1 package SL::DB::Helper::LinkedRecords;
6 our @ISA = qw(Exporter);
7 our @EXPORT = qw(linked_records link_to_record);
10 use List::MoreUtils qw(any);
11 use List::UtilsBy qw(uniq_by);
15 use SL::DB::Helper::Mappings;
16 use SL::DB::RecordLink;
19 my ($self, %params) = @_;
21 my %sort_spec = ( by => delete($params{sort_by}),
22 dir => delete($params{sort_dir}) );
23 my $filter = delete $params{filter};
25 my $records = _linked_records_implementation($self, %params);
26 $records = filter_linked_records($self, $filter, @{ $records }) if $filter;
27 $records = sort_linked_records($self, $sort_spec{by}, $sort_spec{dir}, @{ $records }) if $sort_spec{by};
32 sub _linked_records_implementation {
36 my $wanted = $params{direction};
39 if ($params{to} && $params{from}) {
41 } elsif ($params{to}) {
43 } elsif ($params{from}) {
50 if ($wanted eq 'both') {
51 my $both = delete($params{both});
52 my %from_to = ( from => delete($params{from}) || $both,
53 to => delete($params{to}) || $both);
55 if ($params{batch} && $params{by_id}) {
58 _linked_records_implementation($self, %params, direction => 'from', from => $from_to{from}),
59 _linked_records_implementation($self, %params, direction => 'to', to => $from_to{to} ),
62 for my $by_id (@links) {
64 $results{$_} = defined $results{$_}
65 ? [ uniq_by { $_->id } @{ $results{$_} }, @{ $by_id->{$_} } ]
72 my @records = (@{ _linked_records_implementation($self, %params, direction => 'from', from => $from_to{from}) },
73 @{ _linked_records_implementation($self, %params, direction => 'to', to => $from_to{to} ) });
75 my %record_map = map { ( ref($_) . $_->id => $_ ) } @records;
77 return [ values %record_map ];
82 croak("Cannot use 'via' without '${wanted}_table'") if !$params{$wanted};
83 croak("Cannot use 'via' with '${wanted}_table' being an array") if ref $params{$wanted};
86 my $myself = $wanted eq 'from' ? 'to' : $wanted eq 'to' ? 'from' : croak("Invalid parameter `direction'");
87 my $my_table = SL::DB::Helper::Mappings::get_table_for_package(ref($self));
89 my $sub_wanted_table = "${wanted}_table";
90 my $sub_wanted_id = "${wanted}_id";
91 my $sub_myself_id = "${myself}_id";
93 my ($wanted_classes, $wanted_tables);
94 if ($params{$wanted}) {
95 $wanted_classes = ref($params{$wanted}) eq 'ARRAY' ? $params{$wanted} : [ $params{$wanted} ];
96 $wanted_tables = [ map { SL::DB::Helper::Mappings::get_table_for_package($_) || croak("Invalid parameter `${wanted}'") } @{ $wanted_classes } ];
99 my @get_objects_query = ref($params{query}) eq 'ARRAY' ? @{ $params{query} } : ();
100 my $get_objects = sub {
102 return [] unless @$links;
105 push @{ $classes{ $_->$sub_wanted_table } //= [] }, $_->$sub_wanted_id for @$links;
108 for (keys %classes) {
109 my $manager_class = SL::DB::Helper::Mappings::get_manager_package_for_table($_);
110 my $object_class = SL::DB::Helper::Mappings::get_package_for_table($_);
111 eval "require " . $object_class . "; 1;";
113 push @objs, @{ $manager_class->get_all(
114 query => [ id => $classes{$_}, @get_objects_query ],
115 (with_objects => $params{with_objects}) x !!$params{with_objects},
120 my %objs_by_id = map { $_->id => $_ } @objs;
123 if ('ARRAY' eq ref $objs_by_id{$_->$sub_wanted_id}->{_record_link}) {
124 push @{ $objs_by_id{$_->$sub_wanted_id}->{_record_link_direction} }, $wanted;
125 push @{ $objs_by_id{$_->$sub_wanted_id}->{_record_link } }, $_;
126 } elsif ($objs_by_id{$_->$sub_wanted_id}->{_record_link}) {
127 $objs_by_id{$_->$sub_wanted_id}->{_record_link_direction} = [
128 $objs_by_id{$_->$sub_wanted_id}->{_record_link_direction},
131 $objs_by_id{$_->$sub_wanted_id}->{_record_link} = [
132 $objs_by_id{$_->$sub_wanted_id}->{_record_link},
136 $objs_by_id{$_->$sub_wanted_id}->{_record_link_direction} = $wanted;
137 $objs_by_id{$_->$sub_wanted_id}->{_record_link} = $_;
144 # If no 'via' is given then use a simple(r) method for querying the wanted objects.
145 if (!$params{via} && !$params{recursive}) {
146 my @query = ( "${myself}_table" => $my_table,
147 "${myself}_id" => $params{batch} ? $params{batch} : $self->id );
148 push @query, ( "${wanted}_table" => $wanted_tables ) if $wanted_tables;
150 my $links = SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]);
151 my $objs = $get_objects->($links);
153 if ($params{batch} && $params{by_id}) {
159 $_->{_record_link}->$sub_myself_id == $id
162 } @{ $params{batch} }
169 # More complex handling for the 'via' case.
171 die 'batch mode is not supported with via' if $params{batch};
173 my @sources = ( $self );
174 my @targets = map { SL::DB::Helper::Mappings::get_table_for_package($_) } @{ ref($params{via}) ? $params{via} : [ $params{via} ] };
175 push @targets, @{ $wanted_tables } if $wanted_tables;
177 my %seen = map { ($_->meta->table . $_->id => 1) } @sources;
180 my @new_sources = @sources;
181 foreach my $src (@sources) {
182 my @query = ( "${myself}_table" => $src->meta->table,
183 "${myself}_id" => $src->id,
184 "${wanted}_table" => \@targets );
187 grep { !$seen{$_->$sub_wanted_table . $_->$sub_wanted_id} }
188 @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) }
192 @sources = @new_sources;
193 %seen = map { ($_->meta->table . $_->id => 1) } @sources;
197 my %wanted_tables_map = map { ($_ => 1) } @{ $wanted_tables };
198 return [ grep { $wanted_tables_map{$_->meta->table} } @sources ];
201 # And lastly recursive mode
202 if ($params{recursive}) {
203 my ($id_token, @ids);
204 if ($params{batch}) {
205 $id_token = sprintf 'IN (%s)', join ', ', ('?') x @{ $params{batch} };
206 @ids = @{ $params{batch} };
212 # don't use rose retrieval here. too slow.
213 # instead use recursive sql to get all the linked record_links entrys, and retrieve the objects from there
215 WITH RECURSIVE record_links_rec_${wanted}(id, from_table, from_id, to_table, to_id, depth, path, cycle) AS (
216 SELECT id, from_table, from_id, to_table, to_id,
219 WHERE ${myself}_id $id_token and ${myself}_table = ?
221 SELECT rl.id, rl.from_table, rl.from_id, rl.to_table, rl.to_id,
222 rlr.depth + 1, path || rl.id, rl.id = ANY(path)
223 FROM record_links rl, record_links_rec_${wanted} rlr
224 WHERE rlr.${wanted}_id = rl.${myself}_id AND rlr.${wanted}_table = rl.${myself}_table AND NOT cycle
226 SELECT DISTINCT ON (${wanted}_table, ${wanted}_id)
227 id, from_table, from_id, to_table, to_id, path, depth FROM record_links_rec_${wanted}
229 ORDER BY ${wanted}_table, ${wanted}_id, depth ASC;
231 my $links = selectall_hashref_query($::form, $::form->get_standard_dbh, $query, @ids, $self->meta->table);
234 return $params{by_id} ? {} : [];
237 my $link_objs = SL::DB::Manager::RecordLink->get_all(query => [ id => [ map { $_->{id} } @$links ] ]);
238 my $objects = $get_objects->($link_objs);
240 my %links_by_id = map { $_->{id} => $_ } @$links;
242 if ($params{save_path}) {
244 for my $record_link ('ARRAY' eq ref $_->{_record_link} ? @{ $_->{_record_link} } : $_->{_record_link}) {
245 my $link = $links_by_id{$record_link->id};
246 my $intermediate_links = SL::DB::Manager::RecordLink->get_all(query => [ id => $link->{path} ]);
247 $_->{_record_link_path} = $link->{path};
248 $_->{_record_link_obj_path} = $get_objects->($intermediate_links);
249 $_->{_record_link_depth} = $link->{depth};
254 if ($params{batch} && $params{by_id}) {
255 my %link_obj_by_id = map { $_->id => $_ } @$link_objs;
263 $links_by_id{$_->id}->{path}->[0]
264 }->$sub_myself_id == $id
265 } 'ARRAY' eq $_->{_record_link} ? @{ $_->{_record_link} } : $_->{_record_link}
268 } @{ $params{batch} }
281 croak "self has no id" unless $self->id;
282 croak "other has no id" unless $other->id;
284 my @directions = ([ 'from', 'to' ]);
285 push @directions, [ 'to', 'from' ] if $params{bidirectional};
288 foreach my $direction (@directions) {
289 my %data = ( $direction->[0] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($self)),
290 $direction->[0] . "_id" => $self->id,
291 $direction->[1] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($other)),
292 $direction->[1] . "_id" => $other->id,
295 my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
296 push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save;
299 return wantarray ? @links : $links[0];
302 sub sort_linked_records {
303 my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
305 @records = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
306 $sort_dir = $sort_dir * 1 ? 1 : -1;
308 my %numbers = ( 'SL::DB::SalesProcess' => sub { $_[0]->id },
309 'SL::DB::Order' => sub { $_[0]->quotation ? $_[0]->quonumber : $_[0]->ordnumber },
310 'SL::DB::DeliveryOrder' => sub { $_[0]->donumber },
311 'SL::DB::Invoice' => sub { $_[0]->invnumber },
312 'SL::DB::PurchaseInvoice' => sub { $_[0]->invnumber },
313 'SL::DB::RequirementSpec' => sub { $_[0]->id },
314 'SL::DB::Letter' => sub { $_[0]->letternumber },
315 UNKNOWN => '9999999999999999',
317 my $number_xtor = sub {
318 my $number = $numbers{ ref($_[0]) };
319 $number = $number->($_[0]) if ref($number) eq 'CODE';
320 return $number || $numbers{UNKNOWN};
322 my $number_comparator = sub {
323 my $number_a = $number_xtor->($a);
324 my $number_b = $number_xtor->($b);
326 ncmp($number_a, $number_b) * $sort_dir;
330 %scores = ( 'SL::DB::SalesProcess' => 10,
331 'SL::DB::RequirementSpec' => 15,
332 'SL::DB::Order' => sub { $scores{ $_[0]->type } },
333 sales_quotation => 20,
335 sales_delivery_order => 40,
336 'SL::DB::DeliveryOrder' => sub { $scores{ $_[0]->type } },
337 'SL::DB::Invoice' => 50,
338 request_quotation => 120,
339 purchase_order => 130,
340 purchase_delivery_order => 140,
341 'SL::DB::PurchaseInvoice' => 150,
342 'SL::DB::PurchaseInvoice' => 150,
343 'SL::DB::Letter' => 200,
346 my $score_xtor = sub {
347 my $score = $scores{ ref($_[0]) };
348 $score = $score->($_[0]) if ref($score) eq 'CODE';
349 return $score || $scores{UNKNOWN};
351 my $type_comparator = sub {
352 my $score_a = $score_xtor->($a);
353 my $score_b = $score_xtor->($b);
355 $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
358 my $today = DateTime->today_local;
359 my $date_xtor = sub {
360 $_[0]->can('transdate_as_date') ? $_[0]->transdate
361 : $_[0]->can('itime_as_date') ? $_[0]->itime->clone->truncate(to => 'day')
364 my $date_comparator = sub {
365 my $date_a = $date_xtor->($a);
366 my $date_b = $date_xtor->($b);
368 ($date_a <=> $date_b) * $sort_dir;
371 my $comparator = $sort_by eq 'number' ? $number_comparator
372 : $sort_by eq 'date' ? $date_comparator
375 return [ sort($comparator @records) ];
378 sub filter_linked_records {
379 my ($self_or_class, $filter, @records) = @_;
381 if ($filter eq 'accessible') {
382 my $employee = SL::DB::Manager::Employee->current;
383 @records = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
385 croak "Unsupported filter parameter '${filter}'";
399 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
403 # In SL::DB::<Object>
404 use SL::DB::Helper::LinkedRecords;
406 # later in consumer code
407 # retrieve all links in both directions
408 my @linked_objects = $order->linked_records;
410 # only links to Invoices
411 my @linked_objects = $order->linked_records(
415 # more than one target
416 my @linked_objects = $order->linked_records(
417 to => [ 'Invoice', 'Order' ],
420 # more than one direction
421 my @linked_objects = $order->linked_records(
425 # more than one direction and different targets
426 my @linked_objects = $order->linked_records(
431 # via over known classes
432 my @linked_objects = $order->linked_records(
434 via => 'DeliveryOrder',
436 my @linked_objects = $order->linked_records(
438 via => [ 'Order', 'DeliveryOrder' ],
442 my @linked_objects = $order->linked_records(
447 # limit direction when further params contain additional keys
448 my %params = (to => 'Invoice', from => 'Order');
449 my @linked_objects = $order->linked_records(
455 $order->link_to_record($invoice);
456 $order->link_to_record($purchase_order, bidirectional => 1);
463 =item C<linked_records %params>
465 Retrieves records linked from or to C<$self> via the table C<record_links>.
467 The optional parameter C<direction> (either C<from>, C<to> or C<both>)
468 determines whether the function retrieves records that link to C<$self> (for
469 C<direction> = C<to>) or that are linked from C<$self> (for C<direction> =
470 C<from>). For C<direction = both> all records linked from or to C<$self> are
473 The optional parameter C<from> or C<to> (same as C<direction>) contains the
474 package names of Rose models for table limitation (the prefix C<SL::DB::> is
475 optional). It can be a single model name as a single scalar or multiple model
476 names in an array reference in which case all links matching any of the model
477 names will be returned.
479 If no parameter C<direction> is given, but any of C<to>, C<from> or C<both>,
480 then C<direction> is inferred accordingly. If neither are given, C<direction> is
483 The optional parameter C<via> can be used to retrieve all documents that may
484 have intermediate documents inbetween. It is an array reference of Rose package
485 names for the models that may be intermediate link targets. One example is
486 retrieving all invoices for a given quotation no matter whether or not orders
487 and delivery orders have been created. If C<via> is given then C<from> or C<to>
488 (depending on C<direction>) must be given as well, and it must then not be an
493 If you only need invoices created directly from an order C<$order> (no
494 delivery orders in between) then the call could look like this:
496 my $invoices = $order->linked_records(
501 Retrieving all invoices from a quotation no matter whether or not
502 orders or delivery orders were created:
504 my $invoices = $quotation->linked_records(
507 via => [ 'Order', 'DeliveryOrder' ],
510 The optional parameter C<query> can be used to limit the records
511 returned. The following call limits the earlier example to invoices
514 my $invoices = $order->linked_records(
517 query => [ transdate => DateTime->today_local ],
520 In case you don't know or care which or how many objects are visited the flag
521 C<recursive> can be used. It searches all reachable objects in the given direction:
523 my $records = $order->linked_records(
528 Only link chains of the same type will be considered. So even with direction
531 order 1 ---> invoice <--- order 2
533 started from order 1 will only find invoice. If an object is found both in each
534 direction, only one copy will be returned. The recursion is cycle protected,
535 and will not recurse infinitely. Cycles are defined by the same link being
536 visited twice, so this
539 order 1 ---> order 2 <--> delivery order
543 will find the path o1 -> o2 -> do -> o2 -> i without considering it a cycle.
545 The optional extra flag C<save_path> will give you extra information saved in
546 the returned objects:
548 my $records = $order->linked_records(
554 Every record will have two fields set:
558 =item C<_record_link_path>
560 An array with the ids of the visited links. The shortest paths will be
561 preferred, so in the previous example this would contain the ids of o1-o2 and
564 =item C<_record_link_depth>
566 Recursion depth when this object was found. Equal to the number of ids in
571 Since record_links is comparatively expensive to call, you will want to cache
572 the results for multiple objects if you know in advance you'll need them.
574 You can pass the optional argument C<batch> with an array ref of ids which will
575 be used instead of the id of the invocant. You still need to call it as a
576 method on a valid object, because table information is inferred from there.
578 C<batch> mode will currenty not work with C<via>.
580 The optional flag C<by_id> will return the objects sorted into a hash instead
581 of a plain array. Calling C<<recursive => 1, batch => [1,2], by_id => 1>> on
584 order 1 --> delivery order 1 --> invoice 1
585 order 2 --> delivery order 2 --> invoice 2
589 { 1 => [ delivery order 1, invoice 1 ],
590 2 => [ delivery order 2, invoice 1 ], }
592 you may then cache these as you see fit.
595 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
596 can be used in order to sort the result. If C<$params{sort_by}> is
597 trueish then the result is sorted by calling L</sort_linked_records>.
599 The optional parameter C<$params{filter}> controls whether or not the
600 result is filtered. Supported values are:
606 Removes all objects for which the function C<may_be_accessed> from the
607 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
608 the current employee.
612 Returns an array reference. Each element returned is a Rose::DB
613 instance. Additionally several elements in the element returned are
614 set to special values:
618 =item C<_record_link_direction>
620 Either C<from> or C<to> indicating the direction. C<from> means that
621 this object is the source in the link.
623 =item C<_record_link>
625 The actual database link object (an instance of L<SL::DB::RecordLink>).
629 =item C<link_to_record $record, %params>
631 Will create an entry in the table C<record_links> with the C<from>
632 side being C<$self> and the C<to> side being C<$record>. Will only
633 insert a new entry if such a link does not already exist.
635 If C<$params{bidirectional}> is trueish then another link will be
636 created with the roles of C<from> and C<to> reversed. This link will
637 also only be created if it doesn't exist already.
639 In scalar context returns either the existing link or the newly
640 created one as an instance of C<SL::DB::RecordLink>. In array context
641 it returns an array of links (one entry if C<$params{bidirectional}>
642 is falsish and two entries if it is trueish).
644 =item C<sort_linked_records $sort_by, $sort_dir, @records>
646 Sorts linked records by C<$sort_by> in the direction given by
647 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
648 can be either a single array reference or or normal array.
650 C<$sort_by> can be one of the following strings:
656 Sort by type first and by record number second. The type order
657 reflects the order in which records are usually processed by the
658 employees: sales processes, sales quotations, sales orders, sales
659 delivery orders, invoices; requests for quotation, purchase orders,
660 purchase delivery orders, purchase invoices.
664 Sort by the record's running number.
668 Sort by the transdate of the record was created or applies to.
670 Note: If the latter has a default setting it will always mask the creation time.
674 Returns an array reference.
676 Can only be called both as a class function since it is not exported.
682 This mixin exports the functions L</linked_records> and
691 * C<recursive> should take a query param depth and cut off there
692 * C<recursive> uses partial distinct which is known to be not terribly fast on
693 a million entry table. replace with a better statement if this ever becomes
698 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
699 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>