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
 197     : $_[0]->can('itime_as_date')     ? $_[0]->itime->clone->truncate(to => 'day')
 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 SYNOPSIS
 238
 239   # In SL::DB::<Object>
 240   use SL::DB::Helper::LinkedRecords;
 241
 242   # later in consumer code
 243   # retrieve all links
 244   my @linked_objects = $order->linked_records(
 245     direction => 'both',
 246   );
 247
 248   # only links to Invoices
 249   my @linked_objects = $order->linked_records(
 250     direction => 'to',
 251     to        => 'Invoice',
 252   );
 253
 254   # more than one target
 255   my @linked_objects = $order->linked_records(
 256     direction => 'to',
 257     to        => [ 'Invoice', 'Order' ],
 258   );
 259
 260   # more than one direction
 261   my @linked_objects = $order->linked_records(
 262     direction => 'both',
 263     both      => 'Invoice',
 264   );
 265
 266   # more than one direction and different targets
 267   my @linked_objects = $order->linked_records(
 268     direction => 'both',
 269     to        => 'Invoice',
 270     from      => 'Order',
 271   );
 272
 273   # transitive over known classes
 274   my @linked_objects = $order->linked_records(
 275     direction => 'to',
 276     to        => 'Invoice',
 277     via       => 'DeliveryOrder',
 278   );
 279
 280   # add a new link
 281   $order->link_to_record($invoice);
 282   $order->link_to_record($purchase_order, bidirectional => 1);
 283
 284
 285 =head1 FUNCTIONS
 286
 287 =over 4
 288
 289 =item C<linked_records %params>
 290
 291 Retrieves records linked from or to C<$self> via the table C<record_links>. The
 292 mandatory parameter C<direction> (either C<from>, C<to> or C<both>) determines
 293 whether the function retrieves records that link to C<$self> (for C<direction>
 294 = C<to>) or that are linked from C<$self> (for C<direction> = C<from>). For
 295 C<direction = both> all records linked from or to C<$self> are returned.
 296
 297 The optional parameter C<from> or C<to> (same as C<direction>) contains the
 298 package names of Rose models for table limitation (the prefix C<SL::DB::> is
 299 optional). It can be a single model name as a single scalar or multiple model
 300 names in an array reference in which case all links matching any of the model
 301 names will be returned.
 302
 303 The optional parameter C<via> can be used to retrieve all documents that may
 304 have intermediate documents inbetween. It is an array reference of Rose package
 305 names for the models that may be intermediate link targets. One example is
 306 retrieving all invoices for a given quotation no matter whether or not orders
 307 and delivery orders have been created. If C<via> is given then C<from> or C<to>
 308 (depending on C<direction>) must be given as well, and it must then not be an
 309 array reference.
 310
 311 Examples:
 312
 313 If you only need invoices created directly from an order C<$order> (no
 314 delivery orders inbetween) then the call could look like this:
 315
 316   my $invoices = $order->linked_records(
 317     direction => 'to',
 318     to        => 'Invoice',
 319   );
 320
 321 Retrieving all invoices from a quotation no matter whether or not
 322 orders or delivery orders where created:
 323
 324   my $invoices = $quotation->linked_records(
 325     direction => 'to',
 326     to        => 'Invoice',
 327     via       => [ 'Order', 'DeliveryOrder' ],
 328   );
 329
 330 The optional parameter C<query> can be used to limit the records
 331 returned. The following call limits the earlier example to invoices
 332 created today:
 333
 334   my $invoices = $order->linked_records(
 335     direction => 'to',
 336     to        => 'Invoice',
 337     query     => [ transdate => DateTime->today_local ],
 338   );
 339
 340 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
 341 can be used in order to sort the result. If C<$params{sort_by}> is
 342 trueish then the result is sorted by calling L</sort_linked_records>.
 343
 344 The optional parameter C<$params{filter}> controls whether or not the
 345 result is filtered. Supported values are:
 346
 347 =over 2
 348
 349 =item C<accessible>
 350
 351 Removes all objects for which the function C<may_be_accessed> from the
 352 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
 353 the current employee.
 354
 355 =back
 356
 357 Returns an array reference. Each element returned is a Rose::DB
 358 instance. Additionally several elements in the element returned are
 359 set to special values:
 360
 361 =over 2
 362
 363 =item C<_record_link_direction>
 364
 365 Either C<from> or C<to> indicating the direction. C<from> means that
 366 this object is the source in the link.
 367
 368 =item C<_record_link>
 369
 370 The actual database link object (an instance of L<SL::DB::RecordLink>).
 371
 372 =back
 373
 374 =item C<link_to_record $record, %params>
 375
 376 Will create an entry in the table C<record_links> with the C<from>
 377 side being C<$self> and the C<to> side being C<$record>. Will only
 378 insert a new entry if such a link does not already exist.
 379
 380 If C<$params{bidirectional}> is trueish then another link will be
 381 created with the roles of C<from> and C<to> reversed. This link will
 382 also only be created if it doesn't exist already.
 383
 384 In scalar context returns either the existing link or the newly
 385 created one as an instance of C<SL::DB::RecordLink>. In array context
 386 it returns an array of links (one entry if C<$params{bidirectional}>
 387 is falsish and two entries if it is trueish).
 388
 389 =item C<sort_linked_records $sort_by, $sort_dir, @records>
 390
 391 Sorts linked records by C<$sort_by> in the direction given by
 392 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
 393 can be either a single array reference or or normal array.
 394
 395 C<$sort_by> can be one of the following strings:
 396
 397 =over 2
 398
 399 =item * C<type>
 400
 401 Sort by type first and by record number second. The type order
 402 reflects the order in which records are usually processed by the
 403 employees: sales processes, sales quotations, sales orders, sales
 404 delivery orders, invoices; requests for quotation, purchase orders,
 405 purchase delivery orders, purchase invoices.
 406
 407 =item * C<number>
 408
 409 Sort by the record's running number.
 410
 411 =item * C<date>
 412
 413 Sort by the transdate of the record was created or applies to.
 414
 415 Note: If the latter has a default setting it will always mask the creation time.
 416
 417 =back
 418
 419 Returns an array reference.
 420
 421 Can only be called both as a class function since it is noe exported.
 422
 423 =back
 424
 425 =head1 EXPORTS
 426
 427 This mixin exports the functions L</linked_records> and
 428 L</link_to_record>.
 429
 430 =head1 BUGS
 431
 432 Nothing here yet.
 433
 434 =head1 AUTHOR
 435
 436 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 437
 438 =cut