X-Git-Url: http://wagnertech.de/gitweb/gitweb.cgi/mfinanz.git/blobdiff_plain/eb0b223d2716d3fcffb9a3d806506ca4e396f4f8..155b8aa4f756d7cd34a2b26a65207cbacce40ec3:/SL/Helper/Inventory.pm

diff --git a/SL/Helper/Inventory.pm b/SL/Helper/Inventory.pm
index 5fc15ea0e..14d4d1619 100644
--- a/SL/Helper/Inventory.pm
+++ b/SL/Helper/Inventory.pm
@@ -4,17 +4,19 @@ use strict;
 use Carp;
 use DateTime;
 use Exporter qw(import);
-use List::Util qw(min);
+use List::Util qw(min sum);
 use List::UtilsBy qw(sort_by);
 use List::MoreUtils qw(any);
+use POSIX qw(ceil);
 
 use SL::Locale::String qw(t8);
 use SL::MoreCommon qw(listify);
 use SL::DBUtils qw(selectall_hashref_query selectrow_query);
 use SL::DB::TransferType;
+use SL::Helper::Number qw(_round_qty _qty);
 use SL::X;
 
-our @EXPORT_OK = qw(get_stock get_onhand allocate allocate_for_assembly produce_assembly);
+our @EXPORT_OK = qw(get_stock get_onhand allocate allocate_for_assembly produce_assembly check_constraints);
 our %EXPORT_TAGS = (ALL => \@EXPORT_OK);
 
 sub _get_stock_onhand {
@@ -187,11 +189,10 @@ sub allocate {
   # sort results so that reserve_for is first, then chargenumbers, then wanted bins, then wanted warehouses
   my @sorted_results = sort {
        (!!$b->{reserve_for_id})    <=> (!!$a->{reserve_for_id})                   # sort by existing reserve_for_id first.
-    || $chargenumbers{$b->{chargenumber}}  <=> $chargenumbers{$a->{chargenumber}} # then prefer wanted chargenumbers
-    || $bin_whitelist{$b->{bin_id}}        <=> $bin_whitelist{$a->{bin_id}}       # then prefer wanted bins
-    || $wh_whitelist{$b->{warehouse_id}}   <=> $wh_whitelist{$a->{warehouse_id}}  # then prefer wanted bins
+    || exists $chargenumbers{$b->{chargenumber}}  <=> exists $chargenumbers{$a->{chargenumber}} # then prefer wanted chargenumbers
+    || exists $bin_whitelist{$b->{bin_id}}        <=> exists $bin_whitelist{$a->{bin_id}}       # then prefer wanted bins
+    || exists $wh_whitelist{$b->{warehouse_id}}   <=> exists $wh_whitelist{$a->{warehouse_id}}  # then prefer wanted bins
   } @filtered_results;
-
   my @allocations;
   my $rest_qty = $qty;
 
@@ -208,18 +209,22 @@ sub allocate {
         bestbefore        => $chunk->{bestbefore},
         reserve_for_id    => $chunk->{reserve_for_id},
         reserve_for_table => $chunk->{reserve_for_table},
+        for_object_id     => undef,
       );
-      $rest_qty -= $qty;
+      $rest_qty -=  _round_qty($qty);
     }
-
+    $rest_qty = _round_qty($rest_qty);
     last if $rest_qty == 0;
   }
   if ($rest_qty > 0) {
     die SL::X::Inventory::Allocation->new(
-      error => t8('not enough to allocate'),
-      msg => t8("can not allocate #1 units of #2, missing #3 units", $qty, $part->displayable_name, $rest_qty),
+      error => 'not enough to allocate',
+      msg => t8("can not allocate #1 units of #2, missing #3 units", _qty($qty), $part->displayable_name, _qty($rest_qty)),
     );
   } else {
+    if ($params{constraints}) {
+      check_constraints($params{constraints},\@allocations);
+    }
     return @allocations;
   }
 }
@@ -235,8 +240,13 @@ sub allocate_for_assembly {
   my %parts_to_allocate;
 
   for my $assembly ($part->assemblies) {
+    next if $assembly->part->dispotype eq 'no_stock';
+
+    my $tmpqty = $assembly->assembly_part->is_recipe   ? $assembly->qty * $qty / $assembly->assembly_part->scalebasis
+               : $assembly->part->unit eq 'Stck' ? ceil($assembly->qty * $qty)
+               : $assembly->qty * $qty;
     $parts_to_allocate{ $assembly->part->id } //= 0;
-    $parts_to_allocate{ $assembly->part->id } += $assembly->qty * $qty; # TODO recipe factor
+    $parts_to_allocate{ $assembly->part->id } += $tmpqty;
   }
 
   my @allocations;
@@ -249,6 +259,52 @@ sub allocate_for_assembly {
   @allocations;
 }
 
+sub check_constraints {
+  my ($constraints, $allocations) = @_;
+  if ('CODE' eq ref $constraints) {
+    if (!$constraints->(@$allocations)) {
+      die SL::X::Inventory::Allocation->new(
+        error => 'allocation constraints failure',
+        msg => t8("Allocations didn't pass constraints"),
+      );
+    }
+  } else {
+    croak 'constraints needs to be a hashref' unless 'HASH' eq ref $constraints;
+
+    my %supported_constraints = (
+      bin_id       => 'bin_id',
+      warehouse_id => 'warehouse_id',
+      chargenumber => 'chargenumber',
+    );
+
+    for (keys %$constraints ) {
+      croak "unsupported constraint '$_'" unless $supported_constraints{$_};
+
+      my %whitelist = map { (ref $_ ? $_->id : $_) => 1 } listify($constraints->{$_});
+      my $accessor = $supported_constraints{$_};
+
+      if (any { !$whitelist{$_->$accessor} } @$allocations) {
+        my %error_constraints = (
+          bin_id       => t8('Bins'),
+          warehouse_id => t8('Warehouses'),
+          chargenumber => t8('Chargenumbers'),
+        );
+        my @allocs = grep { $whitelist{$_->$accessor} } @$allocations;
+        my $needed = sum map { $_->qty } grep { !$whitelist{$_->$accessor} } @$allocations;
+        my $err    = t8("Cannot allocate parts.");
+        $err      .= ' '.t8('part \'#\'1 in bin \'#2\' only with qty #3 (need additional #4) and chargenumber \'#5\'.',
+              SL::DB::Part->load_cached($_->parts_id)->description,
+              SL::DB::Bin->load_cached($_->bin_id)->full_description,
+              _qty($_->qty), _qty($needed), $_->chargenumber ? $_->chargenumber : '--') for @allocs;
+        die SL::X::Inventory::Allocation->new(
+          error => 'allocation constraints failure',
+          msg   => $err,
+        );
+      }
+    }
+  }
+}
+
 sub produce_assembly {
   my (%params) = @_;
 
@@ -267,6 +323,7 @@ sub produce_assembly {
   my $bin          = $params{bin} or Carp::croak("need target bin");
   my $chargenumber = $params{chargenumber};
   my $bestbefore   = $params{bestbefore};
+  my $for_object_id = $params{for_object_id};
   my $comment      = $params{comment} // '';
 
   my $production_order_item = $params{production_order_item};
@@ -297,6 +354,7 @@ sub produce_assembly {
 
   my @transfers;
   for my $allocation (@$allocations) {
+    my $oe_id = delete $allocation->{for_object_id};
     push @transfers, SL::DB::Inventory->new(
       trans_id     => $trans_id,
       %$allocation,
@@ -304,6 +362,7 @@ sub produce_assembly {
       trans_type   => $trans_type_out,
       shippingdate => $shippingdate,
       employee     => SL::DB::Manager::Employee->current,
+      oe_id        => $allocation->for_object_id,
     );
   }
 
@@ -324,6 +383,7 @@ sub produce_assembly {
     comment           => $comment,
     prod              => $production_order_item,
     employee          => SL::DB::Manager::Employee->current,
+    oe_id             => $for_object_id,
   );
 
   SL::DB->client->with_transaction(sub {
@@ -337,7 +397,7 @@ sub produce_assembly {
 }
 
 package SL::Helper::Inventory::Allocation {
-  my @attributes = qw(parts_id qty bin_id warehouse_id chargenumber bestbefore comment reserve_for_id reserve_for_table);
+  my @attributes = qw(parts_id qty bin_id warehouse_id chargenumber bestbefore comment reserve_for_id reserve_for_table for_object_id);
   my %attributes = map { $_ => 1 } @attributes;
 
   for my $name (@attributes) {
@@ -419,6 +479,7 @@ SL::WH - Warehouse and Inventory API
     bestbefore        => undef,
     reserve_for_id    => undef,
     reserve_for_table => undef,
+    for_object_id     => $order->id,
   );
 
   # produce_assembly:
@@ -706,11 +767,58 @@ each of the following attributes to be set at creation time:
 
 =item * reserve_for_table
 
+=item * for_object_id
+
+If set the allocations will be marked as allocated for the given object.
+If these allocations are later used to produce an assembly, the resulting
+consuming transactions will be marked as belonging to the given object.
+The object may be an order, productionorder or other objects
+
 =back
 
-C<chargenumber>, C<bestbefore>, C<reserve_for_id> and C<reserve_for_table> may
-be C<undef> (but must still be present at creation time). Instances are
-considered immutable.
+C<chargenumber>, C<bestbefore>, C<reserve_for_id>, C<reserve_for_table> and
+C<for_object_id> may be C<undef> (but must still be present at creation time).
+Instances are considered immutable.
+
+
+=head1 CONSTRAINTS
+
+  # whitelist constraints
+  ->allocate(
+    ...
+    constraints => {
+      bin_id       => \@allowed_bins,
+      chargenumber => \@allowed_chargenumbers,
+    }
+  );
+
+  # custom constraints
+  ->allocate(
+    constraints => sub {
+      # only allow chargenumbers with specific format
+      all { $_->chargenumber =~ /^ C \d{8} - \a{d2} $/x } @_
+
+      &&
+      # and must be all reservations
+      all { $_->reserve_for_id } @_;
+    }
+  )
+
+C<allocation> is "best effort" in nature. It will take the C<bin>,
+C<chargenumber> etc hints from the parameters, but will try it's bvest to
+fulfil the request anyway and only bail out if it is absolutely not possible.
+
+Sometimes you need to restrict allocations though. For this you can pass
+additional constraints to C<allocate>. A constraint serves as a whitelist.
+Every allocation must fulfil every constraint by having that attribute be one
+of the given values.
+
+In case even that is not enough, you may supply a custom check by passing a
+function that will be given the allocation objects.
+
+Note that both whitelists and constraints do not influence the order of
+allocations, which is done purely from the initial parameters. They only serve
+to reject allocations made in good faith which do fulfil required assertions.
 
 =head1 ERROR HANDLING