1 package SL::DB::Helper::LinkedRecords;
6 our @ISA = qw(Exporter);
7 our @EXPORT = qw(linked_records link_to_record);
12 use SL::DB::Helper::Mappings;
13 use SL::DB::RecordLink;
16 my ($self, %params) = @_;
18 my %sort_spec = ( by => delete($params{sort_by}),
19 dir => delete($params{sort_dir}) );
20 my $filter = delete $params{filter};
22 my $records = _linked_records_implementation($self, %params);
23 $records = filter_linked_records($self, $filter, @{ $records }) if $filter;
24 $records = sort_linked_records($self, $sort_spec{by}, $sort_spec{dir}, @{ $records }) if $sort_spec{by};
29 sub _linked_records_implementation {
33 my $wanted = $params{direction} || croak("Missing parameter `direction'");
35 if ($wanted eq 'both') {
36 my $both = delete($params{both});
37 my %from_to = ( from => delete($params{from}) || $both,
38 to => delete($params{to}) || $both);
40 my @records = (@{ _linked_records_implementation($self, %params, direction => 'from', from => $from_to{from}) },
41 @{ _linked_records_implementation($self, %params, direction => 'to', to => $from_to{to} ) });
43 my %record_map = map { ( ref($_) . $_->id => $_ ) } @records;
45 return [ values %record_map ];
49 croak("Cannot use 'via' without '${wanted}_table'") if !$params{$wanted};
50 croak("Cannot use 'via' with '${wanted}_table' being an array") if ref $params{$wanted};
53 my $myself = $wanted eq 'from' ? 'to' : $wanted eq 'to' ? 'from' : croak("Invalid parameter `direction'");
54 my $my_table = SL::DB::Helper::Mappings::get_table_for_package(ref($self));
56 my $sub_wanted_table = "${wanted}_table";
57 my $sub_wanted_id = "${wanted}_id";
59 my ($wanted_classes, $wanted_tables);
60 if ($params{$wanted}) {
61 $wanted_classes = ref($params{$wanted}) eq 'ARRAY' ? $params{$wanted} : [ $params{$wanted} ];
62 $wanted_tables = [ map { SL::DB::Helper::Mappings::get_table_for_package($_) || croak("Invalid parameter `${wanted}'") } @{ $wanted_classes } ];
65 my @get_objects_query = ref($params{query}) eq 'ARRAY' ? @{ $params{query} } : ();
66 my $get_objects = sub {
68 my $manager_class = SL::DB::Helper::Mappings::get_manager_package_for_table($link->$sub_wanted_table);
69 my $object_class = SL::DB::Helper::Mappings::get_package_for_table($link->$sub_wanted_table);
70 eval "require " . $object_class . "; 1;";
72 $_->{_record_link_direction} = $wanted;
73 $_->{_record_link} = $link;
75 } @{ $manager_class->get_all(query => [ id => $link->$sub_wanted_id, @get_objects_query ]) };
78 # If no 'via' is given then use a simple(r) method for querying the wanted objects.
80 my @query = ( "${myself}_table" => $my_table,
81 "${myself}_id" => $self->id );
82 push @query, ( "${wanted}_table" => $wanted_tables ) if $wanted_tables;
84 return [ map { $get_objects->($_) } @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) } ];
87 # More complex handling for the 'via' case.
88 my @sources = ( $self );
89 my @targets = map { SL::DB::Helper::Mappings::get_table_for_package($_) } @{ ref($params{via}) ? $params{via} : [ $params{via} ] };
90 push @targets, @{ $wanted_tables } if $wanted_tables;
92 my %seen = map { ($_->meta->table . $_->id => 1) } @sources;
95 my @new_sources = @sources;
96 foreach my $src (@sources) {
97 my @query = ( "${myself}_table" => $src->meta->table,
98 "${myself}_id" => $src->id,
99 "${wanted}_table" => \@targets );
101 map { $get_objects->($_) }
102 grep { !$seen{$_->$sub_wanted_table . $_->$sub_wanted_id} }
103 @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) };
106 @sources = @new_sources;
107 %seen = map { ($_->meta->table . $_->id => 1) } @sources;
111 my %wanted_tables_map = map { ($_ => 1) } @{ $wanted_tables };
112 return [ grep { $wanted_tables_map{$_->meta->table} } @sources ];
120 croak "self has no id" unless $self->id;
121 croak "other has no id" unless $other->id;
123 my @directions = ([ 'from', 'to' ]);
124 push @directions, [ 'to', 'from' ] if $params{bidirectional};
127 foreach my $direction (@directions) {
128 my %data = ( $direction->[0] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($self)),
129 $direction->[0] . "_id" => $self->id,
130 $direction->[1] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($other)),
131 $direction->[1] . "_id" => $other->id,
134 my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
135 push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save unless $link;
138 return wantarray ? @links : $links[0];
141 sub sort_linked_records {
142 my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
144 @records = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
145 $sort_dir = $sort_dir * 1 ? 1 : -1;
147 my %numbers = ( 'SL::DB::SalesProcess' => sub { $_[0]->id },
148 'SL::DB::Order' => sub { $_[0]->quotation ? $_[0]->quonumber : $_[0]->ordnumber },
149 'SL::DB::DeliveryOrder' => sub { $_[0]->donumber },
150 'SL::DB::Invoice' => sub { $_[0]->invnumber },
151 'SL::DB::PurchaseInvoice' => sub { $_[0]->invnumber },
152 UNKNOWN => '9999999999999999',
154 my $number_xtor = sub {
155 my $number = $numbers{ ref($_[0]) };
156 $number = $number->($_[0]) if ref($number) eq 'CODE';
157 return $number || $numbers{UNKNOWN};
159 my $number_comparator = sub {
160 my $number_a = $number_xtor->($a);
161 my $number_b = $number_xtor->($b);
163 ncmp($number_a, $number_b) * $sort_dir;
167 %scores = ( 'SL::DB::SalesProcess' => 10,
168 'SL::DB::Order' => sub { $scores{ $_[0]->type } },
169 sales_quotation => 20,
171 sales_delivery_order => 40,
172 'SL::DB::DeliveryOrder' => sub { $scores{ $_[0]->type } },
173 'SL::DB::Invoice' => 50,
174 request_quotation => 120,
175 purchase_order => 130,
176 purchase_delivery_order => 140,
177 'SL::DB::PurchaseInvoice' => 150,
180 my $score_xtor = sub {
181 my $score = $scores{ ref($_[0]) };
182 $score = $score->($_[0]) if ref($score) eq 'CODE';
183 return $score || $scores{UNKNOWN};
185 my $type_comparator = sub {
186 my $score_a = $score_xtor->($a);
187 my $score_b = $score_xtor->($b);
189 $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
192 my $today = DateTime->today_local;
193 my $date_xtor = sub {
194 $_[0]->can('transdate_as_date') ? $_[0]->transdate_as_date
195 : $_[0]->can('itime_as_date') ? $_[0]->itime_as_date
198 my $date_comparator = sub {
199 my $date_a = $date_xtor->($a);
200 my $date_b = $date_xtor->($b);
202 ($date_a <=> $date_b) * $sort_dir;
205 my $comparator = $sort_by eq 'number' ? $number_comparator
206 : $sort_by eq 'date' ? $date_comparator
209 return [ sort($comparator @records) ];
212 sub filter_linked_records {
213 my ($self_or_class, $filter, @records) = @_;
215 if ($filter eq 'accessible') {
216 my $employee = SL::DB::Manager::Employee->current;
217 @records = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
219 croak "Unsupported filter parameter '${filter}'";
233 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
239 =item C<linked_records %params>
241 Retrieves records linked from or to C<$self> via the table
242 C<record_links>. The mandatory parameter C<direction> (either C<from>,
243 C<to> or C<both>) determines whether the function retrieves records
244 that link to C<$self> (for C<direction> = C<to>) or that are linked
245 from C<$self> (for C<direction> = C<from>). For C<direction = both>
246 all records linked from or to C<$self> are returned.
248 The optional parameter C<from> or C<to> (same as C<direction>)
249 contains the package names of Rose models for table limitation (the
250 prefix C<SL::DB::> is optional). It can be a single model name as a
251 single scalar or multiple model names in an array reference in which
252 case all links matching any of the model names will be returned.
254 The optional parameter C<via> can be used to retrieve all documents
255 that may have intermediate documents inbetween. It is an array
256 reference of Rose package names for the models that may be
257 intermediate link targets. One example is retrieving all invoices for
258 a given quotation no matter whether or not orders and delivery orders
259 have been created. If C<via> is given then C<from> or C<to> (depending
260 on C<direction>) must be given as well, and it must then not be an
265 If you only need invoices created directly from an order C<$order> (no
266 delivery orders inbetween) then the call could look like this:
268 my $invoices = $order->linked_records(direction => 'to',
271 Retrieving all invoices from a quotation no matter whether or not
272 orders or delivery orders where created:
274 my $invoices = $quotation->linked_records(direction => 'to',
276 via => [ 'Order', 'DeliveryOrder' ]);
278 The optional parameter C<query> can be used to limit the records
279 returned. The following call limits the earlier example to invoices
282 my $invoices = $order->linked_records(direction => 'to',
284 query => [ transdate => DateTime->today_local ]);
286 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
287 can be used in order to sort the result. If C<$params{sort_by}> is
288 trueish then the result is sorted by calling L</sort_linked_records>.
290 The optional parameter C<$params{filter}> controls whether or not the
291 result is filtered. Supported values are:
297 Removes all objects for which the function C<may_be_accessed> from the
298 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
299 the current employee.
303 Returns an array reference. Each element returned is a Rose::DB
304 instance. Additionally several elements in the element returned are
305 set to special values:
309 =item C<_record_link_direction>
311 Either C<from> or C<to> indicating the direction. C<from> means that
312 this object is the source in the link.
314 =item C<_record_link>
316 The actual database link object (an instance of L<SL::DB::RecordLink>).
320 =item C<link_to_record $record, %params>
322 Will create an entry in the table C<record_links> with the C<from>
323 side being C<$self> and the C<to> side being C<$record>. Will only
324 insert a new entry if such a link does not already exist.
326 If C<$params{bidirectional}> is trueish then another link will be
327 created with the roles of C<from> and C<to> reversed. This link will
328 also only be created if it doesn't exist already.
330 In scalar contenxt returns either the existing link or the newly
331 created one as an instance of C<SL::DB::RecordLink>. In array context
332 it returns an array of links (one entry if C<$params{bidirectional}>
333 is falsish and two entries if it is trueish).
335 =item C<sort_linked_records $sort_by, $sort_dir, @records>
337 Sorts linked records by C<$sort_by> in the direction given by
338 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
339 can be either a single array reference or or normal array.
341 C<$sort_by> can be one of the following strings:
347 Sort by type first and by record number second. The type order
348 reflects the order in which records are usually processed by the
349 employees: sales processes, sales quotations, sales orders, sales
350 delivery orders, invoices; requests for quotation, purchase orders,
351 purchase delivery orders, purchase invoices.
355 Sort by the record's running number.
359 Sort by the date the record was created or applies to.
363 Returns a hash reference.
365 Can be called both as a class or as an instance function.
367 This function is not exported.
373 This mixin exports the functions L</linked_records> and
382 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>