1 package SL::DB::Helper::LinkedRecords;
6 our @ISA = qw(Exporter);
7 our @EXPORT = qw(linked_records link_to_record);
13 use SL::DB::Helper::Mappings;
14 use SL::DB::RecordLink;
17 my ($self, %params) = @_;
19 my %sort_spec = ( by => delete($params{sort_by}),
20 dir => delete($params{sort_dir}) );
21 my $filter = delete $params{filter};
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};
30 sub _linked_records_implementation {
34 my $wanted = $params{direction};
37 if ($params{to} && $params{from}) {
39 } elsif ($params{to}) {
41 } elsif ($params{from}) {
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);
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} ) });
56 my %record_map = map { ( ref($_) . $_->id => $_ ) } @records;
58 return [ values %record_map ];
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};
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));
69 my $sub_wanted_table = "${wanted}_table";
70 my $sub_wanted_id = "${wanted}_id";
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 } ];
78 my @get_objects_query = ref($params{query}) eq 'ARRAY' ? @{ $params{query} } : ();
79 my $get_objects = sub {
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;";
85 $_->{_record_link_direction} = $wanted;
86 $_->{_record_link} = $link;
88 } @{ $manager_class->get_all(query => [ id => $link->$sub_wanted_id, @get_objects_query ]) };
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;
97 return [ map { $get_objects->($_) } @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) } ];
100 # More complex handling for the 'via' case.
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;
106 my %seen = map { ($_->meta->table . $_->id => 1) } @sources;
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 );
115 map { $get_objects->($_) }
116 grep { !$seen{$_->$sub_wanted_table . $_->$sub_wanted_id} }
117 @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) };
120 @sources = @new_sources;
121 %seen = map { ($_->meta->table . $_->id => 1) } @sources;
125 my %wanted_tables_map = map { ($_ => 1) } @{ $wanted_tables };
126 return [ grep { $wanted_tables_map{$_->meta->table} } @sources ];
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
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,
138 WHERE ${myself}_id = ? and ${myself}_table = ?
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
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}
148 ORDER BY ${wanted}_table, ${wanted}_id, depth ASC;
150 my $links = selectall_hashref_query($::form, $::form->get_standard_dbh, $query, $self->id, $self->meta->table);
152 return [] unless @$links;
154 my $link_objs = SL::DB::Manager::RecordLink->get_all(query => [ id => [ map { $_->{id} } @$links ] ]);
155 my @objects = map { $get_objects->($_) } @$link_objs;
157 if ($params{save_path}) {
158 my %links_by_id = map { $_->{id} => $_ } @$links;
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};
177 croak "self has no id" unless $self->id;
178 croak "other has no id" unless $other->id;
180 my @directions = ([ 'from', 'to' ]);
181 push @directions, [ 'to', 'from' ] if $params{bidirectional};
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,
191 my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
192 push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save;
195 return wantarray ? @links : $links[0];
198 sub sort_linked_records {
199 my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
201 @records = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
202 $sort_dir = $sort_dir * 1 ? 1 : -1;
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',
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};
218 my $number_comparator = sub {
219 my $number_a = $number_xtor->($a);
220 my $number_b = $number_xtor->($b);
222 ncmp($number_a, $number_b) * $sort_dir;
226 %scores = ( 'SL::DB::SalesProcess' => 10,
227 'SL::DB::RequirementSpec' => 15,
228 'SL::DB::Order' => sub { $scores{ $_[0]->type } },
229 sales_quotation => 20,
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,
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};
247 my $type_comparator = sub {
248 my $score_a = $score_xtor->($a);
249 my $score_b = $score_xtor->($b);
251 $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
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')
260 my $date_comparator = sub {
261 my $date_a = $date_xtor->($a);
262 my $date_b = $date_xtor->($b);
264 ($date_a <=> $date_b) * $sort_dir;
267 my $comparator = $sort_by eq 'number' ? $number_comparator
268 : $sort_by eq 'date' ? $date_comparator
271 return [ sort($comparator @records) ];
274 sub filter_linked_records {
275 my ($self_or_class, $filter, @records) = @_;
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;
281 croak "Unsupported filter parameter '${filter}'";
295 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
299 # In SL::DB::<Object>
300 use SL::DB::Helper::LinkedRecords;
302 # later in consumer code
303 # retrieve all links in both directions
304 my @linked_objects = $order->linked_records;
306 # only links to Invoices
307 my @linked_objects = $order->linked_records(
311 # more than one target
312 my @linked_objects = $order->linked_records(
313 to => [ 'Invoice', 'Order' ],
316 # more than one direction
317 my @linked_objects = $order->linked_records(
321 # more than one direction and different targets
322 my @linked_objects = $order->linked_records(
327 # via over known classes
328 my @linked_objects = $order->linked_records(
330 via => 'DeliveryOrder',
332 my @linked_objects = $order->linked_records(
334 via => [ 'Order', 'DeliveryOrder' ],
338 my @linked_objects = $order->linked_records(
343 # limit direction when further params contain additional keys
344 my %params = (to => 'Invoice', from => 'Order');
345 my @linked_objects = $order->linked_records(
351 $order->link_to_record($invoice);
352 $order->link_to_record($purchase_order, bidirectional => 1);
359 =item C<linked_records %params>
361 Retrieves records linked from or to C<$self> via the table C<record_links>.
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
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.
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
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
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:
392 my $invoices = $order->linked_records(
397 Retrieving all invoices from a quotation no matter whether or not
398 orders or delivery orders were created:
400 my $invoices = $quotation->linked_records(
403 via => [ 'Order', 'DeliveryOrder' ],
406 The optional parameter C<query> can be used to limit the records
407 returned. The following call limits the earlier example to invoices
410 my $invoices = $order->linked_records(
413 query => [ transdate => DateTime->today_local ],
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:
419 my $records = $order->linked_records(
424 Only link chains of the same type will be considered. So even with direction
427 order 1 ---> invoice <--- order 2
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
435 order 1 ---> order 2 <--> delivery order
439 will find the path o1 -> o2 -> do -> o2 -> i without considering it a cycle.
441 The optional extra flag C<save_path> will give you extra information saved in
442 the returned objects:
444 my $records = $order->linked_records(
450 Every record will have two fields set:
454 =item C<_record_link_path>
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
460 =item C<_record_link_depth>
462 Recursion depth when this object was found. Equal to the number of ids in
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>.
472 The optional parameter C<$params{filter}> controls whether or not the
473 result is filtered. Supported values are:
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.
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:
491 =item C<_record_link_direction>
493 Either C<from> or C<to> indicating the direction. C<from> means that
494 this object is the source in the link.
496 =item C<_record_link>
498 The actual database link object (an instance of L<SL::DB::RecordLink>).
502 =item C<link_to_record $record, %params>
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.
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.
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).
517 =item C<sort_linked_records $sort_by, $sort_dir, @records>
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.
523 C<$sort_by> can be one of the following strings:
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.
537 Sort by the record's running number.
541 Sort by the transdate of the record was created or applies to.
543 Note: If the latter has a default setting it will always mask the creation time.
547 Returns an array reference.
549 Can only be called both as a class function since it is not exported.
555 This mixin exports the functions L</linked_records> and
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
571 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
572 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>