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