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};
  34
  35   if (!$wanted) {
  36     if ($params{to} && $params{from}) {
  37       $wanted = 'both';
  38     } elsif ($params{to}) {
  39       $wanted = 'to';
  40     } elsif ($params{from}) {
  41       $wanted = 'from';
  42     } else {
  43       $wanted = 'both';
  44     }
  45   }
  46
  47   if ($wanted eq 'both') {
  48     my $both       = delete($params{both});
  49     my %from_to    = ( from => delete($params{from}) || $both,
  50                        to   => delete($params{to})   || $both);
  51
  52     my @records    = (@{ _linked_records_implementation($self, %params, direction => 'from', from => $from_to{from}) },
  53                       @{ _linked_records_implementation($self, %params, direction => 'to',   to   => $from_to{to}  ) });
  54
  55     my %record_map = map { ( ref($_) . $_->id => $_ ) } @records;
  56
  57     return [ values %record_map ];
  58   }
  59
  60   if ($params{via}) {
  61     croak("Cannot use 'via' without '${wanted}_table'")             if !$params{$wanted};
  62     croak("Cannot use 'via' with '${wanted}_table' being an array") if ref $params{$wanted};
  63   }
  64
  65   my $myself           = $wanted eq 'from' ? 'to' : $wanted eq 'to' ? 'from' : croak("Invalid parameter `direction'");
  66   my $my_table         = SL::DB::Helper::Mappings::get_table_for_package(ref($self));
  67
  68   my $sub_wanted_table = "${wanted}_table";
  69   my $sub_wanted_id    = "${wanted}_id";
  70
  71   my ($wanted_classes, $wanted_tables);
  72   if ($params{$wanted}) {
  73     $wanted_classes = ref($params{$wanted}) eq 'ARRAY' ? $params{$wanted} : [ $params{$wanted} ];
  74     $wanted_tables  = [ map { SL::DB::Helper::Mappings::get_table_for_package($_) || croak("Invalid parameter `${wanted}'") } @{ $wanted_classes } ];
  75   }
  76
  77   my @get_objects_query = ref($params{query}) eq 'ARRAY' ? @{ $params{query} } : ();
  78   my $get_objects       = sub {
  79     my ($link)        = @_;
  80     my $manager_class = SL::DB::Helper::Mappings::get_manager_package_for_table($link->$sub_wanted_table);
  81     my $object_class  = SL::DB::Helper::Mappings::get_package_for_table($link->$sub_wanted_table);
  82     eval "require " . $object_class . "; 1;";
  83     return map {
  84       $_->{_record_link_direction} = $wanted;
  85       $_->{_record_link}           = $link;
  86       $_
  87     } @{ $manager_class->get_all(query => [ id => $link->$sub_wanted_id, @get_objects_query ]) };
  88   };
  89
  90   # If no 'via' is given then use a simple(r) method for querying the wanted objects.
  91   if (!$params{via}) {
  92     my @query = ( "${myself}_table" => $my_table,
  93                   "${myself}_id"    => $self->id );
  94     push @query, ( "${wanted}_table" => $wanted_tables ) if $wanted_tables;
  95
  96     return [ map { $get_objects->($_) } @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) } ];
  97   }
  98
  99   # More complex handling for the 'via' case.
 100   my @sources = ( $self );
 101   my @targets = map { SL::DB::Helper::Mappings::get_table_for_package($_) } @{ ref($params{via}) ? $params{via} : [ $params{via} ] };
 102   push @targets, @{ $wanted_tables } if $wanted_tables;
 103
 104   my %seen = map { ($_->meta->table . $_->id => 1) } @sources;
 105
 106   while (@targets) {
 107     my @new_sources = @sources;
 108     foreach my $src (@sources) {
 109       my @query = ( "${myself}_table" => $src->meta->table,
 110                     "${myself}_id"    => $src->id,
 111                     "${wanted}_table" => \@targets );
 112       push @new_sources,
 113            map  { $get_objects->($_) }
 114            grep { !$seen{$_->$sub_wanted_table . $_->$sub_wanted_id} }
 115            @{ SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]) };
 116     }
 117
 118     @sources = @new_sources;
 119     %seen    = map { ($_->meta->table . $_->id => 1) } @sources;
 120     shift @targets;
 121   }
 122
 123   my %wanted_tables_map = map  { ($_ => 1) } @{ $wanted_tables };
 124   return [ grep { $wanted_tables_map{$_->meta->table} } @sources ];
 125 }
 126
 127 sub link_to_record {
 128   my $self   = shift;
 129   my $other  = shift;
 130   my %params = @_;
 131
 132   croak "self has no id"  unless $self->id;
 133   croak "other has no id" unless $other->id;
 134
 135   my @directions = ([ 'from', 'to' ]);
 136   push @directions, [ 'to', 'from' ] if $params{bidirectional};
 137   my @links;
 138
 139   foreach my $direction (@directions) {
 140     my %data = ( $direction->[0] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($self)),
 141                  $direction->[0] . "_id"    => $self->id,
 142                  $direction->[1] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($other)),
 143                  $direction->[1] . "_id"    => $other->id,
 144                );
 145
 146     my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
 147     push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save;
 148   }
 149
 150   return wantarray ? @links : $links[0];
 151 }
 152
 153 sub sort_linked_records {
 154   my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
 155
 156   @records  = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
 157   $sort_dir = $sort_dir * 1 ? 1 : -1;
 158
 159   my %numbers = ( 'SL::DB::SalesProcess'    => sub { $_[0]->id },
 160                   'SL::DB::Order'           => sub { $_[0]->quotation ? $_[0]->quonumber : $_[0]->ordnumber },
 161                   'SL::DB::DeliveryOrder'   => sub { $_[0]->donumber },
 162                   'SL::DB::Invoice'         => sub { $_[0]->invnumber },
 163                   'SL::DB::PurchaseInvoice' => sub { $_[0]->invnumber },
 164                   'SL::DB::RequirementSpec' => sub { $_[0]->id },
 165                   UNKNOWN                   => '9999999999999999',
 166                 );
 167   my $number_xtor = sub {
 168     my $number = $numbers{ ref($_[0]) };
 169     $number    = $number->($_[0]) if ref($number) eq 'CODE';
 170     return $number || $numbers{UNKNOWN};
 171   };
 172   my $number_comparator = sub {
 173     my $number_a = $number_xtor->($a);
 174     my $number_b = $number_xtor->($b);
 175
 176     ncmp($number_a, $number_b) * $sort_dir;
 177   };
 178
 179   my %scores;
 180   %scores = ( 'SL::DB::SalesProcess'    =>  10,
 181               'SL::DB::RequirementSpec' =>  15,
 182               'SL::DB::Order'           =>  sub { $scores{ $_[0]->type } },
 183               sales_quotation           =>  20,
 184               sales_order               =>  30,
 185               sales_delivery_order      =>  40,
 186               'SL::DB::DeliveryOrder'   =>  sub { $scores{ $_[0]->type } },
 187               'SL::DB::Invoice'         =>  50,
 188               request_quotation         => 120,
 189               purchase_order            => 130,
 190               purchase_delivery_order   => 140,
 191               'SL::DB::PurchaseInvoice' => 150,
 192               UNKNOWN                   => 999,
 193             );
 194   my $score_xtor = sub {
 195     my $score = $scores{ ref($_[0]) };
 196     $score    = $score->($_[0]) if ref($score) eq 'CODE';
 197     return $score || $scores{UNKNOWN};
 198   };
 199   my $type_comparator = sub {
 200     my $score_a = $score_xtor->($a);
 201     my $score_b = $score_xtor->($b);
 202
 203     $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
 204   };
 205
 206   my $today     = DateTime->today_local;
 207   my $date_xtor = sub {
 208       $_[0]->can('transdate_as_date') ? $_[0]->transdate
 209     : $_[0]->can('itime_as_date')     ? $_[0]->itime->clone->truncate(to => 'day')
 210     :                                   $today;
 211   };
 212   my $date_comparator = sub {
 213     my $date_a = $date_xtor->($a);
 214     my $date_b = $date_xtor->($b);
 215
 216     ($date_a <=> $date_b) * $sort_dir;
 217   };
 218
 219   my $comparator = $sort_by eq 'number' ? $number_comparator
 220                  : $sort_by eq 'date'   ? $date_comparator
 221                  :                        $type_comparator;
 222
 223   return [ sort($comparator @records) ];
 224 }
 225
 226 sub filter_linked_records {
 227   my ($self_or_class, $filter, @records) = @_;
 228
 229   if ($filter eq 'accessible') {
 230     my $employee = SL::DB::Manager::Employee->current;
 231     @records     = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
 232   } else {
 233     croak "Unsupported filter parameter '${filter}'";
 234   }
 235
 236   return \@records;
 237 }
 238
 239 1;
 240
 241 __END__
 242
 243 =encoding utf8
 244
 245 =head1 NAME
 246
 247 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
 248
 249 SYNOPSIS
 250
 251   # In SL::DB::<Object>
 252   use SL::DB::Helper::LinkedRecords;
 253
 254   # later in consumer code
 255   # retrieve all links in both directions
 256   my @linked_objects = $order->linked_records;
 257
 258   # only links to Invoices
 259   my @linked_objects = $order->linked_records(
 260     to        => 'Invoice',
 261   );
 262
 263   # more than one target
 264   my @linked_objects = $order->linked_records(
 265     to        => [ 'Invoice', 'Order' ],
 266   );
 267
 268   # more than one direction
 269   my @linked_objects = $order->linked_records(
 270     both      => 'Invoice',
 271   );
 272
 273   # more than one direction and different targets
 274   my @linked_objects = $order->linked_records(
 275     to        => 'Invoice',
 276     from      => 'Order',
 277   );
 278
 279   # transitive over known classes
 280   my @linked_objects = $order->linked_records(
 281     direction => 'to',
 282     to        => 'Invoice',
 283     via       => 'DeliveryOrder',
 284   );
 285
 286   # limit direction when further params contain additional keys
 287   my %params = (to => 'Invoice', from => 'Order');
 288   my @linked_objects = $order->linked_records(
 289     direction => 'to',
 290     %params,
 291   );
 292
 293   # add a new link
 294   $order->link_to_record($invoice);
 295   $order->link_to_record($purchase_order, bidirectional => 1);
 296
 297
 298 =head1 FUNCTIONS
 299
 300 =over 4
 301
 302 =item C<linked_records %params>
 303
 304 Retrieves records linked from or to C<$self> via the table C<record_links>.
 305
 306 The optional parameter C<direction> (either C<from>, C<to> or C<both>)
 307 determines whether the function retrieves records that link to C<$self> (for
 308 C<direction> = C<to>) or that are linked from C<$self> (for C<direction> =
 309 C<from>). For C<direction = both> all records linked from or to C<$self> are
 310 returned.
 311
 312 The optional parameter C<from> or C<to> (same as C<direction>) contains the
 313 package names of Rose models for table limitation (the prefix C<SL::DB::> is
 314 optional). It can be a single model name as a single scalar or multiple model
 315 names in an array reference in which case all links matching any of the model
 316 names will be returned.
 317
 318 If no parameter C<direction> is given, but any of C<to>, C<from> or C<both>,
 319 then C<direction> is infered accordingly. If neither are given, C<direction> is
 320 set to C<both>.
 321
 322 The optional parameter C<via> can be used to retrieve all documents that may
 323 have intermediate documents inbetween. It is an array reference of Rose package
 324 names for the models that may be intermediate link targets. One example is
 325 retrieving all invoices for a given quotation no matter whether or not orders
 326 and delivery orders have been created. If C<via> is given then C<from> or C<to>
 327 (depending on C<direction>) must be given as well, and it must then not be an
 328 array reference.
 329
 330 Examples:
 331
 332 If you only need invoices created directly from an order C<$order> (no
 333 delivery orders inbetween) then the call could look like this:
 334
 335   my $invoices = $order->linked_records(
 336     direction => 'to',
 337     to        => 'Invoice',
 338   );
 339
 340 Retrieving all invoices from a quotation no matter whether or not
 341 orders or delivery orders where created:
 342
 343   my $invoices = $quotation->linked_records(
 344     direction => 'to',
 345     to        => 'Invoice',
 346     via       => [ 'Order', 'DeliveryOrder' ],
 347   );
 348
 349 The optional parameter C<query> can be used to limit the records
 350 returned. The following call limits the earlier example to invoices
 351 created today:
 352
 353   my $invoices = $order->linked_records(
 354     direction => 'to',
 355     to        => 'Invoice',
 356     query     => [ transdate => DateTime->today_local ],
 357   );
 358
 359 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
 360 can be used in order to sort the result. If C<$params{sort_by}> is
 361 trueish then the result is sorted by calling L</sort_linked_records>.
 362
 363 The optional parameter C<$params{filter}> controls whether or not the
 364 result is filtered. Supported values are:
 365
 366 =over 2
 367
 368 =item C<accessible>
 369
 370 Removes all objects for which the function C<may_be_accessed> from the
 371 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
 372 the current employee.
 373
 374 =back
 375
 376 Returns an array reference. Each element returned is a Rose::DB
 377 instance. Additionally several elements in the element returned are
 378 set to special values:
 379
 380 =over 2
 381
 382 =item C<_record_link_direction>
 383
 384 Either C<from> or C<to> indicating the direction. C<from> means that
 385 this object is the source in the link.
 386
 387 =item C<_record_link>
 388
 389 The actual database link object (an instance of L<SL::DB::RecordLink>).
 390
 391 =back
 392
 393 =item C<link_to_record $record, %params>
 394
 395 Will create an entry in the table C<record_links> with the C<from>
 396 side being C<$self> and the C<to> side being C<$record>. Will only
 397 insert a new entry if such a link does not already exist.
 398
 399 If C<$params{bidirectional}> is trueish then another link will be
 400 created with the roles of C<from> and C<to> reversed. This link will
 401 also only be created if it doesn't exist already.
 402
 403 In scalar context returns either the existing link or the newly
 404 created one as an instance of C<SL::DB::RecordLink>. In array context
 405 it returns an array of links (one entry if C<$params{bidirectional}>
 406 is falsish and two entries if it is trueish).
 407
 408 =item C<sort_linked_records $sort_by, $sort_dir, @records>
 409
 410 Sorts linked records by C<$sort_by> in the direction given by
 411 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
 412 can be either a single array reference or or normal array.
 413
 414 C<$sort_by> can be one of the following strings:
 415
 416 =over 2
 417
 418 =item * C<type>
 419
 420 Sort by type first and by record number second. The type order
 421 reflects the order in which records are usually processed by the
 422 employees: sales processes, sales quotations, sales orders, sales
 423 delivery orders, invoices; requests for quotation, purchase orders,
 424 purchase delivery orders, purchase invoices.
 425
 426 =item * C<number>
 427
 428 Sort by the record's running number.
 429
 430 =item * C<date>
 431
 432 Sort by the transdate of the record was created or applies to.
 433
 434 Note: If the latter has a default setting it will always mask the creation time.
 435
 436 =back
 437
 438 Returns an array reference.
 439
 440 Can only be called both as a class function since it is noe exported.
 441
 442 =back
 443
 444 =head1 EXPORTS
 445
 446 This mixin exports the functions L</linked_records> and
 447 L</link_to_record>.
 448
 449 =head1 BUGS
 450
 451 Nothing here yet.
 452
 453 =head1 AUTHOR
 454
 455 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 456
 457 =cut