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