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