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;
89 $manager_class->get_all(
90 query => [ id => $link->$sub_wanted_id, @get_objects_query ],
91 (with_objects => $params{with_objects}) x !!$params{with_objects},
97 # If no 'via' is given then use a simple(r) method for querying the wanted objects.
98 if (!$params{via} && !$params{recursive}) {
99 my @query = ( "${myself}_table" => $my_table,
100 "${myself}_id" => $self->id );
101 push @query, ( "${wanted}_table" => $wanted_tables ) if $wanted_tables;
103 return [ map { $get_objects->($_) } @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) } ];
106 # More complex handling for the 'via' case.
108 my @sources = ( $self );
109 my @targets = map { SL::DB::Helper::Mappings::get_table_for_package($_) } @{ ref($params{via}) ? $params{via} : [ $params{via} ] };
110 push @targets, @{ $wanted_tables } if $wanted_tables;
112 my %seen = map { ($_->meta->table . $_->id => 1) } @sources;
115 my @new_sources = @sources;
116 foreach my $src (@sources) {
117 my @query = ( "${myself}_table" => $src->meta->table,
118 "${myself}_id" => $src->id,
119 "${wanted}_table" => \@targets );
121 map { $get_objects->($_) }
122 grep { !$seen{$_->$sub_wanted_table . $_->$sub_wanted_id} }
123 @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) };
126 @sources = @new_sources;
127 %seen = map { ($_->meta->table . $_->id => 1) } @sources;
131 my %wanted_tables_map = map { ($_ => 1) } @{ $wanted_tables };
132 return [ grep { $wanted_tables_map{$_->meta->table} } @sources ];
135 # And lastly recursive mode
136 if ($params{recursive}) {
137 # don't use rose retrieval here. too slow.
138 # instead use recursive sql to get all the linked record_links entrys, and retrieve the objects from there
140 WITH RECURSIVE record_links_rec_${wanted}(id, from_table, from_id, to_table, to_id, depth, path, cycle) AS (
141 SELECT id, from_table, from_id, to_table, to_id,
144 WHERE ${myself}_id = ? and ${myself}_table = ?
146 SELECT rl.id, rl.from_table, rl.from_id, rl.to_table, rl.to_id,
147 rlr.depth + 1, path || rl.id, rl.id = ANY(path)
148 FROM record_links rl, record_links_rec_${wanted} rlr
149 WHERE rlr.${wanted}_id = rl.${myself}_id AND rlr.${wanted}_table = rl.${myself}_table AND NOT cycle
151 SELECT DISTINCT ON (${wanted}_table, ${wanted}_id)
152 id, from_table, from_id, to_table, to_id, path, depth FROM record_links_rec_${wanted}
154 ORDER BY ${wanted}_table, ${wanted}_id, depth ASC;
156 my $links = selectall_hashref_query($::form, $::form->get_standard_dbh, $query, $self->id, $self->meta->table);
158 return [] unless @$links;
160 my $link_objs = SL::DB::Manager::RecordLink->get_all(query => [ id => [ map { $_->{id} } @$links ] ]);
161 my @objects = map { $get_objects->($_) } @$link_objs;
163 if ($params{save_path}) {
164 my %links_by_id = map { $_->{id} => $_ } @$links;
166 my $link = $links_by_id{$_->{_record_link}->id};
167 my $intermediate_links = SL::DB::Manager::RecordLink->get_all(query => [ id => $link->{path} ]);
168 $_->{_record_link_path} = $link->{path};
169 $_->{_record_link_obj_path} = [ map { $get_objects->($_) } @$intermediate_links ];
170 $_->{_record_link_depth} = $link->{depth};
183 croak "self has no id" unless $self->id;
184 croak "other has no id" unless $other->id;
186 my @directions = ([ 'from', 'to' ]);
187 push @directions, [ 'to', 'from' ] if $params{bidirectional};
190 foreach my $direction (@directions) {
191 my %data = ( $direction->[0] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($self)),
192 $direction->[0] . "_id" => $self->id,
193 $direction->[1] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($other)),
194 $direction->[1] . "_id" => $other->id,
197 my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
198 push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save;
201 return wantarray ? @links : $links[0];
204 sub sort_linked_records {
205 my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
207 @records = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
208 $sort_dir = $sort_dir * 1 ? 1 : -1;
210 my %numbers = ( 'SL::DB::SalesProcess' => sub { $_[0]->id },
211 'SL::DB::Order' => sub { $_[0]->quotation ? $_[0]->quonumber : $_[0]->ordnumber },
212 'SL::DB::DeliveryOrder' => sub { $_[0]->donumber },
213 'SL::DB::Invoice' => sub { $_[0]->invnumber },
214 'SL::DB::PurchaseInvoice' => sub { $_[0]->invnumber },
215 'SL::DB::RequirementSpec' => sub { $_[0]->id },
216 'SL::DB::Letter' => sub { $_[0]->letternumber },
217 UNKNOWN => '9999999999999999',
219 my $number_xtor = sub {
220 my $number = $numbers{ ref($_[0]) };
221 $number = $number->($_[0]) if ref($number) eq 'CODE';
222 return $number || $numbers{UNKNOWN};
224 my $number_comparator = sub {
225 my $number_a = $number_xtor->($a);
226 my $number_b = $number_xtor->($b);
228 ncmp($number_a, $number_b) * $sort_dir;
232 %scores = ( 'SL::DB::SalesProcess' => 10,
233 'SL::DB::RequirementSpec' => 15,
234 'SL::DB::Order' => sub { $scores{ $_[0]->type } },
235 sales_quotation => 20,
237 sales_delivery_order => 40,
238 'SL::DB::DeliveryOrder' => sub { $scores{ $_[0]->type } },
239 'SL::DB::Invoice' => 50,
240 request_quotation => 120,
241 purchase_order => 130,
242 purchase_delivery_order => 140,
243 'SL::DB::PurchaseInvoice' => 150,
244 'SL::DB::PurchaseInvoice' => 150,
245 'SL::DB::Letter' => 200,
248 my $score_xtor = sub {
249 my $score = $scores{ ref($_[0]) };
250 $score = $score->($_[0]) if ref($score) eq 'CODE';
251 return $score || $scores{UNKNOWN};
253 my $type_comparator = sub {
254 my $score_a = $score_xtor->($a);
255 my $score_b = $score_xtor->($b);
257 $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
260 my $today = DateTime->today_local;
261 my $date_xtor = sub {
262 $_[0]->can('transdate_as_date') ? $_[0]->transdate
263 : $_[0]->can('itime_as_date') ? $_[0]->itime->clone->truncate(to => 'day')
266 my $date_comparator = sub {
267 my $date_a = $date_xtor->($a);
268 my $date_b = $date_xtor->($b);
270 ($date_a <=> $date_b) * $sort_dir;
273 my $comparator = $sort_by eq 'number' ? $number_comparator
274 : $sort_by eq 'date' ? $date_comparator
277 return [ sort($comparator @records) ];
280 sub filter_linked_records {
281 my ($self_or_class, $filter, @records) = @_;
283 if ($filter eq 'accessible') {
284 my $employee = SL::DB::Manager::Employee->current;
285 @records = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
287 croak "Unsupported filter parameter '${filter}'";
301 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
305 # In SL::DB::<Object>
306 use SL::DB::Helper::LinkedRecords;
308 # later in consumer code
309 # retrieve all links in both directions
310 my @linked_objects = $order->linked_records;
312 # only links to Invoices
313 my @linked_objects = $order->linked_records(
317 # more than one target
318 my @linked_objects = $order->linked_records(
319 to => [ 'Invoice', 'Order' ],
322 # more than one direction
323 my @linked_objects = $order->linked_records(
327 # more than one direction and different targets
328 my @linked_objects = $order->linked_records(
333 # via over known classes
334 my @linked_objects = $order->linked_records(
336 via => 'DeliveryOrder',
338 my @linked_objects = $order->linked_records(
340 via => [ 'Order', 'DeliveryOrder' ],
344 my @linked_objects = $order->linked_records(
349 # limit direction when further params contain additional keys
350 my %params = (to => 'Invoice', from => 'Order');
351 my @linked_objects = $order->linked_records(
357 $order->link_to_record($invoice);
358 $order->link_to_record($purchase_order, bidirectional => 1);
365 =item C<linked_records %params>
367 Retrieves records linked from or to C<$self> via the table C<record_links>.
369 The optional parameter C<direction> (either C<from>, C<to> or C<both>)
370 determines whether the function retrieves records that link to C<$self> (for
371 C<direction> = C<to>) or that are linked from C<$self> (for C<direction> =
372 C<from>). For C<direction = both> all records linked from or to C<$self> are
375 The optional parameter C<from> or C<to> (same as C<direction>) contains the
376 package names of Rose models for table limitation (the prefix C<SL::DB::> is
377 optional). It can be a single model name as a single scalar or multiple model
378 names in an array reference in which case all links matching any of the model
379 names will be returned.
381 If no parameter C<direction> is given, but any of C<to>, C<from> or C<both>,
382 then C<direction> is inferred accordingly. If neither are given, C<direction> is
385 The optional parameter C<via> can be used to retrieve all documents that may
386 have intermediate documents inbetween. It is an array reference of Rose package
387 names for the models that may be intermediate link targets. One example is
388 retrieving all invoices for a given quotation no matter whether or not orders
389 and delivery orders have been created. If C<via> is given then C<from> or C<to>
390 (depending on C<direction>) must be given as well, and it must then not be an
395 If you only need invoices created directly from an order C<$order> (no
396 delivery orders in between) then the call could look like this:
398 my $invoices = $order->linked_records(
403 Retrieving all invoices from a quotation no matter whether or not
404 orders or delivery orders were created:
406 my $invoices = $quotation->linked_records(
409 via => [ 'Order', 'DeliveryOrder' ],
412 The optional parameter C<query> can be used to limit the records
413 returned. The following call limits the earlier example to invoices
416 my $invoices = $order->linked_records(
419 query => [ transdate => DateTime->today_local ],
422 In case you don't know or care which or how many objects are visited the flag
423 C<recursive> can be used. It searches all reachable objects in the given direction:
425 my $records = $order->linked_records(
430 Only link chains of the same type will be considered. So even with direction
433 order 1 ---> invoice <--- order 2
435 started from order 1 will only find invoice. If an object is found both in each
436 direction, only one copy will be returned. The recursion is cycle protected,
437 and will not recurse infinitely. Cycles are defined by the same link being
438 visited twice, so this
441 order 1 ---> order 2 <--> delivery order
445 will find the path o1 -> o2 -> do -> o2 -> i without considering it a cycle.
447 The optional extra flag C<save_path> will give you extra information saved in
448 the returned objects:
450 my $records = $order->linked_records(
456 Every record will have two fields set:
460 =item C<_record_link_path>
462 An array with the ids of the visited links. The shortest paths will be
463 preferred, so in the previous example this would contain the ids of o1-o2 and
466 =item C<_record_link_depth>
468 Recursion depth when this object was found. Equal to the number of ids in
474 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
475 can be used in order to sort the result. If C<$params{sort_by}> is
476 trueish then the result is sorted by calling L</sort_linked_records>.
478 The optional parameter C<$params{filter}> controls whether or not the
479 result is filtered. Supported values are:
485 Removes all objects for which the function C<may_be_accessed> from the
486 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
487 the current employee.
491 Returns an array reference. Each element returned is a Rose::DB
492 instance. Additionally several elements in the element returned are
493 set to special values:
497 =item C<_record_link_direction>
499 Either C<from> or C<to> indicating the direction. C<from> means that
500 this object is the source in the link.
502 =item C<_record_link>
504 The actual database link object (an instance of L<SL::DB::RecordLink>).
508 =item C<link_to_record $record, %params>
510 Will create an entry in the table C<record_links> with the C<from>
511 side being C<$self> and the C<to> side being C<$record>. Will only
512 insert a new entry if such a link does not already exist.
514 If C<$params{bidirectional}> is trueish then another link will be
515 created with the roles of C<from> and C<to> reversed. This link will
516 also only be created if it doesn't exist already.
518 In scalar context returns either the existing link or the newly
519 created one as an instance of C<SL::DB::RecordLink>. In array context
520 it returns an array of links (one entry if C<$params{bidirectional}>
521 is falsish and two entries if it is trueish).
523 =item C<sort_linked_records $sort_by, $sort_dir, @records>
525 Sorts linked records by C<$sort_by> in the direction given by
526 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
527 can be either a single array reference or or normal array.
529 C<$sort_by> can be one of the following strings:
535 Sort by type first and by record number second. The type order
536 reflects the order in which records are usually processed by the
537 employees: sales processes, sales quotations, sales orders, sales
538 delivery orders, invoices; requests for quotation, purchase orders,
539 purchase delivery orders, purchase invoices.
543 Sort by the record's running number.
547 Sort by the transdate of the record was created or applies to.
549 Note: If the latter has a default setting it will always mask the creation time.
553 Returns an array reference.
555 Can only be called both as a class function since it is not exported.
561 This mixin exports the functions L</linked_records> and
570 * C<recursive> should take a query param depth and cut off there
571 * C<recursive> uses partial distinct which is known to be not terribly fast on
572 a million entry table. replace with a better statement if this ever becomes
577 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
578 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>