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 entries 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 'SL::DB::ShopOrder' => sub { $_[0]->shop_ordernumber },
316 'SL::DB::EmailJournal' => sub { $_[0]->id },
317 UNKNOWN => '9999999999999999',
319 my $number_xtor = sub {
320 my $number = $numbers{ ref($_[0]) };
321 $number = $number->($_[0]) if ref($number) eq 'CODE';
322 return $number || $numbers{UNKNOWN};
324 my $number_comparator = sub {
325 my $number_a = $number_xtor->($a);
326 my $number_b = $number_xtor->($b);
328 ncmp($number_a, $number_b) * $sort_dir;
332 %scores = ( 'SL::DB::SalesProcess' => 10,
333 'SL::DB::RequirementSpec' => 15,
334 'SL::DB::Order' => sub { $scores{ $_[0]->type } },
335 sales_quotation => 20,
337 sales_delivery_order => 40,
338 'SL::DB::DeliveryOrder' => sub { $scores{ $_[0]->type } },
339 'SL::DB::Invoice' => 50,
340 request_quotation => 120,
341 purchase_order => 130,
342 purchase_delivery_order => 140,
343 'SL::DB::PurchaseInvoice' => 150,
344 'SL::DB::PurchaseInvoice' => 150,
345 'SL::DB::Letter' => 200,
346 'SL::DB::ShopOrder' => 250,
347 'SL::DB::EmailJournal' => 300,
350 my $score_xtor = sub {
351 my $score = $scores{ ref($_[0]) };
352 $score = $score->($_[0]) if ref($score) eq 'CODE';
353 return $score || $scores{UNKNOWN};
355 my $type_comparator = sub {
356 my $score_a = $score_xtor->($a);
357 my $score_b = $score_xtor->($b);
359 $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
362 my $today = DateTime->today_local;
363 my $date_xtor = sub {
364 $_[0]->can('transdate_as_date') ? $_[0]->transdate
365 : $_[0]->can('itime_as_date') ? $_[0]->itime->clone->truncate(to => 'day')
368 my $date_comparator = sub {
369 my $date_a = $date_xtor->($a);
370 my $date_b = $date_xtor->($b);
372 ($date_a <=> $date_b) * $sort_dir;
375 my $comparator = $sort_by eq 'number' ? $number_comparator
376 : $sort_by eq 'date' ? $date_comparator
379 return [ sort($comparator @records) ];
382 sub filter_linked_records {
383 my ($self_or_class, $filter, @records) = @_;
385 if ($filter eq 'accessible') {
386 my $employee = SL::DB::Manager::Employee->current;
387 @records = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
389 croak "Unsupported filter parameter '${filter}'";
403 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
407 # In SL::DB::<Object>
408 use SL::DB::Helper::LinkedRecords;
410 # later in consumer code
411 # retrieve all links in both directions
412 my @linked_objects = $order->linked_records;
414 # only links to Invoices
415 my @linked_objects = $order->linked_records(
419 # more than one target
420 my @linked_objects = $order->linked_records(
421 to => [ 'Invoice', 'Order' ],
424 # more than one direction
425 my @linked_objects = $order->linked_records(
429 # more than one direction and different targets
430 my @linked_objects = $order->linked_records(
435 # via over known classes
436 my @linked_objects = $order->linked_records(
438 via => 'DeliveryOrder',
440 my @linked_objects = $order->linked_records(
442 via => [ 'Order', 'DeliveryOrder' ],
446 my @linked_objects = $order->linked_records(
451 # limit direction when further params contain additional keys
452 my %params = (to => 'Invoice', from => 'Order');
453 my @linked_objects = $order->linked_records(
459 $order->link_to_record($invoice);
460 $order->link_to_record($purchase_order, bidirectional => 1);
467 =item C<linked_records %params>
469 Retrieves records linked from or to C<$self> via the table C<record_links>.
471 The optional parameter C<direction> (either C<from>, C<to> or C<both>)
472 determines whether the function retrieves records that link to C<$self> (for
473 C<direction> = C<to>) or that are linked from C<$self> (for C<direction> =
474 C<from>). For C<direction = both> all records linked from or to C<$self> are
477 The optional parameter C<from> or C<to> (same as C<direction>) contains the
478 package names of Rose models for table limitation (the prefix C<SL::DB::> is
479 optional). It can be a single model name as a single scalar or multiple model
480 names in an array reference in which case all links matching any of the model
481 names will be returned.
483 If no parameter C<direction> is given, but any of C<to>, C<from> or C<both>,
484 then C<direction> is inferred accordingly. If neither are given, C<direction> is
487 The optional parameter C<via> can be used to retrieve all documents that may
488 have intermediate documents inbetween. It is an array reference of Rose package
489 names for the models that may be intermediate link targets. One example is
490 retrieving all invoices for a given quotation no matter whether or not orders
491 and delivery orders have been created. If C<via> is given then C<from> or C<to>
492 (depending on C<direction>) must be given as well, and it must then not be an
497 If you only need invoices created directly from an order C<$order> (no
498 delivery orders in between) then the call could look like this:
500 my $invoices = $order->linked_records(
505 Retrieving all invoices from a quotation no matter whether or not
506 orders or delivery orders were created:
508 my $invoices = $quotation->linked_records(
511 via => [ 'Order', 'DeliveryOrder' ],
514 The optional parameter C<query> can be used to limit the records
515 returned. The following call limits the earlier example to invoices
518 my $invoices = $order->linked_records(
521 query => [ transdate => DateTime->today_local ],
524 In case you don't know or care which or how many objects are visited the flag
525 C<recursive> can be used. It searches all reachable objects in the given direction:
527 my $records = $order->linked_records(
532 Only link chains of the same type will be considered. So even with direction
535 order 1 ---> invoice <--- order 2
537 started from order 1 will only find invoice. If an object is found both in each
538 direction, only one copy will be returned. The recursion is cycle protected,
539 and will not recurse infinitely. Cycles are defined by the same link being
540 visited twice, so this
543 order 1 ---> order 2 <--> delivery order
547 will find the path o1 -> o2 -> do -> o2 -> i without considering it a cycle.
549 The optional extra flag C<save_path> will give you extra information saved in
550 the returned objects:
552 my $records = $order->linked_records(
558 Every record will have two fields set:
562 =item C<_record_link_path>
564 An array with the ids of the visited links. The shortest paths will be
565 preferred, so in the previous example this would contain the ids of o1-o2 and
568 =item C<_record_link_depth>
570 Recursion depth when this object was found. Equal to the number of ids in
575 Since record_links is comparatively expensive to call, you will want to cache
576 the results for multiple objects if you know in advance you'll need them.
578 You can pass the optional argument C<batch> with an array ref of ids which will
579 be used instead of the id of the invocant. You still need to call it as a
580 method on a valid object, because table information is inferred from there.
582 C<batch> mode will currenty not work with C<via>.
584 The optional flag C<by_id> will return the objects sorted into a hash instead
585 of a plain array. Calling C<<recursive => 1, batch => [1,2], by_id => 1>> on
588 order 1 --> delivery order 1 --> invoice 1
589 order 2 --> delivery order 2 --> invoice 2
593 { 1 => [ delivery order 1, invoice 1 ],
594 2 => [ delivery order 2, invoice 1 ], }
596 you may then cache these as you see fit.
599 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
600 can be used in order to sort the result. If C<$params{sort_by}> is
601 trueish then the result is sorted by calling L</sort_linked_records>.
603 The optional parameter C<$params{filter}> controls whether or not the
604 result is filtered. Supported values are:
610 Removes all objects for which the function C<may_be_accessed> from the
611 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
612 the current employee.
616 Returns an array reference. Each element returned is a Rose::DB
617 instance. Additionally several elements in the element returned are
618 set to special values:
622 =item C<_record_link_direction>
624 Either C<from> or C<to> indicating the direction. C<from> means that
625 this object is the source in the link.
627 =item C<_record_link>
629 The actual database link object (an instance of L<SL::DB::RecordLink>).
633 =item C<link_to_record $record, %params>
635 Will create an entry in the table C<record_links> with the C<from>
636 side being C<$self> and the C<to> side being C<$record>. Will only
637 insert a new entry if such a link does not already exist.
639 If C<$params{bidirectional}> is trueish then another link will be
640 created with the roles of C<from> and C<to> reversed. This link will
641 also only be created if it doesn't exist already.
643 In scalar context returns either the existing link or the newly
644 created one as an instance of C<SL::DB::RecordLink>. In array context
645 it returns an array of links (one entry if C<$params{bidirectional}>
646 is falsish and two entries if it is trueish).
648 =item C<sort_linked_records $sort_by, $sort_dir, @records>
650 Sorts linked records by C<$sort_by> in the direction given by
651 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
652 can be either a single array reference or or normal array.
654 C<$sort_by> can be one of the following strings:
660 Sort by type first and by record number second. The type order
661 reflects the order in which records are usually processed by the
662 employees: sales processes, sales quotations, sales orders, sales
663 delivery orders, invoices; requests for quotation, purchase orders,
664 purchase delivery orders, purchase invoices.
668 Sort by the record's running number.
672 Sort by the transdate of the record was created or applies to.
674 Note: If the latter has a default setting it will always mask the creation time.
678 Returns an array reference.
680 Can only be called both as a class function since it is not exported.
686 This mixin exports the functions L</linked_records> and
695 * C<recursive> should take a query param depth and cut off there
696 * C<recursive> uses partial distinct which is known to be not terribly fast on
697 a million entry table. replace with a better statement if this ever becomes
702 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
703 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>