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