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 {
67 my $manager_class = SL::DB::Helper::Mappings::get_manager_package_for_table($_[0]->$sub_wanted_table);
68 my $object_class = SL::DB::Helper::Mappings::get_package_for_table($_[0]->$sub_wanted_table);
69 eval "require " . $object_class . "; 1;";
70 return @{ $manager_class->get_all(query => [ id => $_[0]->$sub_wanted_id, @get_objects_query ]) };
73 # If no 'via' is given then use a simple(r) method for querying the wanted objects.
75 my @query = ( "${myself}_table" => $my_table,
76 "${myself}_id" => $self->id );
77 push @query, ( "${wanted}_table" => $wanted_tables ) if $wanted_tables;
79 return [ map { $get_objects->($_) } @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) } ];
82 # More complex handling for the 'via' case.
83 my @sources = ( $self );
84 my @targets = map { SL::DB::Helper::Mappings::get_table_for_package($_) } @{ ref($params{via}) ? $params{via} : [ $params{via} ] };
85 push @targets, @{ $wanted_tables } if $wanted_tables;
87 my %seen = map { ($_->meta->table . $_->id => 1) } @sources;
90 my @new_sources = @sources;
91 foreach my $src (@sources) {
92 my @query = ( "${myself}_table" => $src->meta->table,
93 "${myself}_id" => $src->id,
94 "${wanted}_table" => \@targets );
96 map { $get_objects->($_) }
97 grep { !$seen{$_->$sub_wanted_table . $_->$sub_wanted_id} }
98 @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) };
101 @sources = @new_sources;
102 %seen = map { ($_->meta->table . $_->id => 1) } @sources;
106 my %wanted_tables_map = map { ($_ => 1) } @{ $wanted_tables };
107 return [ grep { $wanted_tables_map{$_->meta->table} } @sources ];
115 croak "self has no id" unless $self->id;
116 croak "other has no id" unless $other->id;
118 my @directions = ([ 'from', 'to' ]);
119 push @directions, [ 'to', 'from' ] if $params{bidirectional};
122 foreach my $direction (@directions) {
123 my %data = ( $direction->[0] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($self)),
124 $direction->[0] . "_id" => $self->id,
125 $direction->[1] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($other)),
126 $direction->[1] . "_id" => $other->id,
129 my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
130 push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save unless $link;
133 return wantarray ? @links : $links[0];
136 sub sort_linked_records {
137 my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
139 @records = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
140 $sort_dir = $sort_dir * 1 ? 1 : -1;
142 my %numbers = ( 'SL::DB::SalesProcess' => sub { $_[0]->id },
143 'SL::DB::Order' => sub { $_[0]->quotation ? $_[0]->quonumber : $_[0]->ordnumber },
144 'SL::DB::DeliveryOrder' => sub { $_[0]->donumber },
145 'SL::DB::Invoice' => sub { $_[0]->invnumber },
146 'SL::DB::PurchaseInvoice' => sub { $_[0]->invnumber },
147 UNKNOWN => '9999999999999999',
149 my $number_xtor = sub {
150 my $number = $numbers{ ref($_[0]) };
151 $number = $number->($_[0]) if ref($number) eq 'CODE';
152 return $number || $numbers{UNKNOWN};
154 my $number_comparator = sub {
155 my $number_a = $number_xtor->($a);
156 my $number_b = $number_xtor->($b);
158 ncmp($number_a, $number_b) * $sort_dir;
162 %scores = ( 'SL::DB::SalesProcess' => 10,
163 'SL::DB::Order' => sub { $scores{ $_[0]->type } },
164 sales_quotation => 20,
166 sales_delivery_order => 40,
167 'SL::DB::DeliveryOrder' => sub { $scores{ $_[0]->type } },
168 'SL::DB::Invoice' => 50,
169 request_quotation => 120,
170 purchase_order => 130,
171 purchase_delivery_order => 140,
172 'SL::DB::PurchaseInvoice' => 150,
175 my $score_xtor = sub {
176 my $score = $scores{ ref($_[0]) };
177 $score = $score->($_[0]) if ref($score) eq 'CODE';
178 return $score || $scores{UNKNOWN};
180 my $type_comparator = sub {
181 my $score_a = $score_xtor->($a);
182 my $score_b = $score_xtor->($b);
184 $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
187 my $today = DateTime->today_local;
188 my $date_xtor = sub {
189 $_[0]->can('transdate_as_date') ? $_[0]->transdate_as_date
190 : $_[0]->can('itime_as_date') ? $_[0]->itime_as_date
193 my $date_comparator = sub {
194 my $date_a = $date_xtor->($a);
195 my $date_b = $date_xtor->($b);
197 ($date_a <=> $date_b) * $sort_dir;
200 my $comparator = $sort_by eq 'number' ? $number_comparator
201 : $sort_by eq 'date' ? $date_comparator
204 return [ sort($comparator @records) ];
207 sub filter_linked_records {
208 my ($self_or_class, $filter, @records) = @_;
210 if ($filter eq 'accessible') {
211 my $employee = SL::DB::Manager::Employee->current;
212 @records = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
214 croak "Unsupported filter parameter '${filter}'";
228 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
234 =item C<linked_records %params>
236 Retrieves records linked from or to C<$self> via the table
237 C<record_links>. The mandatory parameter C<direction> (either C<from>,
238 C<to> or C<both>) determines whether the function retrieves records
239 that link to C<$self> (for C<direction> = C<to>) or that are linked
240 from C<$self> (for C<direction> = C<from>). For C<direction = both>
241 all records linked from or to C<$self> are returned.
243 The optional parameter C<from> or C<to> (same as C<direction>)
244 contains the package names of Rose models for table limitation (the
245 prefix C<SL::DB::> is optional). It can be a single model name as a
246 single scalar or multiple model names in an array reference in which
247 case all links matching any of the model names will be returned.
249 The optional parameter C<via> can be used to retrieve all documents
250 that may have intermediate documents inbetween. It is an array
251 reference of Rose package names for the models that may be
252 intermediate link targets. One example is retrieving all invoices for
253 a given quotation no matter whether or not orders and delivery orders
254 have been created. If C<via> is given then C<from> or C<to> (depending
255 on C<direction>) must be given as well, and it must then not be an
260 If you only need invoices created directly from an order C<$order> (no
261 delivery orders inbetween) then the call could look like this:
263 my $invoices = $order->linked_records(direction => 'to',
266 Retrieving all invoices from a quotation no matter whether or not
267 orders or delivery orders where created:
269 my $invoices = $quotation->linked_records(direction => 'to',
271 via => [ 'Order', 'DeliveryOrder' ]);
273 The optional parameter C<query> can be used to limit the records
274 returned. The following call limits the earlier example to invoices
277 my $invoices = $order->linked_records(direction => 'to',
279 query => [ transdate => DateTime->today_local ]);
281 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
282 can be used in order to sort the result. If C<$params{sort_by}> is
283 trueish then the result is sorted by calling L</sort_linked_records>.
285 The optional parameter C<$params{filter}> controls whether or not the
286 result is filtered. Supported values are:
292 Removes all objects for which the function C<may_be_accessed> from the
293 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
294 the current employee.
298 Returns an array reference.
300 =item C<link_to_record $record, %params>
302 Will create an entry in the table C<record_links> with the C<from>
303 side being C<$self> and the C<to> side being C<$record>. Will only
304 insert a new entry if such a link does not already exist.
306 If C<$params{bidirectional}> is trueish then another link will be
307 created with the roles of C<from> and C<to> reversed. This link will
308 also only be created if it doesn't exist already.
310 In scalar contenxt returns either the existing link or the newly
311 created one as an instance of C<SL::DB::RecordLink>. In array context
312 it returns an array of links (one entry if C<$params{bidirectional}>
313 is falsish and two entries if it is trueish).
315 =item C<sort_linked_records $sort_by, $sort_dir, @records>
317 Sorts linked records by C<$sort_by> in the direction given by
318 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
319 can be either a single array reference or or normal array.
321 C<$sort_by> can be one of the following strings:
327 Sort by type first and by record number second. The type order
328 reflects the order in which records are usually processed by the
329 employees: sales processes, sales quotations, sales orders, sales
330 delivery orders, invoices; requests for quotation, purchase orders,
331 purchase delivery orders, purchase invoices.
335 Sort by the record's running number.
339 Sort by the date the record was created or applies to.
343 Returns a hash reference.
345 Can be called both as a class or as an instance function.
347 This function is not exported.
353 This mixin exports the functions L</linked_records> and
362 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>