SL/DB/Helper/LinkedRecords.pm

   1 package SL::DB::Helper::LinkedRecords;
   2
   3 use strict;
   4
   5 require Exporter;
   6 our @ISA    = qw(Exporter);
   7 our @EXPORT = qw(linked_records link_to_record);
   8
   9 use Carp;
  10 use Sort::Naturally;
  11
  12 use SL::DB::Helper::Mappings;
  13 use SL::DB::RecordLink;
  14
  15 sub linked_records {
  16   my ($self, %params) = @_;
  17
  18   my %sort_spec       = ( by  => delete($params{sort_by}),
  19                           dir => delete($params{sort_dir}) );
  20   my $filter          =  delete $params{filter};
  21
  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};
  25
  26   return $records;
  27 }
  28
  29 sub _linked_records_implementation {
  30   my $self     = shift;
  31   my %params   = @_;
  32
  33   my $wanted   = $params{direction} || croak("Missing parameter `direction'");
  34
  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);
  39
  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}  ) });
  42
  43     my %record_map = map { ( ref($_) . $_->id => $_ ) } @records;
  44
  45     return [ values %record_map ];
  46   }
  47
  48   if ($params{via}) {
  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};
  51   }
  52
  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));
  55
  56   my $sub_wanted_table = "${wanted}_table";
  57   my $sub_wanted_id    = "${wanted}_id";
  58
  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 } ];
  63   }
  64
  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 ]) };
  71   };
  72
  73   # If no 'via' is given then use a simple(r) method for querying the wanted objects.
  74   if (!$params{via}) {
  75     my @query = ( "${myself}_table" => $my_table,
  76                   "${myself}_id"    => $self->id );
  77     push @query, ( "${wanted}_table" => $wanted_tables ) if $wanted_tables;
  78
  79     return [ map { $get_objects->($_) } @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) } ];
  80   }
  81
  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;
  86
  87   my %seen = map { ($_->meta->table . $_->id => 1) } @sources;
  88
  89   while (@targets) {
  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 );
  95       push @new_sources,
  96            map  { $get_objects->($_) }
  97            grep { !$seen{$_->$sub_wanted_table . $_->$sub_wanted_id} }
  98            @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) };
  99     }
 100
 101     @sources = @new_sources;
 102     %seen    = map { ($_->meta->table . $_->id => 1) } @sources;
 103     shift @targets;
 104   }
 105
 106   my %wanted_tables_map = map  { ($_ => 1) } @{ $wanted_tables };
 107   return [ grep { $wanted_tables_map{$_->meta->table} } @sources ];
 108 }
 109
 110 sub link_to_record {
 111   my $self   = shift;
 112   my $other  = shift;
 113   my %params = @_;
 114
 115   croak "self has no id"  unless $self->id;
 116   croak "other has no id" unless $other->id;
 117
 118   my @directions = ([ 'from', 'to' ]);
 119   push @directions, [ 'to', 'from' ] if $params{bidirectional};
 120   my @links;
 121
 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,
 127                );
 128
 129     my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
 130     push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save unless $link;
 131   }
 132
 133   return wantarray ? @links : $links[0];
 134 }
 135
 136 sub sort_linked_records {
 137   my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
 138
 139   @records  = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
 140   $sort_dir = $sort_dir * 1 ? 1 : -1;
 141
 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',
 148                 );
 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};
 153   };
 154   my $number_comparator = sub {
 155     my $number_a = $number_xtor->($a);
 156     my $number_b = $number_xtor->($b);
 157
 158     ncmp($number_a, $number_b) * $sort_dir;
 159   };
 160
 161   my %scores;
 162   %scores = ( 'SL::DB::SalesProcess'    =>  10,
 163               'SL::DB::Order'           =>  sub { $scores{ $_[0]->type } },
 164               sales_quotation           =>  20,
 165               sales_order               =>  30,
 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,
 173               UNKNOWN                   => 999,
 174             );
 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};
 179   };
 180   my $type_comparator = sub {
 181     my $score_a = $score_xtor->($a);
 182     my $score_b = $score_xtor->($b);
 183
 184     $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
 185   };
 186
 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
 191     :                                   $today;
 192   };
 193   my $date_comparator = sub {
 194     my $date_a = $date_xtor->($a);
 195     my $date_b = $date_xtor->($b);
 196
 197     ($date_a <=> $date_b) * $sort_dir;
 198   };
 199
 200   my $comparator = $sort_by eq 'number' ? $number_comparator
 201                  : $sort_by eq 'date'   ? $date_comparator
 202                  :                        $type_comparator;
 203
 204   return [ sort($comparator @records) ];
 205 }
 206
 207 sub filter_linked_records {
 208   my ($self_or_class, $filter, @records) = @_;
 209
 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;
 213   } else {
 214     croak "Unsupported filter parameter '${filter}'";
 215   }
 216
 217   return \@records;
 218 }
 219
 220 1;
 221
 222 __END__
 223
 224 =encoding utf8
 225
 226 =head1 NAME
 227
 228 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
 229
 230 =head1 FUNCTIONS
 231
 232 =over 4
 233
 234 =item C<linked_records %params>
 235
 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.
 242
 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.
 248
 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
 256 array reference.
 257
 258 Examples:
 259
 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:
 262
 263   my $invoices = $order->linked_records(direction => 'to',
 264                                         to        => 'Invoice');
 265
 266 Retrieving all invoices from a quotation no matter whether or not
 267 orders or delivery orders where created:
 268
 269   my $invoices = $quotation->linked_records(direction => 'to',
 270                                             to        => 'Invoice',
 271                                             via       => [ 'Order', 'DeliveryOrder' ]);
 272
 273 The optional parameter C<query> can be used to limit the records
 274 returned. The following call limits the earlier example to invoices
 275 created today:
 276
 277   my $invoices = $order->linked_records(direction => 'to',
 278                                         to        => 'Invoice',
 279                                         query     => [ transdate => DateTime->today_local ]);
 280
 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>.
 284
 285 The optional parameter C<$params{filter}> controls whether or not the
 286 result is filtered. Supported values are:
 287
 288 =over 2
 289
 290 =item C<accessible>
 291
 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.
 295
 296 =back
 297
 298 Returns an array reference.
 299
 300 =item C<link_to_record $record, %params>
 301
 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.
 305
 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.
 309
 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).
 314
 315 =item C<sort_linked_records $sort_by, $sort_dir, @records>
 316
 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.
 320
 321 C<$sort_by> can be one of the following strings:
 322
 323 =over 2
 324
 325 =item * C<type>
 326
 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.
 332
 333 =item * C<number>
 334
 335 Sort by the record's running number.
 336
 337 =item * C<date>
 338
 339 Sort by the date the record was created or applies to.
 340
 341 =back
 342
 343 Returns a hash reference.
 344
 345 Can be called both as a class or as an instance function.
 346
 347 This function is not exported.
 348
 349 =back
 350
 351 =head1 EXPORTS
 352
 353 This mixin exports the functions L</linked_records> and
 354 L</link_to_record>.
 355
 356 =head1 BUGS
 357
 358 Nothing here yet.
 359
 360 =head1 AUTHOR
 361
 362 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 363
 364 =cut