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