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