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   my $myself   = $wanted eq 'from' ? 'to' : $wanted eq 'to' ? 'from' : croak("Invalid parameter `direction'");
  49
  50   my $my_table = SL::DB::Helper::Mappings::get_table_for_package(ref($self));
  51
  52   my @query    = ( "${myself}_table" => $my_table,
  53                    "${myself}_id"    => $self->id );
  54
  55   if ($params{$wanted}) {
  56     my $wanted_classes = ref($params{$wanted}) eq 'ARRAY' ? $params{$wanted} : [ $params{$wanted} ];
  57     my $wanted_tables  = [ map { SL::DB::Helper::Mappings::get_table_for_package($_) || croak("Invalid parameter `${wanted}'") } @{ $wanted_classes } ];
  58     push @query, ("${wanted}_table" => $wanted_tables);
  59   }
  60
  61   my $links            = SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]);
  62
  63   my $sub_wanted_table = "${wanted}_table";
  64   my $sub_wanted_id    = "${wanted}_id";
  65
  66   my $records          = [];
  67   @query               = ref($params{query}) eq 'ARRAY' ? @{ $params{query} } : ();
  68
  69   foreach my $link (@{ $links }) {
  70     my $manager_class = SL::DB::Helper::Mappings::get_manager_package_for_table($link->$sub_wanted_table);
  71     my $object_class  = SL::DB::Helper::Mappings::get_package_for_table($link->$sub_wanted_table);
  72     eval "require " . $object_class . "; 1;";
  73     push @{ $records }, @{ $manager_class->get_all(query => [ id => $link->$sub_wanted_id, @query ]) };
  74   }
  75
  76   return $records;
  77 }
  78
  79 sub link_to_record {
  80   my $self   = shift;
  81   my $other  = shift;
  82   my %params = @_;
  83
  84   croak "self has no id"  unless $self->id;
  85   croak "other has no id" unless $other->id;
  86
  87   my @directions = ([ 'from', 'to' ]);
  88   push @directions, [ 'to', 'from' ] if $params{bidirectional};
  89   my @links;
  90
  91   foreach my $direction (@directions) {
  92     my %data = ( $direction->[0] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($self)),
  93                  $direction->[0] . "_id"    => $self->id,
  94                  $direction->[1] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($other)),
  95                  $direction->[1] . "_id"    => $other->id,
  96                );
  97
  98     my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
  99     push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save unless $link;
 100   }
 101
 102   return wantarray ? @links : $links[0];
 103 }
 104
 105 sub sort_linked_records {
 106   my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
 107
 108   @records  = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
 109   $sort_dir = $sort_dir * 1 ? 1 : -1;
 110
 111   my %numbers = ( 'SL::DB::SalesProcess'    => sub { $_[0]->id },
 112                   'SL::DB::Order'           => sub { $_[0]->quotation ? $_[0]->quonumber : $_[0]->ordnumber },
 113                   'SL::DB::DeliveryOrder'   => sub { $_[0]->donumber },
 114                   'SL::DB::Invoice'         => sub { $_[0]->invnumber },
 115                   'SL::DB::PurchaseInvoice' => sub { $_[0]->invnumber },
 116                   UNKNOWN                   => '9999999999999999',
 117                 );
 118   my $number_xtor = sub {
 119     my $number = $numbers{ ref($_[0]) };
 120     $number    = $number->($_[0]) if ref($number) eq 'CODE';
 121     return $number || $numbers{UNKNOWN};
 122   };
 123   my $number_comparator = sub {
 124     my $number_a = $number_xtor->($a);
 125     my $number_b = $number_xtor->($b);
 126
 127     ncmp($number_a, $number_b) * $sort_dir;
 128   };
 129
 130   my %scores;
 131   %scores = ( 'SL::DB::SalesProcess'    =>  10,
 132               'SL::DB::Order'           =>  sub { $scores{ $_[0]->type } },
 133               sales_quotation           =>  20,
 134               sales_order               =>  30,
 135               sales_delivery_order      =>  40,
 136               'SL::DB::DeliveryOrder'   =>  sub { $scores{ $_[0]->type } },
 137               'SL::DB::Invoice'         =>  50,
 138               request_quotation         => 120,
 139               purchase_order            => 130,
 140               purchase_delivery_order   => 140,
 141               'SL::DB::PurchaseInvoice' => 150,
 142               UNKNOWN                   => 999,
 143             );
 144   my $score_xtor = sub {
 145     my $score = $scores{ ref($_[0]) };
 146     $score    = $score->($_[0]) if ref($score) eq 'CODE';
 147     return $score || $scores{UNKNOWN};
 148   };
 149   my $type_comparator = sub {
 150     my $score_a = $score_xtor->($a);
 151     my $score_b = $score_xtor->($b);
 152
 153     $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
 154   };
 155
 156   my $today     = DateTime->today_local;
 157   my $date_xtor = sub {
 158       $_[0]->can('transdate_as_date') ? $_[0]->transdate_as_date
 159     : $_[0]->can('itime_as_date')     ? $_[0]->itime_as_date
 160     :                                   $today;
 161   };
 162   my $date_comparator = sub {
 163     my $date_a = $date_xtor->($a);
 164     my $date_b = $date_xtor->($b);
 165
 166     ($date_a <=> $date_b) * $sort_dir;
 167   };
 168
 169   my $comparator = $sort_by eq 'number' ? $number_comparator
 170                  : $sort_by eq 'date'   ? $date_comparator
 171                  :                        $type_comparator;
 172
 173   return [ sort($comparator @records) ];
 174 }
 175
 176 sub filter_linked_records {
 177   my ($self_or_class, $filter, @records) = @_;
 178
 179   if ($filter eq 'accessible') {
 180     my $employee = SL::DB::Manager::Employee->current;
 181     @records     = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
 182   } else {
 183     croak "Unsupported filter parameter '${filter}'";
 184   }
 185
 186   return \@records;
 187 }
 188
 189 1;
 190
 191 __END__
 192
 193 =encoding utf8
 194
 195 =head1 NAME
 196
 197 SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
 198
 199 =head1 FUNCTIONS
 200
 201 =over 4
 202
 203 =item C<linked_records %params>
 204
 205 Retrieves records linked from or to C<$self> via the table
 206 C<record_links>. The mandatory parameter C<direction> (either C<from>,
 207 C<to> or C<both>) determines whether the function retrieves records
 208 that link to C<$self> (for C<direction> = C<to>) or that are linked
 209 from C<$self> (for C<direction> = C<from>). For C<direction = both>
 210 all records linked from or to C<$self> are returned.
 211
 212 The optional parameter C<from> or C<to> (same as C<direction>)
 213 contains the package names of Rose models for table limitation. It can
 214 be a single model name as a single scalar or multiple model names in
 215 an array reference in which case all links matching any of the model
 216 names will be returned.
 217
 218 If you only need invoices created from an order C<$order> then the
 219 call could look like this:
 220
 221   my $invoices = $order->linked_records(direction => 'to',
 222                                         to        => 'SL::DB::Invoice');
 223
 224 The optional parameter C<query> can be used to limit the records
 225 returned. The following call limits the earlier example to invoices
 226 created today:
 227
 228   my $invoices = $order->linked_records(direction => 'to',
 229                                         to        => 'SL::DB::Invoice',
 230                                         query     => [ transdate => DateTime->today_local ]);
 231
 232 The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
 233 can be used in order to sort the result. If C<$params{sort_by}> is
 234 trueish then the result is sorted by calling L</sort_linked_records>.
 235
 236 The optional parameter C<$params{filter}> controls whether or not the
 237 result is filtered. Supported values are:
 238
 239 =over 2
 240
 241 =item C<accessible>
 242
 243 Removes all objects for which the function C<may_be_accessed> from the
 244 mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
 245 the current employee.
 246
 247 =back
 248
 249 Returns an array reference.
 250
 251 =item C<link_to_record $record, %params>
 252
 253 Will create an entry in the table C<record_links> with the C<from>
 254 side being C<$self> and the C<to> side being C<$record>. Will only
 255 insert a new entry if such a link does not already exist.
 256
 257 If C<$params{bidirectional}> is trueish then another link will be
 258 created with the roles of C<from> and C<to> reversed. This link will
 259 also only be created if it doesn't exist already.
 260
 261 In scalar contenxt returns either the existing link or the newly
 262 created one as an instance of C<SL::DB::RecordLink>. In array context
 263 it returns an array of links (one entry if C<$params{bidirectional}>
 264 is falsish and two entries if it is trueish).
 265
 266 =item C<sort_linked_records $sort_by, $sort_dir, @records>
 267
 268 Sorts linked records by C<$sort_by> in the direction given by
 269 C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
 270 can be either a single array reference or or normal array.
 271
 272 C<$sort_by> can be one of the following strings:
 273
 274 =over 2
 275
 276 =item * C<type>
 277
 278 Sort by type first and by record number second. The type order
 279 reflects the order in which records are usually processed by the
 280 employees: sales processes, sales quotations, sales orders, sales
 281 delivery orders, invoices; requests for quotation, purchase orders,
 282 purchase delivery orders, purchase invoices.
 283
 284 =item * C<number>
 285
 286 Sort by the record's running number.
 287
 288 =item * C<date>
 289
 290 Sort by the date the record was created or applies to.
 291
 292 =back
 293
 294 Returns a hash reference.
 295
 296 Can be called both as a class or as an instance function.
 297
 298 This function is not exported.
 299
 300 =back
 301
 302 =head1 EXPORTS
 303
 304 This mixin exports the functions L</linked_records> and
 305 L</link_to_record>.
 306
 307 =head1 BUGS
 308
 309 Nothing here yet.
 310
 311 =head1 AUTHOR
 312
 313 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 314
 315 =cut