X-Git-Url: http://wagnertech.de/gitweb/gitweb.cgi/mfinanz.git/blobdiff_plain/982ea31671dc3073ee90ebf57f92578d95b70201..71eff037f1b2da6a2a2e3a392a6332648d805a6a:/SL/Helper/Inventory.pm diff --git a/SL/Helper/Inventory.pm b/SL/Helper/Inventory.pm index feb57e449..17a7d98c0 100644 --- a/SL/Helper/Inventory.pm +++ b/SL/Helper/Inventory.pm @@ -14,7 +14,7 @@ use SL::DBUtils qw(selectall_hashref_query selectrow_query); use SL::DB::TransferType; 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 { @@ -191,7 +191,6 @@ sub allocate { || $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 } @filtered_results; - my @allocations; my $rest_qty = $qty; @@ -208,19 +207,22 @@ sub allocate { bestbefore => $chunk->{bestbefore}, reserve_for_id => $chunk->{reserve_for_id}, reserve_for_table => $chunk->{reserve_for_table}, + oe_id => undef, ); $rest_qty -= $qty; } last if $rest_qty == 0; } - if ($rest_qty > 0) { die SL::X::Inventory::Allocation->new( - error => 'not enough to allocate', + error => t8('not enough to allocate'), msg => t8("can not allocate #1 units of #2, missing #3 units", $qty, $part->displayable_name, $rest_qty), ); } else { + if ($params{constraints}) { + check_constraints($params{constraints},\@allocations); + } return @allocations; } } @@ -243,13 +245,55 @@ sub allocate_for_assembly { my @allocations; for my $part_id (keys %parts_to_allocate) { - my $part = SL::DB::Part->new(id => $part_id); + my $part = SL::DB::Part->load_cached($part_id); push @allocations, allocate(%params, part => $part, qty => $parts_to_allocate{$part_id}); } @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; + die SL::X::Inventory::Allocation->new( + accessor => $accessor, + allocations => \@allocs, + error => 'allocation constraints failure', + msg => t8("Allocations didn't pass constraints for #1",$error_constraints{$_}), + ); + } + } + } +} + sub produce_assembly { my (%params) = @_; @@ -268,6 +312,7 @@ sub produce_assembly { my $bin = $params{bin} or Carp::croak("need target bin"); my $chargenumber = $params{chargenumber}; my $bestbefore = $params{bestbefore}; + my $oe_id = $params{oe_id}; my $comment = $params{comment} // ''; my $production_order_item = $params{production_order_item}; @@ -305,6 +350,7 @@ sub produce_assembly { trans_type => $trans_type_out, shippingdate => $shippingdate, employee => SL::DB::Manager::Employee->current, + oe_id => $allocation->oe_id, ); } @@ -325,6 +371,7 @@ sub produce_assembly { comment => $comment, prod => $production_order_item, employee => SL::DB::Manager::Employee->current, + oe_id => $oe_id, ); SL::DB->client->with_transaction(sub { @@ -338,7 +385,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 oe_id); my %attributes = map { $_ => 1 } @attributes; for my $name (@attributes) { @@ -420,6 +467,7 @@ SL::WH - Warehouse and Inventory API bestbefore => undef, reserve_for_id => undef, reserve_for_table => undef, + oe_id => $my_document, ); # produce_assembly: @@ -707,12 +755,56 @@ each of the following attributes to be set at creation time: =item * reserve_for_table +=item * oe_id + +Must be explicit set if the allocation needs also an (other) document. + =back -C, C, C and C may +C, C, C, C and oe_id may be C (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 is "best effort" in nature. It will take the C, +C 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. 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 C and C will throw exceptions if the request can