SL/DB/Order.pm

   1 package SL::DB::Order;
   2
   3 use utf8;
   4 use strict;
   5
   6 use Carp;
   7 use DateTime;
   8 use List::Util qw(max);
   9 use List::MoreUtils qw(any);
  10
  11 use SL::DB::MetaSetup::Order;
  12 use SL::DB::Manager::Order;
  13 use SL::DB::Helper::AttrHTML;
  14 use SL::DB::Helper::AttrSorted;
  15 use SL::DB::Helper::FlattenToForm;
  16 use SL::DB::Helper::LinkedRecords;
  17 use SL::DB::Helper::PriceTaxCalculator;
  18 use SL::DB::Helper::PriceUpdater;
  19 use SL::DB::Helper::TransNumberGenerator;
  20 use SL::RecordLinks;
  21 use Rose::DB::Object::Helpers qw(as_tree);
  22
  23 __PACKAGE__->meta->add_relationship(
  24   orderitems => {
  25     type         => 'one to many',
  26     class        => 'SL::DB::OrderItem',
  27     column_map   => { id => 'trans_id' },
  28     manager_args => {
  29       with_objects => [ 'part' ]
  30     }
  31   },
  32   periodic_invoices_config => {
  33     type                   => 'one to one',
  34     class                  => 'SL::DB::PeriodicInvoicesConfig',
  35     column_map             => { id => 'oe_id' },
  36   },
  37   custom_shipto            => {
  38     type                   => 'one to one',
  39     class                  => 'SL::DB::Shipto',
  40     column_map             => { id => 'trans_id' },
  41     query_args             => [ module => 'OE' ],
  42   },
  43 );
  44
  45 __PACKAGE__->meta->initialize;
  46
  47 __PACKAGE__->attr_html('notes');
  48 __PACKAGE__->attr_sorted('items');
  49
  50 __PACKAGE__->before_save('_before_save_set_ord_quo_number');
  51
  52 # hooks
  53
  54 sub _before_save_set_ord_quo_number {
  55   my ($self) = @_;
  56
  57   # ordnumber is 'NOT NULL'. Therefore make sure it's always set to at
  58   # least an empty string, even if we're saving a quotation.
  59   $self->ordnumber('') if !$self->ordnumber;
  60
  61   my $field = $self->quotation ? 'quonumber' : 'ordnumber';
  62   $self->create_trans_number if !$self->$field;
  63
  64   return 1;
  65 }
  66
  67 # methods
  68
  69 sub items { goto &orderitems; }
  70 sub add_items { goto &add_orderitems; }
  71 sub record_number { goto &number; }
  72
  73 sub type {
  74   my $self = shift;
  75
  76   return 'sales_order'       if $self->customer_id && ! $self->quotation;
  77   return 'purchase_order'    if $self->vendor_id   && ! $self->quotation;
  78   return 'sales_quotation'   if $self->customer_id &&   $self->quotation;
  79   return 'request_quotation' if $self->vendor_id   &&   $self->quotation;
  80
  81   return;
  82 }
  83
  84 sub is_type {
  85   return shift->type eq shift;
  86 }
  87
  88 sub displayable_type {
  89   my $type = shift->type;
  90
  91   return $::locale->text('Sales quotation')   if $type eq 'sales_quotation';
  92   return $::locale->text('Request quotation') if $type eq 'request_quotation';
  93   return $::locale->text('Sales Order')       if $type eq 'sales_order';
  94   return $::locale->text('Purchase Order')    if $type eq 'purchase_order';
  95
  96   die 'invalid type';
  97 }
  98
  99 sub displayable_name {
 100   join ' ', grep $_, map $_[0]->$_, qw(displayable_type record_number);
 101 };
 102
 103 sub is_sales {
 104   croak 'not an accessor' if @_ > 1;
 105   return !!shift->customer_id;
 106 }
 107
 108 sub invoices {
 109   my $self   = shift;
 110   my %params = @_;
 111
 112   if ($self->quotation) {
 113     return [];
 114   } else {
 115     require SL::DB::Invoice;
 116     return SL::DB::Manager::Invoice->get_all(
 117       query => [
 118         ordnumber => $self->ordnumber,
 119         @{ $params{query} || [] },
 120       ]
 121     );
 122   }
 123 }
 124
 125 sub displayable_state {
 126   my ($self) = @_;
 127
 128   return $self->closed ? $::locale->text('closed') : $::locale->text('open');
 129 }
 130
 131 sub abschlag_invoices {
 132   return shift()->invoices(query => [ abschlag => 1 ]);
 133 }
 134
 135 sub end_invoice {
 136   return shift()->invoices(query => [ abschlag => 0 ]);
 137 }
 138
 139 sub convert_to_invoice {
 140   my ($self, %params) = @_;
 141
 142   croak("Conversion to invoices is only supported for sales records") unless $self->customer_id;
 143
 144   my $invoice;
 145   if (!$self->db->with_transaction(sub {
 146     require SL::DB::Invoice;
 147     $invoice = SL::DB::Invoice->new_from($self)->post(%params) || die;
 148     $self->link_to_record($invoice);
 149     $self->update_attributes(closed => 1);
 150     1;
 151   })) {
 152     return undef;
 153   }
 154
 155   return $invoice;
 156 }
 157
 158 sub convert_to_delivery_order {
 159   my ($self, @args) = @_;
 160
 161   my $delivery_order;
 162   if (!$self->db->with_transaction(sub {
 163     require SL::DB::DeliveryOrder;
 164     $delivery_order = SL::DB::DeliveryOrder->new_from($self, @args);
 165     $delivery_order->save;
 166     $self->link_to_record($delivery_order);
 167     # TODO extend link_to_record for items, otherwise long-term no d.r.y.
 168     foreach my $item (@{ $delivery_order->items }) {
 169       foreach (qw(orderitems)) {    # expand if needed (delivery_order_items)
 170         if ($item->{"converted_from_${_}_id"}) {
 171           die unless $item->{id};
 172           RecordLinks->create_links('dbh'        => $self->db->dbh,
 173                                     'mode'       => 'ids',
 174                                     'from_table' => $_,
 175                                     'from_ids'   => $item->{"converted_from_${_}_id"},
 176                                     'to_table'   => 'delivery_order_items',
 177                                     'to_id'      => $item->{id},
 178           ) || die;
 179           delete $item->{"converted_from_${_}_id"};
 180         }
 181       }
 182     }
 183
 184     $self->update_attributes(delivered => 1);
 185     1;
 186   })) {
 187     return undef;
 188   }
 189
 190   return $delivery_order;
 191 }
 192
 193 sub _clone_orderitem_cvar {
 194   my ($cvar) = @_;
 195
 196   my $cloned = $_->clone_and_reset;
 197   $cloned->sub_module('orderitems');
 198
 199   return $cloned;
 200 }
 201
 202 sub new_from {
 203   my ($class, $source, %params) = @_;
 204
 205   croak("Unsupported source object type '" . ref($source) . "'") unless ref($source) eq 'SL::DB::Order';
 206   croak("A destination type must be given as parameter")         unless $params{destination_type};
 207
 208   my $destination_type  = delete $params{destination_type};
 209
 210   my @from_tos = (
 211     { from => 'sales_quotation',   to => 'sales_order',       abbr => 'sqso' },
 212     { from => 'request_quotation', to => 'purchase_order',    abbr => 'rqpo' },
 213     { from => 'sales_quotation',   to => 'sales_quotation',   abbr => 'sqsq' },
 214     { from => 'sales_order',       to => 'sales_order',       abbr => 'soso' },
 215     { from => 'request_quotation', to => 'request_quotation', abbr => 'rqrq' },
 216     { from => 'purchase_order',    to => 'purchase_order',    abbr => 'popo' },
 217     { from => 'sales_order',       to => 'purchase_order',    abbr => 'sopo' },
 218     { from => 'purchase_order',    to => 'sales_order',       abbr => 'poso' },
 219   );
 220   my $from_to = (grep { $_->{from} eq $source->type && $_->{to} eq $destination_type} @from_tos)[0];
 221   croak("Cannot convert from '" . $source->type . "' to '" . $destination_type . "'") if !$from_to;
 222
 223   my $is_abbr_any = sub {
 224     # foreach my $abbr (@_) {
 225     #   croak "no such abbreviation: '$abbr'" if !grep { $_->{abbr} eq $abbr } @from_tos;
 226     # }
 227     any { $from_to->{abbr} eq $_ } @_;
 228   };
 229
 230   my ($item_parent_id_column, $item_parent_column);
 231
 232   if (ref($source) eq 'SL::DB::Order') {
 233     $item_parent_id_column = 'trans_id';
 234     $item_parent_column    = 'order';
 235   }
 236
 237   my %args = ( map({ ( $_ => $source->$_ ) } qw(amount cp_id currency_id cusordnumber customer_id delivery_customer_id delivery_term_id delivery_vendor_id
 238                                                 department_id employee_id globalproject_id intnotes marge_percent marge_total language_id netamount notes
 239                                                 ordnumber payment_id quonumber reqdate salesman_id shippingpoint shipvia taxincluded taxzone_id
 240                                                 transaction_description vendor_id
 241                                              )),
 242                quotation => !!($destination_type =~ m{quotation$}),
 243                closed    => 0,
 244                delivered => 0,
 245                transdate => DateTime->today_local,
 246             );
 247
 248   if ( $is_abbr_any->(qw(sopo poso)) ) {
 249     $args{ordnumber} = undef;
 250     $args{reqdate}   = DateTime->today_local->next_workday();
 251     $args{employee}  = SL::DB::Manager::Employee->current;
 252   }
 253   if ( $is_abbr_any->(qw(sopo)) ) {
 254     $args{customer_id}      = undef;
 255     $args{salesman_id}      = undef;
 256     $args{payment_id}       = undef;
 257     $args{delivery_term_id} = undef;
 258   }
 259   if ( $is_abbr_any->(qw(poso)) ) {
 260     $args{vendor_id} = undef;
 261   }
 262   if ( $is_abbr_any->(qw(soso)) ) {
 263     $args{periodic_invoices_config} = $source->periodic_invoices_config->clone_and_reset if $source->periodic_invoices_config;
 264   }
 265
 266   # Custom shipto addresses (the ones specific to the sales/purchase
 267   # record and not to the customer/vendor) are only linked from
 268   # shipto → order. Meaning order.shipto_id
 269   # will not be filled in that case.
 270   if (!$source->shipto_id && $source->id) {
 271     $args{custom_shipto} = $source->custom_shipto->clone($class) if $source->can('custom_shipto') && $source->custom_shipto;
 272
 273   } else {
 274     $args{shipto_id} = $source->shipto_id;
 275   }
 276
 277   my $order = $class->new(%args);
 278   $order->assign_attributes(%{ $params{attributes} }) if $params{attributes};
 279   my $items = delete($params{items}) || $source->items_sorted;
 280
 281   my %item_parents;
 282
 283   my @items = map {
 284     my $source_item      = $_;
 285     my $source_item_id   = $_->$item_parent_id_column;
 286     my @custom_variables = map { _clone_orderitem_cvar($_) } @{ $source_item->custom_variables };
 287
 288     $item_parents{$source_item_id} ||= $source_item->$item_parent_column;
 289     my $item_parent                  = $item_parents{$source_item_id};
 290
 291     my $current_oe_item = SL::DB::OrderItem->new(map({ ( $_ => $source_item->$_ ) }
 292                                                      qw(active_discount_source active_price_source base_qty cusordnumber
 293                                                         description discount lastcost longdescription
 294                                                         marge_percent marge_price_factor marge_total
 295                                                         ordnumber parts_id price_factor price_factor_id pricegroup_id
 296                                                         project_id qty reqdate sellprice serialnumber ship subtotal transdate unit
 297                                                      )),
 298                                                  custom_variables => \@custom_variables,
 299     );
 300     if ( $is_abbr_any->(qw(sopo)) ) {
 301       $current_oe_item->sellprice($source_item->lastcost);
 302       $current_oe_item->discount(0);
 303     }
 304     if ( $is_abbr_any->(qw(poso)) ) {
 305       $current_oe_item->lastcost($source_item->sellprice);
 306     }
 307     $current_oe_item->{"converted_from_orderitems_id"} = $_->{id} if ref($item_parent) eq 'SL::DB::Order';
 308     $current_oe_item;
 309   } @{ $items };
 310
 311   @items = grep { $params{item_filter}->($_) } @items if $params{item_filter};
 312   @items = grep { $_->qty * 1 } @items if $params{skip_items_zero_qty};
 313   @items = grep { $_->qty >=0 } @items if $params{skip_items_negative_qty};
 314
 315   $order->items(\@items);
 316
 317   return $order;
 318 }
 319
 320 sub new_from_multi {
 321   my ($class, $sources, %params) = @_;
 322
 323   croak("Unsupported object type in sources")                             if any { ref($_) !~ m{SL::DB::Order} }                   @$sources;
 324   croak("Cannot create order for purchase records")                       if any { !$_->is_sales }                                 @$sources;
 325   croak("Cannot create order from source records of different customers") if any { $_->customer_id != $sources->[0]->customer_id } @$sources;
 326
 327   # bb: todo: check shipto: is it enough to check the ids or do we have to compare the entries?
 328   if (delete $params{check_same_shipto}) {
 329     die "check same shipto address is not implemented yet";
 330     die "Source records do not have the same shipto"        if 1;
 331   }
 332
 333   # sort sources
 334   if (defined $params{sort_sources_by}) {
 335     my $sort_by = delete $params{sort_sources_by};
 336     if ($sources->[0]->can($sort_by)) {
 337       $sources = [ sort { $a->$sort_by cmp $b->$sort_by } @$sources ];
 338     } else {
 339       die "Cannot sort source records by $sort_by";
 340     }
 341   }
 342
 343   # set this entries to undef that yield different information
 344   my %attributes;
 345   foreach my $attr (qw(ordnumber transdate reqdate taxincluded shippingpoint
 346                        shipvia notes closed delivered reqdate quonumber
 347                        cusordnumber proforma transaction_description
 348                        order_probability expected_billing_date)) {
 349     $attributes{$attr} = undef if any { ($sources->[0]->$attr//'') ne ($_->$attr//'') } @$sources;
 350   }
 351   foreach my $attr (qw(cp_id currency_id employee_id salesman_id department_id
 352                        delivery_customer_id delivery_vendor_id shipto_id
 353                        globalproject_id)) {
 354     $attributes{$attr} = undef if any { ($sources->[0]->$attr||0) != ($_->$attr||0) }   @$sources;
 355   }
 356
 357   # set this entries from customer that yield different information
 358   foreach my $attr (qw(language_id taxzone_id payment_id delivery_term_id)) {
 359     $attributes{$attr}  = $sources->[0]->customervendor->$attr if any { ($sources->[0]->$attr||0)     != ($_->$attr||0) }      @$sources;
 360   }
 361   $attributes{intnotes} = $sources->[0]->customervendor->notes if any { ($sources->[0]->intnotes//'') ne ($_->intnotes//'')  } @$sources;
 362
 363   # no periodic invoice config for new order
 364   $attributes{periodic_invoices_config} = undef;
 365
 366   # copy global ordnumber, transdate, cusordnumber into item scope
 367   #   unless already present there
 368   foreach my $attr (qw(ordnumber transdate cusordnumber)) {
 369     foreach my $src (@$sources) {
 370       foreach my $item (@{ $src->items_sorted }) {
 371         $item->$attr($src->$attr) if !$item->$attr;
 372       }
 373     }
 374   }
 375
 376   # collect items
 377   my @items;
 378   push @items, @{$_->items_sorted} for @$sources;
 379   # make order from first source and all items
 380   my $order = $class->new_from($sources->[0],
 381                                destination_type => 'sales_order',
 382                                attributes       => \%attributes,
 383                                items            => \@items,
 384                                %params);
 385
 386   return $order;
 387 }
 388
 389 sub number {
 390   my $self = shift;
 391
 392   return if !$self->type;
 393
 394   my %number_method = (
 395     sales_order       => 'ordnumber',
 396     sales_quotation   => 'quonumber',
 397     purchase_order    => 'ordnumber',
 398     request_quotation => 'quonumber',
 399   );
 400
 401   return $self->${ \ $number_method{$self->type} }(@_);
 402 }
 403
 404 sub customervendor {
 405   $_[0]->is_sales ? $_[0]->customer : $_[0]->vendor;
 406 }
 407
 408 sub date {
 409   goto &transdate;
 410 }
 411
 412 sub digest {
 413   my ($self) = @_;
 414
 415   sprintf "%s %s %s (%s)",
 416     $self->number,
 417     $self->customervendor->name,
 418     $self->amount_as_number,
 419     $self->date->to_kivitendo;
 420 }
 421
 422 1;
 423
 424 __END__
 425
 426 =pod
 427
 428 =encoding utf8
 429
 430 =head1 NAME
 431
 432 SL::DB::Order - Order Datenbank Objekt.
 433
 434 =head1 FUNCTIONS
 435
 436 =head2 C<type>
 437
 438 Returns one of the following string types:
 439
 440 =over 4
 441
 442 =item sales_order
 443
 444 =item purchase_order
 445
 446 =item sales_quotation
 447
 448 =item request_quotation
 449
 450 =back
 451
 452 =head2 C<is_type TYPE>
 453
 454 Returns true if the order is of the given type.
 455
 456 =head2 C<convert_to_delivery_order %params>
 457
 458 Creates a new delivery order with C<$self> as the basis by calling
 459 L<SL::DB::DeliveryOrder::new_from>. That delivery order is saved, and
 460 C<$self> is linked to the new invoice via
 461 L<SL::DB::RecordLink>. C<$self>'s C<delivered> attribute is set to
 462 C<true>, and C<$self> is saved.
 463
 464 The arguments in C<%params> are passed to
 465 L<SL::DB::DeliveryOrder::new_from>.
 466
 467 Returns C<undef> on failure. Otherwise the new delivery order will be
 468 returned.
 469
 470 =head2 C<convert_to_invoice %params>
 471
 472 Creates a new invoice with C<$self> as the basis by calling
 473 L<SL::DB::Invoice::new_from>. That invoice is posted, and C<$self> is
 474 linked to the new invoice via L<SL::DB::RecordLink>. C<$self>'s
 475 C<closed> attribute is set to C<true>, and C<$self> is saved.
 476
 477 The arguments in C<%params> are passed to L<SL::DB::Invoice::post>.
 478
 479 Returns the new invoice instance on success and C<undef> on
 480 failure. The whole process is run inside a transaction. On failure
 481 nothing is created or changed in the database.
 482
 483 At the moment only sales quotations and sales orders can be converted.
 484
 485 =head2 C<new_from $source, %params>
 486
 487 Creates a new C<SL::DB::Order> instance and copies as much
 488 information from C<$source> as possible. At the moment only records with the
 489 same destination type as the source type and sales orders from
 490 sales quotations and purchase orders from requests for quotations can be
 491 created.
 492
 493 The C<transdate> field will be set to the current date.
 494
 495 The conversion copies the order items as well.
 496
 497 Returns the new order instance. The object returned is not
 498 saved.
 499
 500 C<%params> can include the following options
 501 (C<destination_type> is mandatory):
 502
 503 =over 4
 504
 505 =item C<destination_type>
 506
 507 (mandatory)
 508 The type of the newly created object. Can be C<sales_quotation>,
 509 C<sales_order>, C<purchase_quotation> or C<purchase_order> for now.
 510
 511 =item C<items>
 512
 513 An optional array reference of RDBO instances for the items to use. If
 514 missing then the method C<items_sorted> will be called on
 515 C<$source>. This option can be used to override the sorting, to
 516 exclude certain positions or to add additional ones.
 517
 518 =item C<skip_items_negative_qty>
 519
 520 If trueish then items with a negative quantity are skipped. Items with
 521 a quantity of 0 are not affected by this option.
 522
 523 =item C<skip_items_zero_qty>
 524
 525 If trueish then items with a quantity of 0 are skipped.
 526
 527 =item C<item_filter>
 528
 529 An optional code reference that is called for each item with the item
 530 as its sole parameter. Items for which the code reference returns a
 531 falsish value will be skipped.
 532
 533 =item C<attributes>
 534
 535 An optional hash reference. If it exists then it is passed to C<new>
 536 allowing the caller to set certain attributes for the new delivery
 537 order.
 538
 539 =back
 540
 541 =head2 C<new_from_multi $sources, %params>
 542
 543 Creates a new C<SL::DB::Order> instance from multiple sources and copies as
 544 much information from C<$sources> as possible.
 545 At the moment only sales orders can be combined and they must be of the same
 546 customer.
 547
 548 The new order is created from the first one using C<new_from> and the positions
 549 of all orders are added to the new order. The orders can be sorted with the
 550 parameter C<sort_sources_by>.
 551
 552 The orders attributes are kept if they contain the same information for all
 553 source orders an will be set to empty if they contain different information.
 554
 555 Returns the new order instance. The object returned is not
 556 saved.
 557
 558 C<params> other then C<sort_sources_by> are passed to C<new_from>.
 559
 560 =head1 BUGS
 561
 562 Nothing here yet.
 563
 564 =head1 AUTHOR
 565
 566 Sven Schöling <s.schoeling@linet-services.de>
 567
 568 =cut