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