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 $_->{_record_link_path} = $links_by_id{$_->{_record_link}->id}->{path};
158 $_->{_record_link_depth} = $links_by_id{$_->{_record_link}->id}->{depth};
171 croak "self has no id" unless $self->id;
172 croak "other has no id" unless $other->id;
174 my @directions = ([ 'from', 'to' ]);
175 push @directions, [ 'to', 'from' ] if $params{bidirectional};
178 foreach my $direction (@directions) {
179 my %data = ( $direction->[0] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($self)),
180 $direction->[0] . "_id" => $self->id,
181 $direction->[1] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($other)),
182 $direction->[1] . "_id" => $other->id,
185 my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
186 push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save;
189 return wantarray ? @links : $links[0];
192 sub sort_linked_records {
193 my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
195 @records = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
196 $sort_dir = $sort_dir * 1 ? 1 : -1;
198 my %numbers = ( 'SL::DB::SalesProcess' => sub { $_[0]->id },
199 'SL::DB::Order' => sub { $_[0]->quotation ? $_[0]->quonumber : $_[0]->ordnumber },
200 'SL::DB::DeliveryOrder' => sub { $_[0]->donumber },
201 'SL::DB::Invoice' => sub { $_[0]->invnumber },
202 'SL::DB::PurchaseInvoice' => sub { $_[0]->invnumber },
203 'SL::DB::RequirementSpec' => sub { $_[0]->id },
204 UNKNOWN => '9999999999999999',
206 my $number_xtor = sub {
207 my $number = $numbers{ ref($_[0]) };
208 $number = $number->($_[0]) if ref($number) eq 'CODE';
209 return $number || $numbers{UNKNOWN};
211 my $number_comparator = sub {
212 my $number_a = $number_xtor->($a);
213 my $number_b = $number_xtor->($b);
215 ncmp($number_a, $number_b) * $sort_dir;
219 %scores = ( 'SL::DB::SalesProcess' => 10,
220 'SL::DB::RequirementSpec' => 15,
221 'SL::DB::Order' => sub { $scores{ $_[0]->type } },
222 sales_quotation => 20,
224 sales_delivery_order => 40,
225 'SL::DB::DeliveryOrder' => sub { $scores{ $_[0]->type } },
226 'SL::DB::Invoice' => 50,
227 request_quotation => 120,
228 purchase_order => 130,
229 purchase_delivery_order => 140,
230 'SL::DB::PurchaseInvoice' => 150,
233 my $score_xtor = sub {
234 my $score = $scores{ ref($_[0]) };
235 $score = $score->($_[0]) if ref($score) eq 'CODE';
236 return $score || $scores{UNKNOWN};
238 my $type_comparator = sub {
239 my $score_a = $score_xtor->($a);
240 my $score_b = $score_xtor->($b);
242 $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
245 my $today = DateTime->today_local;
246 my $date_xtor = sub {
247 $_[0]->can('transdate_as_date') ? $_[0]->transdate
248 : $_[0]->can('itime_as_date') ? $_[0]->itime->clone->truncate(to => 'day')
251 my $date_comparator = sub {
252 my $date_a = $date_xtor->($a);
253 my $date_b = $date_xtor->($b);
255 ($date_a <=> $date_b) * $sort_dir;
258 my $comparator = $sort_by eq 'number' ? $number_comparator
259 : $sort_by eq 'date' ? $date_comparator
262 return [ sort($comparator @records) ];
265 sub filter_linked_records {
266 my ($self_or_class, $filter, @records) = @_;
268 if ($filter eq 'accessible') {
269 my $employee = SL::DB::Manager::Employee->current;
270 @records = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
272 croak "Unsupported filter parameter '${filter}'";
286 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
290 # In SL::DB::<Object>
291 use SL::DB::Helper::LinkedRecords;
293 # later in consumer code
294 # retrieve all links in both directions
295 my @linked_objects = $order->linked_records;
297 # only links to Invoices
298 my @linked_objects = $order->linked_records(
302 # more than one target
303 my @linked_objects = $order->linked_records(
304 to => [ 'Invoice', 'Order' ],
307 # more than one direction
308 my @linked_objects = $order->linked_records(
312 # more than one direction and different targets
313 my @linked_objects = $order->linked_records(
318 # via over known classes
319 my @linked_objects = $order->linked_records(
321 via => 'DeliveryOrder',
323 my @linked_objects = $order->linked_records(
325 via => [ 'Order', 'DeliveryOrder' ],
329 my @linked_objects = $order->linked_records(
334 # limit direction when further params contain additional keys
335 my %params = (to => 'Invoice', from => 'Order');
336 my @linked_objects = $order->linked_records(
342 $order->link_to_record($invoice);
343 $order->link_to_record($purchase_order, bidirectional => 1);
350 =item C<linked_records %params>
352 Retrieves records linked from or to C<$self> via the table C<record_links>.
354 The optional parameter C<direction> (either C<from>, C<to> or C<both>)
355 determines whether the function retrieves records that link to C<$self> (for
356 C<direction> = C<to>) or that are linked from C<$self> (for C<direction> =
357 C<from>). For C<direction = both> all records linked from or to C<$self> are
360 The optional parameter C<from> or C<to> (same as C<direction>) contains the
361 package names of Rose models for table limitation (the prefix C<SL::DB::> is
362 optional). It can be a single model name as a single scalar or multiple model
363 names in an array reference in which case all links matching any of the model
364 names will be returned.
366 If no parameter C<direction> is given, but any of C<to>, C<from> or C<both>,
367 then C<direction> is infered accordingly. If neither are given, C<direction> is
370 The optional parameter C<via> can be used to retrieve all documents that may
371 have intermediate documents inbetween. It is an array reference of Rose package
372 names for the models that may be intermediate link targets. One example is
373 retrieving all invoices for a given quotation no matter whether or not orders
374 and delivery orders have been created. If C<via> is given then C<from> or C<to>
375 (depending on C<direction>) must be given as well, and it must then not be an
380 If you only need invoices created directly from an order C<$order> (no
381 delivery orders inbetween) then the call could look like this:
383 my $invoices = $order->linked_records(
388 Retrieving all invoices from a quotation no matter whether or not
389 orders or delivery orders where created:
391 my $invoices = $quotation->linked_records(
394 via => [ 'Order', 'DeliveryOrder' ],
397 The optional parameter C<query> can be used to limit the records
398 returned. The following call limits the earlier example to invoices
401 my $invoices = $order->linked_records(
404 query => [ transdate => DateTime->today_local ],
407 In case you don't know or care which or how many objects are visited the flag
408 C<recursive> can be used. It searches all reachable objects in the given direction:
410 my $records = $order->linked_records(
415 Only link chains of the same type will be considered. So even with direction
418 order 1 ---> invoice <--- order 2
420 started from order 1 will only find invoice. If an object is found both in each
421 direction, only one copy will be returned. The recursion is cycle protected,
422 and will not recurse infinitely. Cycles are defined by the same link being
423 visited twice, so this
426 order 1 ---> order 2 <--> delivery order
430 will find the path o1 -> o2 -> do -> o2 -> i without considering it a cycle.
432 The optional extra flag C<save_path> will give you extra inforamtion saved in
433 the returned objects:
435 my $records = $order->linked_records(
441 Every record will have two fields set:
445 =item C<_record_link_path>
447 And array with the ids of the visited links. The shortest paths will be
448 prefered, so in the previous example this would contain the ids of o1-o2 and
451 =item C<_record_link_depth>
453 Recursion depth when this object was found. Equal to the number of ids in
459 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
460 can be used in order to sort the result. If C<$params{sort_by}> is
461 trueish then the result is sorted by calling L</sort_linked_records>.
463 The optional parameter C<$params{filter}> controls whether or not the
464 result is filtered. Supported values are:
470 Removes all objects for which the function C<may_be_accessed> from the
471 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
472 the current employee.
476 Returns an array reference. Each element returned is a Rose::DB
477 instance. Additionally several elements in the element returned are
478 set to special values:
482 =item C<_record_link_direction>
484 Either C<from> or C<to> indicating the direction. C<from> means that
485 this object is the source in the link.
487 =item C<_record_link>
489 The actual database link object (an instance of L<SL::DB::RecordLink>).
493 =item C<link_to_record $record, %params>
495 Will create an entry in the table C<record_links> with the C<from>
496 side being C<$self> and the C<to> side being C<$record>. Will only
497 insert a new entry if such a link does not already exist.
499 If C<$params{bidirectional}> is trueish then another link will be
500 created with the roles of C<from> and C<to> reversed. This link will
501 also only be created if it doesn't exist already.
503 In scalar context returns either the existing link or the newly
504 created one as an instance of C<SL::DB::RecordLink>. In array context
505 it returns an array of links (one entry if C<$params{bidirectional}>
506 is falsish and two entries if it is trueish).
508 =item C<sort_linked_records $sort_by, $sort_dir, @records>
510 Sorts linked records by C<$sort_by> in the direction given by
511 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
512 can be either a single array reference or or normal array.
514 C<$sort_by> can be one of the following strings:
520 Sort by type first and by record number second. The type order
521 reflects the order in which records are usually processed by the
522 employees: sales processes, sales quotations, sales orders, sales
523 delivery orders, invoices; requests for quotation, purchase orders,
524 purchase delivery orders, purchase invoices.
528 Sort by the record's running number.
532 Sort by the transdate of the record was created or applies to.
534 Note: If the latter has a default setting it will always mask the creation time.
538 Returns an array reference.
540 Can only be called both as a class function since it is noe exported.
546 This mixin exports the functions L</linked_records> and
555 * C<recursive> should take a query param depth and cut off there
556 * C<recursive> uses partial distinct which is known to be not terribly fast on
557 a million entry table. replace with a better statement if this ever becomes
562 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
563 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>