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