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 UNKNOWN => '9999999999999999',
212 my $number_xtor = sub {
213 my $number = $numbers{ ref($_[0]) };
214 $number = $number->($_[0]) if ref($number) eq 'CODE';
215 return $number || $numbers{UNKNOWN};
217 my $number_comparator = sub {
218 my $number_a = $number_xtor->($a);
219 my $number_b = $number_xtor->($b);
221 ncmp($number_a, $number_b) * $sort_dir;
225 %scores = ( 'SL::DB::SalesProcess' => 10,
226 'SL::DB::RequirementSpec' => 15,
227 'SL::DB::Order' => sub { $scores{ $_[0]->type } },
228 sales_quotation => 20,
230 sales_delivery_order => 40,
231 'SL::DB::DeliveryOrder' => sub { $scores{ $_[0]->type } },
232 'SL::DB::Invoice' => 50,
233 request_quotation => 120,
234 purchase_order => 130,
235 purchase_delivery_order => 140,
236 'SL::DB::PurchaseInvoice' => 150,
239 my $score_xtor = sub {
240 my $score = $scores{ ref($_[0]) };
241 $score = $score->($_[0]) if ref($score) eq 'CODE';
242 return $score || $scores{UNKNOWN};
244 my $type_comparator = sub {
245 my $score_a = $score_xtor->($a);
246 my $score_b = $score_xtor->($b);
248 $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
251 my $today = DateTime->today_local;
252 my $date_xtor = sub {
253 $_[0]->can('transdate_as_date') ? $_[0]->transdate
254 : $_[0]->can('itime_as_date') ? $_[0]->itime->clone->truncate(to => 'day')
257 my $date_comparator = sub {
258 my $date_a = $date_xtor->($a);
259 my $date_b = $date_xtor->($b);
261 ($date_a <=> $date_b) * $sort_dir;
264 my $comparator = $sort_by eq 'number' ? $number_comparator
265 : $sort_by eq 'date' ? $date_comparator
268 return [ sort($comparator @records) ];
271 sub filter_linked_records {
272 my ($self_or_class, $filter, @records) = @_;
274 if ($filter eq 'accessible') {
275 my $employee = SL::DB::Manager::Employee->current;
276 @records = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
278 croak "Unsupported filter parameter '${filter}'";
292 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
296 # In SL::DB::<Object>
297 use SL::DB::Helper::LinkedRecords;
299 # later in consumer code
300 # retrieve all links in both directions
301 my @linked_objects = $order->linked_records;
303 # only links to Invoices
304 my @linked_objects = $order->linked_records(
308 # more than one target
309 my @linked_objects = $order->linked_records(
310 to => [ 'Invoice', 'Order' ],
313 # more than one direction
314 my @linked_objects = $order->linked_records(
318 # more than one direction and different targets
319 my @linked_objects = $order->linked_records(
324 # via over known classes
325 my @linked_objects = $order->linked_records(
327 via => 'DeliveryOrder',
329 my @linked_objects = $order->linked_records(
331 via => [ 'Order', 'DeliveryOrder' ],
335 my @linked_objects = $order->linked_records(
340 # limit direction when further params contain additional keys
341 my %params = (to => 'Invoice', from => 'Order');
342 my @linked_objects = $order->linked_records(
348 $order->link_to_record($invoice);
349 $order->link_to_record($purchase_order, bidirectional => 1);
356 =item C<linked_records %params>
358 Retrieves records linked from or to C<$self> via the table C<record_links>.
360 The optional parameter C<direction> (either C<from>, C<to> or C<both>)
361 determines whether the function retrieves records that link to C<$self> (for
362 C<direction> = C<to>) or that are linked from C<$self> (for C<direction> =
363 C<from>). For C<direction = both> all records linked from or to C<$self> are
366 The optional parameter C<from> or C<to> (same as C<direction>) contains the
367 package names of Rose models for table limitation (the prefix C<SL::DB::> is
368 optional). It can be a single model name as a single scalar or multiple model
369 names in an array reference in which case all links matching any of the model
370 names will be returned.
372 If no parameter C<direction> is given, but any of C<to>, C<from> or C<both>,
373 then C<direction> is inferred accordingly. If neither are given, C<direction> is
376 The optional parameter C<via> can be used to retrieve all documents that may
377 have intermediate documents inbetween. It is an array reference of Rose package
378 names for the models that may be intermediate link targets. One example is
379 retrieving all invoices for a given quotation no matter whether or not orders
380 and delivery orders have been created. If C<via> is given then C<from> or C<to>
381 (depending on C<direction>) must be given as well, and it must then not be an
386 If you only need invoices created directly from an order C<$order> (no
387 delivery orders inbetween) then the call could look like this:
389 my $invoices = $order->linked_records(
394 Retrieving all invoices from a quotation no matter whether or not
395 orders or delivery orders were created:
397 my $invoices = $quotation->linked_records(
400 via => [ 'Order', 'DeliveryOrder' ],
403 The optional parameter C<query> can be used to limit the records
404 returned. The following call limits the earlier example to invoices
407 my $invoices = $order->linked_records(
410 query => [ transdate => DateTime->today_local ],
413 In case you don't know or care which or how many objects are visited the flag
414 C<recursive> can be used. It searches all reachable objects in the given direction:
416 my $records = $order->linked_records(
421 Only link chains of the same type will be considered. So even with direction
424 order 1 ---> invoice <--- order 2
426 started from order 1 will only find invoice. If an object is found both in each
427 direction, only one copy will be returned. The recursion is cycle protected,
428 and will not recurse infinitely. Cycles are defined by the same link being
429 visited twice, so this
432 order 1 ---> order 2 <--> delivery order
436 will find the path o1 -> o2 -> do -> o2 -> i without considering it a cycle.
438 The optional extra flag C<save_path> will give you extra information saved in
439 the returned objects:
441 my $records = $order->linked_records(
447 Every record will have two fields set:
451 =item C<_record_link_path>
453 An array with the ids of the visited links. The shortest paths will be
454 preferred, so in the previous example this would contain the ids of o1-o2 and
457 =item C<_record_link_depth>
459 Recursion depth when this object was found. Equal to the number of ids in
465 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
466 can be used in order to sort the result. If C<$params{sort_by}> is
467 trueish then the result is sorted by calling L</sort_linked_records>.
469 The optional parameter C<$params{filter}> controls whether or not the
470 result is filtered. Supported values are:
476 Removes all objects for which the function C<may_be_accessed> from the
477 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
478 the current employee.
482 Returns an array reference. Each element returned is a Rose::DB
483 instance. Additionally several elements in the element returned are
484 set to special values:
488 =item C<_record_link_direction>
490 Either C<from> or C<to> indicating the direction. C<from> means that
491 this object is the source in the link.
493 =item C<_record_link>
495 The actual database link object (an instance of L<SL::DB::RecordLink>).
499 =item C<link_to_record $record, %params>
501 Will create an entry in the table C<record_links> with the C<from>
502 side being C<$self> and the C<to> side being C<$record>. Will only
503 insert a new entry if such a link does not already exist.
505 If C<$params{bidirectional}> is trueish then another link will be
506 created with the roles of C<from> and C<to> reversed. This link will
507 also only be created if it doesn't exist already.
509 In scalar context returns either the existing link or the newly
510 created one as an instance of C<SL::DB::RecordLink>. In array context
511 it returns an array of links (one entry if C<$params{bidirectional}>
512 is falsish and two entries if it is trueish).
514 =item C<sort_linked_records $sort_by, $sort_dir, @records>
516 Sorts linked records by C<$sort_by> in the direction given by
517 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
518 can be either a single array reference or or normal array.
520 C<$sort_by> can be one of the following strings:
526 Sort by type first and by record number second. The type order
527 reflects the order in which records are usually processed by the
528 employees: sales processes, sales quotations, sales orders, sales
529 delivery orders, invoices; requests for quotation, purchase orders,
530 purchase delivery orders, purchase invoices.
534 Sort by the record's running number.
538 Sort by the transdate of the record was created or applies to.
540 Note: If the latter has a default setting it will always mask the creation time.
544 Returns an array reference.
546 Can only be called both as a class function since it is not exported.
552 This mixin exports the functions L</linked_records> and
561 * C<recursive> should take a query param depth and cut off there
562 * C<recursive> uses partial distinct which is known to be not terribly fast on
563 a million entry table. replace with a better statement if this ever becomes
568 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
569 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>