SL/DB/Helper/LinkedRecords.pm

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