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);
151 my $link_objs = SL::DB::Manager::RecordLink->get_all(query => [ id => [ map { $_->{id} } @$links ] ]);
152 my @objects = map { $get_objects->($_) } @$link_objs;
154 if ($params{save_path}) {
155 my %links_by_id = map { $_->{id} => $_ } @$links;
157 my $link = $links_by_id{$_->{_record_link}->id};
158 my $intermediate_links = SL::DB::Manager::RecordLink->get_all(query => [ id => $link->{path} ]);
159 $_->{_record_link_path} = $link->{path};
160 $_->{_record_link_obj_path} = [ map { $get_objects->($_) } @$intermediate_links ];
161 $_->{_record_link_depth} = $link->{depth};
174 croak "self has no id" unless $self->id;
175 croak "other has no id" unless $other->id;
177 my @directions = ([ 'from', 'to' ]);
178 push @directions, [ 'to', 'from' ] if $params{bidirectional};
181 foreach my $direction (@directions) {
182 my %data = ( $direction->[0] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($self)),
183 $direction->[0] . "_id" => $self->id,
184 $direction->[1] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($other)),
185 $direction->[1] . "_id" => $other->id,
188 my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
189 push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save;
192 return wantarray ? @links : $links[0];
195 sub sort_linked_records {
196 my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
198 @records = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
199 $sort_dir = $sort_dir * 1 ? 1 : -1;
201 my %numbers = ( 'SL::DB::SalesProcess' => sub { $_[0]->id },
202 'SL::DB::Order' => sub { $_[0]->quotation ? $_[0]->quonumber : $_[0]->ordnumber },
203 'SL::DB::DeliveryOrder' => sub { $_[0]->donumber },
204 'SL::DB::Invoice' => sub { $_[0]->invnumber },
205 'SL::DB::PurchaseInvoice' => sub { $_[0]->invnumber },
206 'SL::DB::RequirementSpec' => sub { $_[0]->id },
207 UNKNOWN => '9999999999999999',
209 my $number_xtor = sub {
210 my $number = $numbers{ ref($_[0]) };
211 $number = $number->($_[0]) if ref($number) eq 'CODE';
212 return $number || $numbers{UNKNOWN};
214 my $number_comparator = sub {
215 my $number_a = $number_xtor->($a);
216 my $number_b = $number_xtor->($b);
218 ncmp($number_a, $number_b) * $sort_dir;
222 %scores = ( 'SL::DB::SalesProcess' => 10,
223 'SL::DB::RequirementSpec' => 15,
224 'SL::DB::Order' => sub { $scores{ $_[0]->type } },
225 sales_quotation => 20,
227 sales_delivery_order => 40,
228 'SL::DB::DeliveryOrder' => sub { $scores{ $_[0]->type } },
229 'SL::DB::Invoice' => 50,
230 request_quotation => 120,
231 purchase_order => 130,
232 purchase_delivery_order => 140,
233 'SL::DB::PurchaseInvoice' => 150,
236 my $score_xtor = sub {
237 my $score = $scores{ ref($_[0]) };
238 $score = $score->($_[0]) if ref($score) eq 'CODE';
239 return $score || $scores{UNKNOWN};
241 my $type_comparator = sub {
242 my $score_a = $score_xtor->($a);
243 my $score_b = $score_xtor->($b);
245 $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
248 my $today = DateTime->today_local;
249 my $date_xtor = sub {
250 $_[0]->can('transdate_as_date') ? $_[0]->transdate
251 : $_[0]->can('itime_as_date') ? $_[0]->itime->clone->truncate(to => 'day')
254 my $date_comparator = sub {
255 my $date_a = $date_xtor->($a);
256 my $date_b = $date_xtor->($b);
258 ($date_a <=> $date_b) * $sort_dir;
261 my $comparator = $sort_by eq 'number' ? $number_comparator
262 : $sort_by eq 'date' ? $date_comparator
265 return [ sort($comparator @records) ];
268 sub filter_linked_records {
269 my ($self_or_class, $filter, @records) = @_;
271 if ($filter eq 'accessible') {
272 my $employee = SL::DB::Manager::Employee->current;
273 @records = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
275 croak "Unsupported filter parameter '${filter}'";
289 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
293 # In SL::DB::<Object>
294 use SL::DB::Helper::LinkedRecords;
296 # later in consumer code
297 # retrieve all links in both directions
298 my @linked_objects = $order->linked_records;
300 # only links to Invoices
301 my @linked_objects = $order->linked_records(
305 # more than one target
306 my @linked_objects = $order->linked_records(
307 to => [ 'Invoice', 'Order' ],
310 # more than one direction
311 my @linked_objects = $order->linked_records(
315 # more than one direction and different targets
316 my @linked_objects = $order->linked_records(
321 # via over known classes
322 my @linked_objects = $order->linked_records(
324 via => 'DeliveryOrder',
326 my @linked_objects = $order->linked_records(
328 via => [ 'Order', 'DeliveryOrder' ],
332 my @linked_objects = $order->linked_records(
337 # limit direction when further params contain additional keys
338 my %params = (to => 'Invoice', from => 'Order');
339 my @linked_objects = $order->linked_records(
345 $order->link_to_record($invoice);
346 $order->link_to_record($purchase_order, bidirectional => 1);
353 =item C<linked_records %params>
355 Retrieves records linked from or to C<$self> via the table C<record_links>.
357 The optional parameter C<direction> (either C<from>, C<to> or C<both>)
358 determines whether the function retrieves records that link to C<$self> (for
359 C<direction> = C<to>) or that are linked from C<$self> (for C<direction> =
360 C<from>). For C<direction = both> all records linked from or to C<$self> are
363 The optional parameter C<from> or C<to> (same as C<direction>) contains the
364 package names of Rose models for table limitation (the prefix C<SL::DB::> is
365 optional). It can be a single model name as a single scalar or multiple model
366 names in an array reference in which case all links matching any of the model
367 names will be returned.
369 If no parameter C<direction> is given, but any of C<to>, C<from> or C<both>,
370 then C<direction> is infered accordingly. If neither are given, C<direction> is
373 The optional parameter C<via> can be used to retrieve all documents that may
374 have intermediate documents inbetween. It is an array reference of Rose package
375 names for the models that may be intermediate link targets. One example is
376 retrieving all invoices for a given quotation no matter whether or not orders
377 and delivery orders have been created. If C<via> is given then C<from> or C<to>
378 (depending on C<direction>) must be given as well, and it must then not be an
383 If you only need invoices created directly from an order C<$order> (no
384 delivery orders inbetween) then the call could look like this:
386 my $invoices = $order->linked_records(
391 Retrieving all invoices from a quotation no matter whether or not
392 orders or delivery orders where created:
394 my $invoices = $quotation->linked_records(
397 via => [ 'Order', 'DeliveryOrder' ],
400 The optional parameter C<query> can be used to limit the records
401 returned. The following call limits the earlier example to invoices
404 my $invoices = $order->linked_records(
407 query => [ transdate => DateTime->today_local ],
410 In case you don't know or care which or how many objects are visited the flag
411 C<recursive> can be used. It searches all reachable objects in the given direction:
413 my $records = $order->linked_records(
418 Only link chains of the same type will be considered. So even with direction
421 order 1 ---> invoice <--- order 2
423 started from order 1 will only find invoice. If an object is found both in each
424 direction, only one copy will be returned. The recursion is cycle protected,
425 and will not recurse infinitely. Cycles are defined by the same link being
426 visited twice, so this
429 order 1 ---> order 2 <--> delivery order
433 will find the path o1 -> o2 -> do -> o2 -> i without considering it a cycle.
435 The optional extra flag C<save_path> will give you extra inforamtion saved in
436 the returned objects:
438 my $records = $order->linked_records(
444 Every record will have two fields set:
448 =item C<_record_link_path>
450 And array with the ids of the visited links. The shortest paths will be
451 prefered, so in the previous example this would contain the ids of o1-o2 and
454 =item C<_record_link_depth>
456 Recursion depth when this object was found. Equal to the number of ids in
462 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
463 can be used in order to sort the result. If C<$params{sort_by}> is
464 trueish then the result is sorted by calling L</sort_linked_records>.
466 The optional parameter C<$params{filter}> controls whether or not the
467 result is filtered. Supported values are:
473 Removes all objects for which the function C<may_be_accessed> from the
474 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
475 the current employee.
479 Returns an array reference. Each element returned is a Rose::DB
480 instance. Additionally several elements in the element returned are
481 set to special values:
485 =item C<_record_link_direction>
487 Either C<from> or C<to> indicating the direction. C<from> means that
488 this object is the source in the link.
490 =item C<_record_link>
492 The actual database link object (an instance of L<SL::DB::RecordLink>).
496 =item C<link_to_record $record, %params>
498 Will create an entry in the table C<record_links> with the C<from>
499 side being C<$self> and the C<to> side being C<$record>. Will only
500 insert a new entry if such a link does not already exist.
502 If C<$params{bidirectional}> is trueish then another link will be
503 created with the roles of C<from> and C<to> reversed. This link will
504 also only be created if it doesn't exist already.
506 In scalar context returns either the existing link or the newly
507 created one as an instance of C<SL::DB::RecordLink>. In array context
508 it returns an array of links (one entry if C<$params{bidirectional}>
509 is falsish and two entries if it is trueish).
511 =item C<sort_linked_records $sort_by, $sort_dir, @records>
513 Sorts linked records by C<$sort_by> in the direction given by
514 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
515 can be either a single array reference or or normal array.
517 C<$sort_by> can be one of the following strings:
523 Sort by type first and by record number second. The type order
524 reflects the order in which records are usually processed by the
525 employees: sales processes, sales quotations, sales orders, sales
526 delivery orders, invoices; requests for quotation, purchase orders,
527 purchase delivery orders, purchase invoices.
531 Sort by the record's running number.
535 Sort by the transdate of the record was created or applies to.
537 Note: If the latter has a default setting it will always mask the creation time.
541 Returns an array reference.
543 Can only be called both as a class function since it is noe exported.
549 This mixin exports the functions L</linked_records> and
558 * C<recursive> should take a query param depth and cut off there
559 * C<recursive> uses partial distinct which is known to be not terribly fast on
560 a million entry table. replace with a better statement if this ever becomes
565 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
566 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>