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