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__, 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 exchangerate {
 124   my ($self, $val) = @_;
 125
 126   return 1 if $self->currency_id == $::instance_conf->get_currency_id;
 127
 128   # unable to determine if sales or purchase
 129   return undef if !$self->has_customervendor;
 130
 131   my $rate = $self->is_sales ? 'buy' : 'sell';
 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 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)) {
 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<convert_to_delivery_order %params>
 499
 500 Creates a new delivery order with C<$self> as the basis by calling
 501 L<SL::DB::DeliveryOrder::new_from>. That delivery order is saved, and
 502 C<$self> is linked to the new invoice via
 503 L<SL::DB::RecordLink>. C<$self>'s C<delivered> attribute is set to
 504 C<true>, and C<$self> is saved.
 505
 506 The arguments in C<%params> are passed to
 507 L<SL::DB::DeliveryOrder::new_from>.
 508
 509 Returns C<undef> on failure. Otherwise the new delivery order will be
 510 returned.
 511
 512 =head2 C<convert_to_invoice %params>
 513
 514 Creates a new invoice with C<$self> as the basis by calling
 515 L<SL::DB::Invoice::new_from>. That invoice is posted, and C<$self> is
 516 linked to the new invoice via L<SL::DB::RecordLink>. C<$self>'s
 517 C<closed> attribute is set to C<true>, and C<$self> is saved.
 518
 519 The arguments in C<%params> are passed to L<SL::DB::Invoice::post>.
 520
 521 Returns the new invoice instance on success and C<undef> on
 522 failure. The whole process is run inside a transaction. On failure
 523 nothing is created or changed in the database.
 524
 525 At the moment only sales quotations and sales orders can be converted.
 526
 527 =head2 C<new_from $source, %params>
 528
 529 Creates a new C<SL::DB::Order> instance and copies as much
 530 information from C<$source> as possible. At the moment only records with the
 531 same destination type as the source type and sales orders from
 532 sales quotations and purchase orders from requests for quotations can be
 533 created.
 534
 535 The C<transdate> field will be set to the current date.
 536
 537 The conversion copies the order items as well.
 538
 539 Returns the new order instance. The object returned is not
 540 saved.
 541
 542 C<%params> can include the following options
 543 (C<destination_type> is mandatory):
 544
 545 =over 4
 546
 547 =item C<destination_type>
 548
 549 (mandatory)
 550 The type of the newly created object. Can be C<sales_quotation>,
 551 C<sales_order>, C<purchase_quotation> or C<purchase_order> for now.
 552
 553 =item C<items>
 554
 555 An optional array reference of RDBO instances for the items to use. If
 556 missing then the method C<items_sorted> will be called on
 557 C<$source>. This option can be used to override the sorting, to
 558 exclude certain positions or to add additional ones.
 559
 560 =item C<skip_items_negative_qty>
 561
 562 If trueish then items with a negative quantity are skipped. Items with
 563 a quantity of 0 are not affected by this option.
 564
 565 =item C<skip_items_zero_qty>
 566
 567 If trueish then items with a quantity of 0 are skipped.
 568
 569 =item C<item_filter>
 570
 571 An optional code reference that is called for each item with the item
 572 as its sole parameter. Items for which the code reference returns a
 573 falsish value will be skipped.
 574
 575 =item C<attributes>
 576
 577 An optional hash reference. If it exists then it is passed to C<new>
 578 allowing the caller to set certain attributes for the new delivery
 579 order.
 580
 581 =back
 582
 583 =head2 C<new_from_multi $sources, %params>
 584
 585 Creates a new C<SL::DB::Order> instance from multiple sources and copies as
 586 much information from C<$sources> as possible.
 587 At the moment only sales orders can be combined and they must be of the same
 588 customer.
 589
 590 The new order is created from the first one using C<new_from> and the positions
 591 of all orders are added to the new order. The orders can be sorted with the
 592 parameter C<sort_sources_by>.
 593
 594 The orders attributes are kept if they contain the same information for all
 595 source orders an will be set to empty if they contain different information.
 596
 597 Returns the new order instance. The object returned is not
 598 saved.
 599
 600 C<params> other then C<sort_sources_by> are passed to C<new_from>.
 601
 602 =head1 BUGS
 603
 604 Nothing here yet.
 605
 606 =head1 AUTHOR
 607
 608 Sven Schöling <s.schoeling@linet-services.de>
 609
 610 =cut