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},
96 # If no 'via' is given then use a simple(r) method for querying the wanted objects.
97 if (!$params{via} && !$params{recursive}) {
98 my @query = ( "${myself}_table" => $my_table,
99 "${myself}_id" => $self->id );
100 push @query, ( "${wanted}_table" => $wanted_tables ) if $wanted_tables;
102 return [ map { $get_objects->($_) } @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) } ];
105 # More complex handling for the 'via' case.
107 my @sources = ( $self );
108 my @targets = map { SL::DB::Helper::Mappings::get_table_for_package($_) } @{ ref($params{via}) ? $params{via} : [ $params{via} ] };
109 push @targets, @{ $wanted_tables } if $wanted_tables;
111 my %seen = map { ($_->meta->table . $_->id => 1) } @sources;
114 my @new_sources = @sources;
115 foreach my $src (@sources) {
116 my @query = ( "${myself}_table" => $src->meta->table,
117 "${myself}_id" => $src->id,
118 "${wanted}_table" => \@targets );
120 map { $get_objects->($_) }
121 grep { !$seen{$_->$sub_wanted_table . $_->$sub_wanted_id} }
122 @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) };
125 @sources = @new_sources;
126 %seen = map { ($_->meta->table . $_->id => 1) } @sources;
130 my %wanted_tables_map = map { ($_ => 1) } @{ $wanted_tables };
131 return [ grep { $wanted_tables_map{$_->meta->table} } @sources ];
134 # And lastly recursive mode
135 if ($params{recursive}) {
136 # don't use rose retrieval here. too slow.
137 # instead use recursive sql to get all the linked record_links entrys, and retrieve the objects from there
139 WITH RECURSIVE record_links_rec_${wanted}(id, from_table, from_id, to_table, to_id, depth, path, cycle) AS (
140 SELECT id, from_table, from_id, to_table, to_id,
143 WHERE ${myself}_id = ? and ${myself}_table = ?
145 SELECT rl.id, rl.from_table, rl.from_id, rl.to_table, rl.to_id,
146 rlr.depth + 1, path || rl.id, rl.id = ANY(path)
147 FROM record_links rl, record_links_rec_${wanted} rlr
148 WHERE rlr.${wanted}_id = rl.${myself}_id AND rlr.${wanted}_table = rl.${myself}_table AND NOT cycle
150 SELECT DISTINCT ON (${wanted}_table, ${wanted}_id)
151 id, from_table, from_id, to_table, to_id, path, depth FROM record_links_rec_${wanted}
153 ORDER BY ${wanted}_table, ${wanted}_id, depth ASC;
155 my $links = selectall_hashref_query($::form, $::form->get_standard_dbh, $query, $self->id, $self->meta->table);
157 return [] unless @$links;
159 my $link_objs = SL::DB::Manager::RecordLink->get_all(query => [ id => [ map { $_->{id} } @$links ] ]);
160 my @objects = map { $get_objects->($_) } @$link_objs;
162 if ($params{save_path}) {
163 my %links_by_id = map { $_->{id} => $_ } @$links;
165 my $link = $links_by_id{$_->{_record_link}->id};
166 my $intermediate_links = SL::DB::Manager::RecordLink->get_all(query => [ id => $link->{path} ]);
167 $_->{_record_link_path} = $link->{path};
168 $_->{_record_link_obj_path} = [ map { $get_objects->($_) } @$intermediate_links ];
169 $_->{_record_link_depth} = $link->{depth};
182 croak "self has no id" unless $self->id;
183 croak "other has no id" unless $other->id;
185 my @directions = ([ 'from', 'to' ]);
186 push @directions, [ 'to', 'from' ] if $params{bidirectional};
189 foreach my $direction (@directions) {
190 my %data = ( $direction->[0] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($self)),
191 $direction->[0] . "_id" => $self->id,
192 $direction->[1] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($other)),
193 $direction->[1] . "_id" => $other->id,
196 my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
197 push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save;
200 return wantarray ? @links : $links[0];
203 sub sort_linked_records {
204 my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
206 @records = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
207 $sort_dir = $sort_dir * 1 ? 1 : -1;
209 my %numbers = ( 'SL::DB::SalesProcess' => sub { $_[0]->id },
210 'SL::DB::Order' => sub { $_[0]->quotation ? $_[0]->quonumber : $_[0]->ordnumber },
211 'SL::DB::DeliveryOrder' => sub { $_[0]->donumber },
212 'SL::DB::Invoice' => sub { $_[0]->invnumber },
213 'SL::DB::PurchaseInvoice' => sub { $_[0]->invnumber },
214 'SL::DB::RequirementSpec' => sub { $_[0]->id },
215 'SL::DB::Letter' => sub { $_[0]->letternumber },
216 UNKNOWN => '9999999999999999',
218 my $number_xtor = sub {
219 my $number = $numbers{ ref($_[0]) };
220 $number = $number->($_[0]) if ref($number) eq 'CODE';
221 return $number || $numbers{UNKNOWN};
223 my $number_comparator = sub {
224 my $number_a = $number_xtor->($a);
225 my $number_b = $number_xtor->($b);
227 ncmp($number_a, $number_b) * $sort_dir;
231 %scores = ( 'SL::DB::SalesProcess' => 10,
232 'SL::DB::RequirementSpec' => 15,
233 'SL::DB::Order' => sub { $scores{ $_[0]->type } },
234 sales_quotation => 20,
236 sales_delivery_order => 40,
237 'SL::DB::DeliveryOrder' => sub { $scores{ $_[0]->type } },
238 'SL::DB::Invoice' => 50,
239 request_quotation => 120,
240 purchase_order => 130,
241 purchase_delivery_order => 140,
242 'SL::DB::PurchaseInvoice' => 150,
243 'SL::DB::PurchaseInvoice' => 150,
244 'SL::DB::Letter' => 200,
247 my $score_xtor = sub {
248 my $score = $scores{ ref($_[0]) };
249 $score = $score->($_[0]) if ref($score) eq 'CODE';
250 return $score || $scores{UNKNOWN};
252 my $type_comparator = sub {
253 my $score_a = $score_xtor->($a);
254 my $score_b = $score_xtor->($b);
256 $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
259 my $today = DateTime->today_local;
260 my $date_xtor = sub {
261 $_[0]->can('transdate_as_date') ? $_[0]->transdate
262 : $_[0]->can('itime_as_date') ? $_[0]->itime->clone->truncate(to => 'day')
265 my $date_comparator = sub {
266 my $date_a = $date_xtor->($a);
267 my $date_b = $date_xtor->($b);
269 ($date_a <=> $date_b) * $sort_dir;
272 my $comparator = $sort_by eq 'number' ? $number_comparator
273 : $sort_by eq 'date' ? $date_comparator
276 return [ sort($comparator @records) ];
279 sub filter_linked_records {
280 my ($self_or_class, $filter, @records) = @_;
282 if ($filter eq 'accessible') {
283 my $employee = SL::DB::Manager::Employee->current;
284 @records = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
286 croak "Unsupported filter parameter '${filter}'";
300 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
304 # In SL::DB::<Object>
305 use SL::DB::Helper::LinkedRecords;
307 # later in consumer code
308 # retrieve all links in both directions
309 my @linked_objects = $order->linked_records;
311 # only links to Invoices
312 my @linked_objects = $order->linked_records(
316 # more than one target
317 my @linked_objects = $order->linked_records(
318 to => [ 'Invoice', 'Order' ],
321 # more than one direction
322 my @linked_objects = $order->linked_records(
326 # more than one direction and different targets
327 my @linked_objects = $order->linked_records(
332 # via over known classes
333 my @linked_objects = $order->linked_records(
335 via => 'DeliveryOrder',
337 my @linked_objects = $order->linked_records(
339 via => [ 'Order', 'DeliveryOrder' ],
343 my @linked_objects = $order->linked_records(
348 # limit direction when further params contain additional keys
349 my %params = (to => 'Invoice', from => 'Order');
350 my @linked_objects = $order->linked_records(
356 $order->link_to_record($invoice);
357 $order->link_to_record($purchase_order, bidirectional => 1);
364 =item C<linked_records %params>
366 Retrieves records linked from or to C<$self> via the table C<record_links>.
368 The optional parameter C<direction> (either C<from>, C<to> or C<both>)
369 determines whether the function retrieves records that link to C<$self> (for
370 C<direction> = C<to>) or that are linked from C<$self> (for C<direction> =
371 C<from>). For C<direction = both> all records linked from or to C<$self> are
374 The optional parameter C<from> or C<to> (same as C<direction>) contains the
375 package names of Rose models for table limitation (the prefix C<SL::DB::> is
376 optional). It can be a single model name as a single scalar or multiple model
377 names in an array reference in which case all links matching any of the model
378 names will be returned.
380 If no parameter C<direction> is given, but any of C<to>, C<from> or C<both>,
381 then C<direction> is inferred accordingly. If neither are given, C<direction> is
384 The optional parameter C<via> can be used to retrieve all documents that may
385 have intermediate documents inbetween. It is an array reference of Rose package
386 names for the models that may be intermediate link targets. One example is
387 retrieving all invoices for a given quotation no matter whether or not orders
388 and delivery orders have been created. If C<via> is given then C<from> or C<to>
389 (depending on C<direction>) must be given as well, and it must then not be an
394 If you only need invoices created directly from an order C<$order> (no
395 delivery orders in between) then the call could look like this:
397 my $invoices = $order->linked_records(
402 Retrieving all invoices from a quotation no matter whether or not
403 orders or delivery orders were created:
405 my $invoices = $quotation->linked_records(
408 via => [ 'Order', 'DeliveryOrder' ],
411 The optional parameter C<query> can be used to limit the records
412 returned. The following call limits the earlier example to invoices
415 my $invoices = $order->linked_records(
418 query => [ transdate => DateTime->today_local ],
421 In case you don't know or care which or how many objects are visited the flag
422 C<recursive> can be used. It searches all reachable objects in the given direction:
424 my $records = $order->linked_records(
429 Only link chains of the same type will be considered. So even with direction
432 order 1 ---> invoice <--- order 2
434 started from order 1 will only find invoice. If an object is found both in each
435 direction, only one copy will be returned. The recursion is cycle protected,
436 and will not recurse infinitely. Cycles are defined by the same link being
437 visited twice, so this
440 order 1 ---> order 2 <--> delivery order
444 will find the path o1 -> o2 -> do -> o2 -> i without considering it a cycle.
446 The optional extra flag C<save_path> will give you extra information saved in
447 the returned objects:
449 my $records = $order->linked_records(
455 Every record will have two fields set:
459 =item C<_record_link_path>
461 An array with the ids of the visited links. The shortest paths will be
462 preferred, so in the previous example this would contain the ids of o1-o2 and
465 =item C<_record_link_depth>
467 Recursion depth when this object was found. Equal to the number of ids in
473 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
474 can be used in order to sort the result. If C<$params{sort_by}> is
475 trueish then the result is sorted by calling L</sort_linked_records>.
477 The optional parameter C<$params{filter}> controls whether or not the
478 result is filtered. Supported values are:
484 Removes all objects for which the function C<may_be_accessed> from the
485 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
486 the current employee.
490 Returns an array reference. Each element returned is a Rose::DB
491 instance. Additionally several elements in the element returned are
492 set to special values:
496 =item C<_record_link_direction>
498 Either C<from> or C<to> indicating the direction. C<from> means that
499 this object is the source in the link.
501 =item C<_record_link>
503 The actual database link object (an instance of L<SL::DB::RecordLink>).
507 =item C<link_to_record $record, %params>
509 Will create an entry in the table C<record_links> with the C<from>
510 side being C<$self> and the C<to> side being C<$record>. Will only
511 insert a new entry if such a link does not already exist.
513 If C<$params{bidirectional}> is trueish then another link will be
514 created with the roles of C<from> and C<to> reversed. This link will
515 also only be created if it doesn't exist already.
517 In scalar context returns either the existing link or the newly
518 created one as an instance of C<SL::DB::RecordLink>. In array context
519 it returns an array of links (one entry if C<$params{bidirectional}>
520 is falsish and two entries if it is trueish).
522 =item C<sort_linked_records $sort_by, $sort_dir, @records>
524 Sorts linked records by C<$sort_by> in the direction given by
525 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
526 can be either a single array reference or or normal array.
528 C<$sort_by> can be one of the following strings:
534 Sort by type first and by record number second. The type order
535 reflects the order in which records are usually processed by the
536 employees: sales processes, sales quotations, sales orders, sales
537 delivery orders, invoices; requests for quotation, purchase orders,
538 purchase delivery orders, purchase invoices.
542 Sort by the record's running number.
546 Sort by the transdate of the record was created or applies to.
548 Note: If the latter has a default setting it will always mask the creation time.
552 Returns an array reference.
554 Can only be called both as a class function since it is not exported.
560 This mixin exports the functions L</linked_records> and
569 * C<recursive> should take a query param depth and cut off there
570 * C<recursive> uses partial distinct which is known to be not terribly fast on
571 a million entry table. replace with a better statement if this ever becomes
576 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
577 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>