SL/DB/Helper/LinkedRecords.pm

   1 package SL::DB::Helper::LinkedRecords;
   2
   3 use strict;
   4
   5 require Exporter;
   6 our @ISA    = qw(Exporter);
   7 our @EXPORT = qw(linked_records link_to_record);
   8
   9 use Carp;
  10 use Sort::Naturally;
  11 use SL::DBUtils;
  12
  13 use SL::DB::Helper::Mappings;
  14 use SL::DB::RecordLink;
  15
  16 sub linked_records {
  17   my ($self, %params) = @_;
  18
  19   my %sort_spec       = ( by  => delete($params{sort_by}),
  20                           dir => delete($params{sort_dir}) );
  21   my $filter          =  delete $params{filter};
  22
  23   my $records         = _linked_records_implementation($self, %params);
  24   $records            = filter_linked_records($self, $filter, @{ $records })                       if $filter;
  25   $records            = sort_linked_records($self, $sort_spec{by}, $sort_spec{dir}, @{ $records }) if $sort_spec{by};
  26
  27   return $records;
  28 }
  29
  30 sub _linked_records_implementation {
  31   my $self     = shift;
  32   my %params   = @_;
  33
  34   my $wanted   = $params{direction};
  35
  36   if (!$wanted) {
  37     if ($params{to} && $params{from}) {
  38       $wanted = 'both';
  39     } elsif ($params{to}) {
  40       $wanted = 'to';
  41     } elsif ($params{from}) {
  42       $wanted = 'from';
  43     } else {
  44       $wanted = 'both';
  45     }
  46   }
  47
  48   if ($wanted eq 'both') {
  49     my $both       = delete($params{both});
  50     my %from_to    = ( from => delete($params{from}) || $both,
  51                        to   => delete($params{to})   || $both);
  52
  53     my @records    = (@{ _linked_records_implementation($self, %params, direction => 'from', from => $from_to{from}) },
  54                       @{ _linked_records_implementation($self, %params, direction => 'to',   to   => $from_to{to}  ) });
  55
  56     my %record_map = map { ( ref($_) . $_->id => $_ ) } @records;
  57
  58     return [ values %record_map ];
  59   }
  60
  61   if ($params{via}) {
  62     croak("Cannot use 'via' without '${wanted}_table'")             if !$params{$wanted};
  63     croak("Cannot use 'via' with '${wanted}_table' being an array") if ref $params{$wanted};
  64   }
  65
  66   my $myself           = $wanted eq 'from' ? 'to' : $wanted eq 'to' ? 'from' : croak("Invalid parameter `direction'");
  67   my $my_table         = SL::DB::Helper::Mappings::get_table_for_package(ref($self));
  68
  69   my $sub_wanted_table = "${wanted}_table";
  70   my $sub_wanted_id    = "${wanted}_id";
  71
  72   my ($wanted_classes, $wanted_tables);
  73   if ($params{$wanted}) {
  74     $wanted_classes = ref($params{$wanted}) eq 'ARRAY' ? $params{$wanted} : [ $params{$wanted} ];
  75     $wanted_tables  = [ map { SL::DB::Helper::Mappings::get_table_for_package($_) || croak("Invalid parameter `${wanted}'") } @{ $wanted_classes } ];
  76   }
  77
  78   my @get_objects_query = ref($params{query}) eq 'ARRAY' ? @{ $params{query} } : ();
  79   my $get_objects       = sub {
  80     my ($link)        = @_;
  81     my $manager_class = SL::DB::Helper::Mappings::get_manager_package_for_table($link->$sub_wanted_table);
  82     my $object_class  = SL::DB::Helper::Mappings::get_package_for_table($link->$sub_wanted_table);
  83     eval "require " . $object_class . "; 1;";
  84     return map {
  85       $_->{_record_link_direction} = $wanted;
  86       $_->{_record_link}           = $link;
  87       $_
  88     } @{
  89       $manager_class->get_all(
  90         query         => [ id => $link->$sub_wanted_id, @get_objects_query ],
  91         (with_objects => $params{with_objects}) x !!$params{with_objects},
  92       )
  93     };
  94   };
  95
  96   # If no 'via' is given then use a simple(r) method for querying the wanted objects.
  97   if (!$params{via} && !$params{recursive}) {
  98     my @query = ( "${myself}_table" => $my_table,
  99                   "${myself}_id"    => $self->id );
 100     push @query, ( "${wanted}_table" => $wanted_tables ) if $wanted_tables;
 101
 102     return [ map { $get_objects->($_) } @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) } ];
 103   }
 104
 105   # More complex handling for the 'via' case.
 106   if ($params{via}) {
 107     my @sources = ( $self );
 108     my @targets = map { SL::DB::Helper::Mappings::get_table_for_package($_) } @{ ref($params{via}) ? $params{via} : [ $params{via} ] };
 109     push @targets, @{ $wanted_tables } if $wanted_tables;
 110
 111     my %seen = map { ($_->meta->table . $_->id => 1) } @sources;
 112
 113     while (@targets) {
 114       my @new_sources = @sources;
 115       foreach my $src (@sources) {
 116         my @query = ( "${myself}_table" => $src->meta->table,
 117                       "${myself}_id"    => $src->id,
 118                       "${wanted}_table" => \@targets );
 119         push @new_sources,
 120              map  { $get_objects->($_) }
 121              grep { !$seen{$_->$sub_wanted_table . $_->$sub_wanted_id} }
 122              @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) };
 123       }
 124
 125       @sources = @new_sources;
 126       %seen    = map { ($_->meta->table . $_->id => 1) } @sources;
 127       shift @targets;
 128     }
 129
 130     my %wanted_tables_map = map  { ($_ => 1) } @{ $wanted_tables };
 131     return [ grep { $wanted_tables_map{$_->meta->table} } @sources ];
 132   }
 133
 134   # And lastly recursive mode
 135   if ($params{recursive}) {
 136     # don't use rose retrieval here. too slow.
 137     # instead use recursive sql to get all the linked record_links entrys, and retrieve the objects from there
 138     my $query = <<"";
 139       WITH RECURSIVE record_links_rec_${wanted}(id, from_table, from_id, to_table, to_id, depth, path, cycle) AS (
 140         SELECT id, from_table, from_id, to_table, to_id,
 141           1, ARRAY[id], false
 142         FROM record_links
 143         WHERE ${myself}_id = ? and ${myself}_table = ?
 144       UNION ALL
 145         SELECT rl.id, rl.from_table, rl.from_id, rl.to_table, rl.to_id,
 146           rlr.depth + 1, path || rl.id, rl.id = ANY(path)
 147         FROM record_links rl, record_links_rec_${wanted} rlr
 148         WHERE rlr.${wanted}_id = rl.${myself}_id AND rlr.${wanted}_table = rl.${myself}_table AND NOT cycle
 149       )
 150       SELECT DISTINCT ON (${wanted}_table, ${wanted}_id)
 151         id, from_table, from_id, to_table, to_id, path, depth FROM record_links_rec_${wanted}
 152       WHERE NOT cycle
 153       ORDER BY ${wanted}_table, ${wanted}_id, depth ASC;
 154
 155     my $links     = selectall_hashref_query($::form, $::form->get_standard_dbh, $query, $self->id, $self->meta->table);
 156
 157     return [] unless @$links;
 158
 159     my $link_objs = SL::DB::Manager::RecordLink->get_all(query => [ id => [ map { $_->{id} } @$links ] ]);
 160     my @objects = map { $get_objects->($_) } @$link_objs;
 161
 162     if ($params{save_path}) {
 163        my %links_by_id = map { $_->{id} => $_ } @$links;
 164        for (@objects) {
 165          my $link = $links_by_id{$_->{_record_link}->id};
 166          my $intermediate_links = SL::DB::Manager::RecordLink->get_all(query => [ id => $link->{path} ]);
 167          $_->{_record_link_path}     = $link->{path};
 168          $_->{_record_link_obj_path} = [ map { $get_objects->($_) } @$intermediate_links ];
 169          $_->{_record_link_depth}    = $link->{depth};
 170        }
 171     }
 172
 173     return \@objects;
 174   }
 175 }
 176
 177 sub link_to_record {
 178   my $self   = shift;
 179   my $other  = shift;
 180   my %params = @_;
 181
 182   croak "self has no id"  unless $self->id;
 183   croak "other has no id" unless $other->id;
 184
 185   my @directions = ([ 'from', 'to' ]);
 186   push @directions, [ 'to', 'from' ] if $params{bidirectional};
 187   my @links;
 188
 189   foreach my $direction (@directions) {
 190     my %data = ( $direction->[0] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($self)),
 191                  $direction->[0] . "_id"    => $self->id,
 192                  $direction->[1] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($other)),
 193                  $direction->[1] . "_id"    => $other->id,
 194                );
 195
 196     my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
 197     push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save;
 198   }
 199
 200   return wantarray ? @links : $links[0];
 201 }
 202
 203 sub sort_linked_records {
 204   my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
 205
 206   @records  = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
 207   $sort_dir = $sort_dir * 1 ? 1 : -1;
 208
 209   my %numbers = ( 'SL::DB::SalesProcess'    => sub { $_[0]->id },
 210                   'SL::DB::Order'           => sub { $_[0]->quotation ? $_[0]->quonumber : $_[0]->ordnumber },
 211                   'SL::DB::DeliveryOrder'   => sub { $_[0]->donumber },
 212                   'SL::DB::Invoice'         => sub { $_[0]->invnumber },
 213                   'SL::DB::PurchaseInvoice' => sub { $_[0]->invnumber },
 214                   'SL::DB::RequirementSpec' => sub { $_[0]->id },
 215                   'SL::DB::Letter'          => sub { $_[0]->letternumber },
 216                   UNKNOWN                   => '9999999999999999',
 217                 );
 218   my $number_xtor = sub {
 219     my $number = $numbers{ ref($_[0]) };
 220     $number    = $number->($_[0]) if ref($number) eq 'CODE';
 221     return $number || $numbers{UNKNOWN};
 222   };
 223   my $number_comparator = sub {
 224     my $number_a = $number_xtor->($a);
 225     my $number_b = $number_xtor->($b);
 226
 227     ncmp($number_a, $number_b) * $sort_dir;
 228   };
 229
 230   my %scores;
 231   %scores = ( 'SL::DB::SalesProcess'    =>  10,
 232               'SL::DB::RequirementSpec' =>  15,
 233               'SL::DB::Order'           =>  sub { $scores{ $_[0]->type } },
 234               sales_quotation           =>  20,
 235               sales_order               =>  30,
 236               sales_delivery_order      =>  40,
 237               'SL::DB::DeliveryOrder'   =>  sub { $scores{ $_[0]->type } },
 238               'SL::DB::Invoice'         =>  50,
 239               request_quotation         => 120,
 240               purchase_order            => 130,
 241               purchase_delivery_order   => 140,
 242               'SL::DB::PurchaseInvoice' => 150,
 243               'SL::DB::PurchaseInvoice' => 150,
 244               'SL::DB::Letter'          => 200,
 245               UNKNOWN                   => 999,
 246             );
 247   my $score_xtor = sub {
 248     my $score = $scores{ ref($_[0]) };
 249     $score    = $score->($_[0]) if ref($score) eq 'CODE';
 250     return $score || $scores{UNKNOWN};
 251   };
 252   my $type_comparator = sub {
 253     my $score_a = $score_xtor->($a);
 254     my $score_b = $score_xtor->($b);
 255
 256     $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
 257   };
 258
 259   my $today     = DateTime->today_local;
 260   my $date_xtor = sub {
 261       $_[0]->can('transdate_as_date') ? $_[0]->transdate
 262     : $_[0]->can('itime_as_date')     ? $_[0]->itime->clone->truncate(to => 'day')
 263     :                                   $today;
 264   };
 265   my $date_comparator = sub {
 266     my $date_a = $date_xtor->($a);
 267     my $date_b = $date_xtor->($b);
 268
 269     ($date_a <=> $date_b) * $sort_dir;
 270   };
 271
 272   my $comparator = $sort_by eq 'number' ? $number_comparator
 273                  : $sort_by eq 'date'   ? $date_comparator
 274                  :                        $type_comparator;
 275
 276   return [ sort($comparator @records) ];
 277 }
 278
 279 sub filter_linked_records {
 280   my ($self_or_class, $filter, @records) = @_;
 281
 282   if ($filter eq 'accessible') {
 283     my $employee = SL::DB::Manager::Employee->current;
 284     @records     = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
 285   } else {
 286     croak "Unsupported filter parameter '${filter}'";
 287   }
 288
 289   return \@records;
 290 }
 291
 292 1;
 293
 294 __END__
 295
 296 =encoding utf8
 297
 298 =head1 NAME
 299
 300 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
 301
 302 SYNOPSIS
 303
 304   # In SL::DB::<Object>
 305   use SL::DB::Helper::LinkedRecords;
 306
 307   # later in consumer code
 308   # retrieve all links in both directions
 309   my @linked_objects = $order->linked_records;
 310
 311   # only links to Invoices
 312   my @linked_objects = $order->linked_records(
 313     to        => 'Invoice',
 314   );
 315
 316   # more than one target
 317   my @linked_objects = $order->linked_records(
 318     to        => [ 'Invoice', 'Order' ],
 319   );
 320
 321   # more than one direction
 322   my @linked_objects = $order->linked_records(
 323     both      => 'Invoice',
 324   );
 325
 326   # more than one direction and different targets
 327   my @linked_objects = $order->linked_records(
 328     to        => 'Invoice',
 329     from      => 'Order',
 330   );
 331
 332   # via over known classes
 333   my @linked_objects = $order->linked_records(
 334     to        => 'Invoice',
 335     via       => 'DeliveryOrder',
 336   );
 337   my @linked_objects = $order->linked_records(
 338     to        => 'Invoice',
 339     via       => [ 'Order', 'DeliveryOrder' ],
 340   );
 341
 342   # recursive
 343   my @linked_objects = $order->linked_records(
 344     recursive => 1,
 345   );
 346
 347
 348   # limit direction when further params contain additional keys
 349   my %params = (to => 'Invoice', from => 'Order');
 350   my @linked_objects = $order->linked_records(
 351     direction => 'to',
 352     %params,
 353   );
 354
 355   # add a new link
 356   $order->link_to_record($invoice);
 357   $order->link_to_record($purchase_order, bidirectional => 1);
 358
 359
 360 =head1 FUNCTIONS
 361
 362 =over 4
 363
 364 =item C<linked_records %params>
 365
 366 Retrieves records linked from or to C<$self> via the table C<record_links>.
 367
 368 The optional parameter C<direction> (either C<from>, C<to> or C<both>)
 369 determines whether the function retrieves records that link to C<$self> (for
 370 C<direction> = C<to>) or that are linked from C<$self> (for C<direction> =
 371 C<from>). For C<direction = both> all records linked from or to C<$self> are
 372 returned.
 373
 374 The optional parameter C<from> or C<to> (same as C<direction>) contains the
 375 package names of Rose models for table limitation (the prefix C<SL::DB::> is
 376 optional). It can be a single model name as a single scalar or multiple model
 377 names in an array reference in which case all links matching any of the model
 378 names will be returned.
 379
 380 If no parameter C<direction> is given, but any of C<to>, C<from> or C<both>,
 381 then C<direction> is inferred accordingly. If neither are given, C<direction> is
 382 set to C<both>.
 383
 384 The optional parameter C<via> can be used to retrieve all documents that may
 385 have intermediate documents inbetween. It is an array reference of Rose package
 386 names for the models that may be intermediate link targets. One example is
 387 retrieving all invoices for a given quotation no matter whether or not orders
 388 and delivery orders have been created. If C<via> is given then C<from> or C<to>
 389 (depending on C<direction>) must be given as well, and it must then not be an
 390 array reference.
 391
 392 Examples:
 393
 394 If you only need invoices created directly from an order C<$order> (no
 395 delivery orders in between) then the call could look like this:
 396
 397   my $invoices = $order->linked_records(
 398     direction => 'to',
 399     to        => 'Invoice',
 400   );
 401
 402 Retrieving all invoices from a quotation no matter whether or not
 403 orders or delivery orders were created:
 404
 405   my $invoices = $quotation->linked_records(
 406     direction => 'to',
 407     to        => 'Invoice',
 408     via       => [ 'Order', 'DeliveryOrder' ],
 409   );
 410
 411 The optional parameter C<query> can be used to limit the records
 412 returned. The following call limits the earlier example to invoices
 413 created today:
 414
 415   my $invoices = $order->linked_records(
 416     direction => 'to',
 417     to        => 'Invoice',
 418     query     => [ transdate => DateTime->today_local ],
 419   );
 420
 421 In case you don't know or care which or how many objects are visited the flag
 422 C<recursive> can be used. It searches all reachable objects in the given direction:
 423
 424   my $records = $order->linked_records(
 425     direction => 'to',
 426     recursive => 1,
 427   );
 428
 429 Only link chains of the same type will be considered. So even with direction
 430 both, this
 431
 432   order 1 ---> invoice <--- order 2
 433
 434 started from order 1 will only find invoice. If an object is found both in each
 435 direction, only one copy will be returned. The recursion is cycle protected,
 436 and will not recurse infinitely. Cycles are defined by the same link being
 437 visited twice, so this
 438
 439
 440   order 1 ---> order 2 <--> delivery order
 441                  |
 442                  `--------> invoice
 443
 444 will find the path o1 -> o2 -> do -> o2 -> i without considering it a cycle.
 445
 446 The optional extra flag C<save_path> will give you extra information saved in
 447 the returned objects:
 448
 449   my $records = $order->linked_records(
 450     direction => 'to',
 451     recursive => 1,
 452     save_path => 1,
 453   );
 454
 455 Every record will have two fields set:
 456
 457 =over 2
 458
 459 =item C<_record_link_path>
 460
 461 An array with the ids of the visited links. The shortest paths will be
 462 preferred, so in the previous example this would contain the ids of o1-o2 and
 463 o2-i.
 464
 465 =item C<_record_link_depth>
 466
 467 Recursion depth when this object was found. Equal to the number of ids in
 468 C<_record_link_path>
 469
 470 =back
 471
 472
 473 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
 474 can be used in order to sort the result. If C<$params{sort_by}> is
 475 trueish then the result is sorted by calling L</sort_linked_records>.
 476
 477 The optional parameter C<$params{filter}> controls whether or not the
 478 result is filtered. Supported values are:
 479
 480 =over 2
 481
 482 =item C<accessible>
 483
 484 Removes all objects for which the function C<may_be_accessed> from the
 485 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
 486 the current employee.
 487
 488 =back
 489
 490 Returns an array reference. Each element returned is a Rose::DB
 491 instance. Additionally several elements in the element returned are
 492 set to special values:
 493
 494 =over 2
 495
 496 =item C<_record_link_direction>
 497
 498 Either C<from> or C<to> indicating the direction. C<from> means that
 499 this object is the source in the link.
 500
 501 =item C<_record_link>
 502
 503 The actual database link object (an instance of L<SL::DB::RecordLink>).
 504
 505 =back
 506
 507 =item C<link_to_record $record, %params>
 508
 509 Will create an entry in the table C<record_links> with the C<from>
 510 side being C<$self> and the C<to> side being C<$record>. Will only
 511 insert a new entry if such a link does not already exist.
 512
 513 If C<$params{bidirectional}> is trueish then another link will be
 514 created with the roles of C<from> and C<to> reversed. This link will
 515 also only be created if it doesn't exist already.
 516
 517 In scalar context returns either the existing link or the newly
 518 created one as an instance of C<SL::DB::RecordLink>. In array context
 519 it returns an array of links (one entry if C<$params{bidirectional}>
 520 is falsish and two entries if it is trueish).
 521
 522 =item C<sort_linked_records $sort_by, $sort_dir, @records>
 523
 524 Sorts linked records by C<$sort_by> in the direction given by
 525 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
 526 can be either a single array reference or or normal array.
 527
 528 C<$sort_by> can be one of the following strings:
 529
 530 =over 2
 531
 532 =item * C<type>
 533
 534 Sort by type first and by record number second. The type order
 535 reflects the order in which records are usually processed by the
 536 employees: sales processes, sales quotations, sales orders, sales
 537 delivery orders, invoices; requests for quotation, purchase orders,
 538 purchase delivery orders, purchase invoices.
 539
 540 =item * C<number>
 541
 542 Sort by the record's running number.
 543
 544 =item * C<date>
 545
 546 Sort by the transdate of the record was created or applies to.
 547
 548 Note: If the latter has a default setting it will always mask the creation time.
 549
 550 =back
 551
 552 Returns an array reference.
 553
 554 Can only be called both as a class function since it is not exported.
 555
 556 =back
 557
 558 =head1 EXPORTS
 559
 560 This mixin exports the functions L</linked_records> and
 561 L</link_to_record>.
 562
 563 =head1 BUGS
 564
 565 Nothing here yet.
 566
 567 =head1 TODO
 568
 569  * C<recursive> should take a query param depth and cut off there
 570  * C<recursive> uses partial distinct which is known to be not terribly fast on
 571    a million entry table. replace with a better statement if this ever becomes
 572    an issue.
 573
 574 =head1 AUTHOR
 575
 576 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 577 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 578
 579 =cut