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 ($link)        = @_;
  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;";
  71     return map {
  72       $_->{_record_link_direction} = $wanted;
  73       $_->{_record_link}           = $link;
  74       $_
  75     } @{ $manager_class->get_all(query => [ id => $link->$sub_wanted_id, @get_objects_query ]) };
  76   };
  77
  78   # If no 'via' is given then use a simple(r) method for querying the wanted objects.
  79   if (!$params{via}) {
  80     my @query = ( "${myself}_table" => $my_table,
  81                   "${myself}_id"    => $self->id );
  82     push @query, ( "${wanted}_table" => $wanted_tables ) if $wanted_tables;
  83
  84     return [ map { $get_objects->($_) } @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) } ];
  85   }
  86
  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;
  91
  92   my %seen = map { ($_->meta->table . $_->id => 1) } @sources;
  93
  94   while (@targets) {
  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 );
 100       push @new_sources,
 101            map  { $get_objects->($_) }
 102            grep { !$seen{$_->$sub_wanted_table . $_->$sub_wanted_id} }
 103            @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) };
 104     }
 105
 106     @sources = @new_sources;
 107     %seen    = map { ($_->meta->table . $_->id => 1) } @sources;
 108     shift @targets;
 109   }
 110
 111   my %wanted_tables_map = map  { ($_ => 1) } @{ $wanted_tables };
 112   return [ grep { $wanted_tables_map{$_->meta->table} } @sources ];
 113 }
 114
 115 sub link_to_record {
 116   my $self   = shift;
 117   my $other  = shift;
 118   my %params = @_;
 119
 120   croak "self has no id"  unless $self->id;
 121   croak "other has no id" unless $other->id;
 122
 123   my @directions = ([ 'from', 'to' ]);
 124   push @directions, [ 'to', 'from' ] if $params{bidirectional};
 125   my @links;
 126
 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,
 132                );
 133
 134     my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
 135     push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save unless $link;
 136   }
 137
 138   return wantarray ? @links : $links[0];
 139 }
 140
 141 sub sort_linked_records {
 142   my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
 143
 144   @records  = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
 145   $sort_dir = $sort_dir * 1 ? 1 : -1;
 146
 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                   'SL::DB::RequirementSpec' => sub { $_[0]->id },
 153                   UNKNOWN                   => '9999999999999999',
 154                 );
 155   my $number_xtor = sub {
 156     my $number = $numbers{ ref($_[0]) };
 157     $number    = $number->($_[0]) if ref($number) eq 'CODE';
 158     return $number || $numbers{UNKNOWN};
 159   };
 160   my $number_comparator = sub {
 161     my $number_a = $number_xtor->($a);
 162     my $number_b = $number_xtor->($b);
 163
 164     ncmp($number_a, $number_b) * $sort_dir;
 165   };
 166
 167   my %scores;
 168   %scores = ( 'SL::DB::SalesProcess'    =>  10,
 169               'SL::DB::RequirementSpec' =>  15,
 170               'SL::DB::Order'           =>  sub { $scores{ $_[0]->type } },
 171               sales_quotation           =>  20,
 172               sales_order               =>  30,
 173               sales_delivery_order      =>  40,
 174               'SL::DB::DeliveryOrder'   =>  sub { $scores{ $_[0]->type } },
 175               'SL::DB::Invoice'         =>  50,
 176               request_quotation         => 120,
 177               purchase_order            => 130,
 178               purchase_delivery_order   => 140,
 179               'SL::DB::PurchaseInvoice' => 150,
 180               UNKNOWN                   => 999,
 181             );
 182   my $score_xtor = sub {
 183     my $score = $scores{ ref($_[0]) };
 184     $score    = $score->($_[0]) if ref($score) eq 'CODE';
 185     return $score || $scores{UNKNOWN};
 186   };
 187   my $type_comparator = sub {
 188     my $score_a = $score_xtor->($a);
 189     my $score_b = $score_xtor->($b);
 190
 191     $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
 192   };
 193
 194   my $today     = DateTime->today_local;
 195   my $date_xtor = sub {
 196       $_[0]->can('transdate_as_date') ? $_[0]->transdate_as_date
 197     : $_[0]->can('itime_as_date')     ? $_[0]->itime_as_date
 198     :                                   $today;
 199   };
 200   my $date_comparator = sub {
 201     my $date_a = $date_xtor->($a);
 202     my $date_b = $date_xtor->($b);
 203
 204     ($date_a <=> $date_b) * $sort_dir;
 205   };
 206
 207   my $comparator = $sort_by eq 'number' ? $number_comparator
 208                  : $sort_by eq 'date'   ? $date_comparator
 209                  :                        $type_comparator;
 210
 211   return [ sort($comparator @records) ];
 212 }
 213
 214 sub filter_linked_records {
 215   my ($self_or_class, $filter, @records) = @_;
 216
 217   if ($filter eq 'accessible') {
 218     my $employee = SL::DB::Manager::Employee->current;
 219     @records     = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
 220   } else {
 221     croak "Unsupported filter parameter '${filter}'";
 222   }
 223
 224   return \@records;
 225 }
 226
 227 1;
 228
 229 __END__
 230
 231 =encoding utf8
 232
 233 =head1 NAME
 234
 235 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
 236
 237 =head1 FUNCTIONS
 238
 239 =over 4
 240
 241 =item C<linked_records %params>
 242
 243 Retrieves records linked from or to C<$self> via the table
 244 C<record_links>. The mandatory parameter C<direction> (either C<from>,
 245 C<to> or C<both>) determines whether the function retrieves records
 246 that link to C<$self> (for C<direction> = C<to>) or that are linked
 247 from C<$self> (for C<direction> = C<from>). For C<direction = both>
 248 all records linked from or to C<$self> are returned.
 249
 250 The optional parameter C<from> or C<to> (same as C<direction>)
 251 contains the package names of Rose models for table limitation (the
 252 prefix C<SL::DB::> is optional). It can be a single model name as a
 253 single scalar or multiple model names in an array reference in which
 254 case all links matching any of the model names will be returned.
 255
 256 The optional parameter C<via> can be used to retrieve all documents
 257 that may have intermediate documents inbetween. It is an array
 258 reference of Rose package names for the models that may be
 259 intermediate link targets. One example is retrieving all invoices for
 260 a given quotation no matter whether or not orders and delivery orders
 261 have been created. If C<via> is given then C<from> or C<to> (depending
 262 on C<direction>) must be given as well, and it must then not be an
 263 array reference.
 264
 265 Examples:
 266
 267 If you only need invoices created directly from an order C<$order> (no
 268 delivery orders inbetween) then the call could look like this:
 269
 270   my $invoices = $order->linked_records(direction => 'to',
 271                                         to        => 'Invoice');
 272
 273 Retrieving all invoices from a quotation no matter whether or not
 274 orders or delivery orders where created:
 275
 276   my $invoices = $quotation->linked_records(direction => 'to',
 277                                             to        => 'Invoice',
 278                                             via       => [ 'Order', 'DeliveryOrder' ]);
 279
 280 The optional parameter C<query> can be used to limit the records
 281 returned. The following call limits the earlier example to invoices
 282 created today:
 283
 284   my $invoices = $order->linked_records(direction => 'to',
 285                                         to        => 'Invoice',
 286                                         query     => [ transdate => DateTime->today_local ]);
 287
 288 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
 289 can be used in order to sort the result. If C<$params{sort_by}> is
 290 trueish then the result is sorted by calling L</sort_linked_records>.
 291
 292 The optional parameter C<$params{filter}> controls whether or not the
 293 result is filtered. Supported values are:
 294
 295 =over 2
 296
 297 =item C<accessible>
 298
 299 Removes all objects for which the function C<may_be_accessed> from the
 300 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
 301 the current employee.
 302
 303 =back
 304
 305 Returns an array reference. Each element returned is a Rose::DB
 306 instance. Additionally several elements in the element returned are
 307 set to special values:
 308
 309 =over 2
 310
 311 =item C<_record_link_direction>
 312
 313 Either C<from> or C<to> indicating the direction. C<from> means that
 314 this object is the source in the link.
 315
 316 =item C<_record_link>
 317
 318 The actual database link object (an instance of L<SL::DB::RecordLink>).
 319
 320 =back
 321
 322 =item C<link_to_record $record, %params>
 323
 324 Will create an entry in the table C<record_links> with the C<from>
 325 side being C<$self> and the C<to> side being C<$record>. Will only
 326 insert a new entry if such a link does not already exist.
 327
 328 If C<$params{bidirectional}> is trueish then another link will be
 329 created with the roles of C<from> and C<to> reversed. This link will
 330 also only be created if it doesn't exist already.
 331
 332 In scalar contenxt returns either the existing link or the newly
 333 created one as an instance of C<SL::DB::RecordLink>. In array context
 334 it returns an array of links (one entry if C<$params{bidirectional}>
 335 is falsish and two entries if it is trueish).
 336
 337 =item C<sort_linked_records $sort_by, $sort_dir, @records>
 338
 339 Sorts linked records by C<$sort_by> in the direction given by
 340 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
 341 can be either a single array reference or or normal array.
 342
 343 C<$sort_by> can be one of the following strings:
 344
 345 =over 2
 346
 347 =item * C<type>
 348
 349 Sort by type first and by record number second. The type order
 350 reflects the order in which records are usually processed by the
 351 employees: sales processes, sales quotations, sales orders, sales
 352 delivery orders, invoices; requests for quotation, purchase orders,
 353 purchase delivery orders, purchase invoices.
 354
 355 =item * C<number>
 356
 357 Sort by the record's running number.
 358
 359 =item * C<date>
 360
 361 Sort by the date the record was created or applies to.
 362
 363 =back
 364
 365 Returns a hash reference.
 366
 367 Can be called both as a class or as an instance function.
 368
 369 This function is not exported.
 370
 371 =back
 372
 373 =head1 EXPORTS
 374
 375 This mixin exports the functions L</linked_records> and
 376 L</link_to_record>.
 377
 378 =head1 BUGS
 379
 380 Nothing here yet.
 381
 382 =head1 AUTHOR
 383
 384 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 385
 386 =cut