Open-ILS/src/perlmods/lib/OpenILS/Application/Acq/Lineitem/BatchUpdate.pm

   1 package OpenILS::Application::Acq::Lineitem::BatchUpdate;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/OpenILS::Application/;
   7
   8 # All of the packages we might 'use' are already imported in
   9 # OpenILS::Application::Acq::Lineitem.  Only those that export symbols
  10 # need to be mentioned explicitly here.
  11
  12 use List::Util qw/reduce/;
  13 use OpenSRF::Utils::Logger qw/:logger/;
  14 use OpenILS::Utils::CStoreEditor q/:funcs/;
  15
  16 my $U = "OpenILS::Application::AppUtils";
  17
  18
  19 # lineitem_batch_update_perm_test(), helper for lineitem_batch_update_api()
  20 #
  21 # Tests permissions on targeted lineitems, purchase orders, and picklists.
  22 # Returns undef on success, event on perm failure.
  23 # Responsible for calling $e->die_event.
  24 # Also sanitizes values in $target.
  25 #
  26 sub lineitem_batch_update_perm_test {
  27     my ($e, $target) = @_;
  28
  29     return $e->die_event(new OpenILS::Event("BAD_PARAMS", note => "target"))
  30         unless ref $target eq "HASH";
  31
  32     my $perm_for = {
  33         ordering_agency => "CREATE_PURCHASE_ORDER",
  34         org_unit => "UPDATE_PICKLIST"
  35     };
  36
  37     if (ref $target->{lineitems} eq "ARRAY") {
  38         # Sanitization
  39         $target->{lineitems} = [ map { int $_ } @{$target->{lineitems}} ];
  40
  41         return $e->die_event(
  42             new OpenILS::Event(
  43                 "BAD_PARAMS", note => "target (lineitems list empty)"
  44             )
  45         ) unless @{$target->{lineitems}};
  46
  47         # Get all PO & picklist linkings from lineitems in question.
  48         my $li_rows = $e->json_query({
  49             select => {
  50                 jub => ["id"],
  51                 acqpo => ["ordering_agency"],
  52                 acqpl => ["org_unit"]
  53             },
  54             from => {
  55                 jub => {acqpl => {type => "left"}, acqpo => {type => "left"}}
  56             },
  57             where => {
  58                 "+jub" => {id => $target->{lineitems}}
  59             }
  60         }) or return $e->die_event;
  61
  62         # Fail loudly rather than giving user any surprises if they asked to
  63         # update lineitems that don't exist.  This is an asymmetric difference
  64         # calculation.
  65         my %present = map { $_->{id} => 1 } @$li_rows;
  66         my @missing = grep { not exists $present{$_} } @{$target->{lineitems}};
  67         return $e->die_event(
  68             new OpenILS::Event("ACQ_LINEITEM_NOT_FOUND", payload => \@missing)
  69         ) if @missing;
  70
  71         # To avoid repetition of perm tests, track them here.
  72         my $already_done = {
  73             ordering_agency => {},
  74             org_unit => {}
  75         };
  76
  77         # Test all lineitems based on the context OU of all linked POs AND PLs.
  78         foreach my $row (@$li_rows) {
  79             foreach my $field (keys %$already_done) {
  80                 if ($row->{$field}) {
  81                     if (not $already_done->{$row}{$field}) {
  82                         my $perm = $perm_for->{$field};
  83                         my $context = $row->{$field};
  84
  85                         if (not $e->allowed($perm, $context)) {
  86                             my $evt = $e->die_event;
  87
  88                             # Take the PERM_FAILURE event and annotate it with
  89                             # a list of the targeted lineitems that would fail
  90                             # the same permission check (i.e. that have the
  91                             # same context).
  92                             $evt->{payload} = [
  93                                 map { $_->{id} } (
  94                                     grep { $_->{$field} == $context } @$li_rows
  95                                 )
  96                             ];
  97                             return $evt;
  98                         } else {
  99                             $already_done->{$row}{$field} = 1;
 100                         }
 101                     }
 102                 }
 103             }
 104         }
 105     } elsif ($target->{purchase_order}) {
 106         $target->{purchase_order} = int($target->{purchase_order});
 107
 108         my $po = $e->retrieve_acq_purchase_order($target->{purchase_order}) or
 109             return $e->die_event;
 110
 111         return $e->die_event unless
 112             $e->allowed($perm_for->{ordering_agency}, $po->ordering_agency);
 113     } elsif ($target->{picklist}) {
 114         $target->{picklist} = int($target->{picklist});
 115
 116         my $pl = $e->retrieve_acq_picklist($target->{picklist}) or
 117             return $e->die_event;
 118
 119         return $e->die_event unless
 120             $e->allowed($perm_for->{org_unit}, $pl->org_unit);
 121     } else {
 122         return $e->die_event(
 123             new OpenILS::Event("BAD_PARAMS", note => "target")
 124         );
 125     }
 126
 127     return; # perm check pass
 128 }
 129
 130
 131 # $changes->{item_count} wins over distribution formula if both are present.
 132 # It's also ok for neither to be present.
 133 sub pick_winning_item_count {
 134     my ($changes, $dist_formula) = @_;
 135
 136     if (exists $changes->{item_count}) {
 137         return $changes->{item_count};
 138     } elsif ($dist_formula) {
 139         return reduce { $a + $b->item_count } 0, @{$dist_formula->entries};
 140     }
 141
 142     return;
 143 }
 144
 145
 146 # pick_winning_change() should be called in list context, so the caller can
 147 # distinguish between empty result (no change at all) and undef result (clear
 148 # field).
 149 sub pick_winning_change {
 150     my ($changes, $dist_formula, $field, $position) = @_;
 151
 152     if (exists $changes->{$field}) {
 153         # Remember: in $changes, not exists means no change, while undef
 154         # means clear.
 155
 156         return $changes->{$field} if $position >= $changes->{position};
 157     }
 158
 159     if ($dist_formula) {
 160         my $hit;
 161
 162         my $count_over_entries = 0;
 163         foreach my $entry (@{$dist_formula->entries}) {
 164             $count_over_entries += $entry->item_count;
 165
 166             if ($count_over_entries > $position) {
 167                 # Abuse this virtual field on the distribution formula
 168                 # to let the caller know we actually used it.
 169
 170                 $dist_formula->use_count(($dist_formula->use_count || 0) + 1);
 171                 $hit = $entry->$field;
 172                 last;
 173             }
 174         }
 175
 176         # The database doesn't give us a way to distinguish between "not exists"
 177         # and undef like a hash does, so for dist formulas, undef (null) has
 178         # to mean no change, and so if we come up with nothing defined, we
 179         # don't return anything, not even the undef, since that would be
 180         # misunderstood by the caller.
 181         return $hit if defined $hit;
 182     }
 183
 184     return; # return nothing, not even undef (in list context, anyway)
 185 }
 186
 187
 188 # adjust_lineitem_copy_counts() directly changes contents of @$lineitems
 189 sub adjust_lineitem_copy_counts {
 190     my ($lineitems, $item_count) = @_;
 191
 192     # Count how many lineitem details we have per lineitem, and for
 193     # each lineitem add or remove lineitems to match $item_count, as needed.
 194
 195     my %counts;
 196
 197     foreach my $jub (@$lineitems) {
 198         $counts{$jub->id} = scalar @{$jub->lineitem_details};
 199
 200         if ($counts{$jub->id} > $item_count) {
 201             # Take care of excess lineitem details.
 202
 203             for (my $i = $item_count; $i < $counts{$jub->id}; $i++) {
 204                 $jub->lineitem_details->[$i]->isdeleted(1);
 205             }
 206         } elsif ($counts{$jub->id} < $item_count) {
 207             # Add missing lineitem details.
 208
 209             for (my $i = $counts{$jub->id}; $i < $item_count; $i++) {
 210                 my $lid = new Fieldmapper::acq::lineitem_detail;
 211                 $lid->isnew(1);
 212                 $lid->lineitem($jub->id);
 213
 214                 push @{$jub->lineitem_details}, $lid;
 215             }
 216         }
 217     }
 218 }
 219
 220
 221 # lineitem_batch_update_impl() should be handed everything pre-perm-checked
 222 # and ready-to-go. $e is in a transaction.
 223 sub lineitem_batch_update_impl {
 224     my ($conn, $e, $dry_run, $target, $changes, $dist_formula) = @_;
 225
 226     # Keep client's attention.
 227     $conn->status(new OpenSRF::DomainObject::oilsContinueStatus);
 228
 229     # First, retrieve existing lineitems with lineitem details.  We could do
 230     # with the lineitem details only if not for having to catch lineitems
 231     # with zero current lineitem details, so that we can augment those if
 232     # requested by the user via $changes->{item_count}.
 233
 234     # The right ordering is important for adjusting lineitem detail counts.
 235     my %order_by = (order_by => [
 236         {class => "jub", field => "id"},
 237         {class => "acqlid", field => "id"}
 238     ]);
 239
 240     # XXX The following could be refactored only to retrieve one lineitem at a
 241     # time, since the list of fleshed lineitem_details could conceivably be
 242     # very long for each one. We'd then update each lineitem_detail on that
 243     # lineitem before proceeding to the next.
 244
 245     my $lineitems;
 246
 247     if ($target->{lineitems}) {
 248         $lineitems = $e->search_acq_lineitem(
 249             [
 250                 {id => $target->{lineitems}},
 251                 {flesh => 1,
 252                     flesh_fields => {"jub" => ["lineitem_details"]}, %order_by}
 253             ], {substream => 1}
 254         ) or return $e->die_event;
 255     } else {
 256         my $where;
 257
 258         if ($target->{purchase_order}) {
 259             $where = {purchase_order => $target->{purchase_order}};
 260         } else {
 261             $where = {picklist => $target->{picklist}};
 262         }
 263
 264         $lineitems = $e->search_acq_lineitem(
 265             [
 266                 $where,
 267                 {flesh => 1,
 268                     flesh_fields => {"jub" => ["lineitem_details"]}, %order_by}
 269             ], {substream => 1}
 270         ) or return $e->die_event;
 271     }
 272
 273     $conn->status(new OpenSRF::DomainObject::oilsContinueStatus);
 274     $logger->info(
 275         "lineitem_batch_update_impl() working with " .
 276         scalar(@$lineitems) . " lineitems"
 277     );
 278
 279     my $item_count = pick_winning_item_count($changes, $dist_formula);
 280     adjust_lineitem_copy_counts($lineitems, $item_count) if defined $item_count;
 281
 282     # Now, going through all our lineitem details, make the updates
 283     # called for in $changes, other than the 'item_count' field (handled above).
 284
 285     my %fund_cache;
 286     my @fields = qw/owning_lib fund location collection_code circ_modifier/;
 287     foreach my $jub (@$lineitems) {
 288         # We use the counting style of loop below because we need to know our
 289         # position for dist_formula application.
 290
 291         my $starting_use_count =
 292             $dist_formula ? $dist_formula->use_count : undef;
 293
 294         for (my $i = 0; $i < scalar @{$jub->lineitem_details}; $i++) {
 295             my $lid = $jub->lineitem_details->[$i];
 296
 297             # Handle copies needing a delete.
 298             if ($lid->isdeleted) {
 299                 $e->delete_acq_lineitem_detail($lid) or return $e->die_event;
 300                 next;
 301             }
 302
 303             # Handle existing and new copies.
 304             my $fund_changed = 0;
 305             foreach my $field (@fields) {
 306                 # Calling pick_winning_change() in list context gets us an
 307                 # empty list for "no change to make", (undef) for "clear the
 308                 # field", and ($value) for "set the field to $value".
 309
 310                 my @change =
 311                     pick_winning_change($changes, $dist_formula, $field, $i);
 312
 313                 if (scalar @change) {
 314                     my $change = pop @change;
 315
 316                     if (not defined $change) {
 317                         my $meth = "clear_$field";
 318                         $lid->$meth;
 319                     } else {
 320
 321                         $fund_changed = 1 if
 322                             !$lid->isnew and
 323                             $field eq 'fund' and
 324                             $lid->$field ne $change;
 325
 326                         $lid->$field($change);
 327                     }
 328                 }
 329             }
 330
 331             my $method = ($lid->isnew ? "create" : "update") .
 332                 "_acq_lineitem_detail";
 333
 334             if ($fund_changed) {
 335                 # handle_changed_lid updates any existing fund debits
 336                 # linked to the LID to use the new fund.  If the fund
 337                 # balance reaches a stop/warn percent (or error),
 338                 # processing exits early and returns an event.
 339                 my $evt =
 340                     OpenILS::Application::Acq::Order::handle_changed_lid(
 341                         $e, $lid, 0, \%fund_cache);
 342                 return $evt if $evt;
 343             } else {
 344                 $e->$method($lid) or return $e->die_event;
 345             }
 346         }
 347
 348         if (defined $starting_use_count and
 349             $dist_formula->use_count > $starting_use_count) {
 350
 351             # Record the application of the distribution formula.
 352             my $dfa = new Fieldmapper::acq::distribution_formula_application;
 353
 354             $dfa->lineitem($jub->id);
 355             $dfa->formula($dist_formula->id);
 356             $dfa->creator($e->requestor->id);
 357
 358             $e->create_acq_distribution_formula_application($dfa) or
 359                 return $e->die_event;
 360         }
 361
 362         $conn->respond($jub->id);
 363     }
 364
 365     # Explicit bare return statements below avoid sending extra data to client.
 366     if ($dry_run) {
 367         $e->rollback;
 368         return;
 369     } else {
 370         $e->commit or return $e->die_event;
 371         return;
 372     }
 373 }
 374
 375
 376 __PACKAGE__->register_method(
 377     method => "lineitem_batch_update_api",
 378     api_name => "open-ils.acq.lineitem.batch_update",
 379     signature => {
 380         desc => "Apply changes to the lineitem details realted to specified lineitems in batch",
 381         params => [
 382             {desc => "Authentication token", type => "string"},
 383             {desc => "Target. Object key must be one of lineitems, purchase_order or picklist.  The value for 'lineitems' must be an array of IDs, and the values for either of the other two must be single IDs.", type => "object"},
 384             {desc => "Changes (optional).  If these changes conflict with distribution formula, these changes win.", type => "object"},
 385             {desc => "Distribution formula ID (optional). Note that a distribution formula's 'skip_count' field does nothing, but the 'position' and 'item_count' fields of distribution formula *entries* do what they ought to. ", type => "number"}
 386         ],
 387         return => {
 388             desc => q/A stream of lineitem IDs affected upon success.  Events
 389                 on failure.  ANY events in the results, even after any number
 390                 of lineitem IDs, should be interpreted by the client to mean
 391                 that a rollback has happened and nothing has changed./,
 392             type => "mixed"
 393         }
 394     }
 395 );
 396
 397 __PACKAGE__->register_method(
 398     method => "lineitem_batch_update_api",
 399     api_name => "open-ils.acq.lineitem.batch_update.dry_run",
 400     signature => {
 401         desc => "Impotent version of open-ils.acq.lineitem.batch_update that always ends in a rollback",
 402         params => "See open-ils.acq.lineitem.batch_update",
 403         return => "See open-ils.acq.lineitem.batch_update"
 404     }
 405 );
 406
 407 sub lineitem_batch_update_api {
 408     my ($self, $conn, $auth, $target, $changes, $dist_formula) = @_;
 409
 410     # Make sure that $changes->{item_count}, if it exists, is a natural number.
 411     # Other things in $change are safe to treat somewhat more casually,
 412     # except fund, which is handled later.
 413     $changes ||= {};
 414     if (exists $changes->{item_count}) {
 415         $changes->{item_count} = int($changes->{item_count});
 416         return new OpenILS::Event("BAD_PARAMS", note => "changes (item_count)")
 417             unless $changes->{item_count} >= 0;
 418     }
 419
 420     # We want to do our perm tests and everything within a transaction.
 421     my $e = new_editor(authtoken => $auth, xact => 1);
 422     return $e->die_event unless $e->checkauth;
 423
 424     # If any distribution formula ID is given, fetch distribution formula
 425     # (with entries fleshed) early so we can get a quick permission check
 426     # out of the way.
 427     if ($dist_formula) {
 428
 429         # It's important that we NOT flesh use_count here, if that [ever]
 430         # does anything.  We're going to abuse that field internally.
 431
 432         $dist_formula = $e->retrieve_acq_distribution_formula([
 433             int($dist_formula), {
 434                 flesh=>2,
 435                 flesh_fields=>{
 436                     acqdf => ["entries"],
 437                     acqdfe => ["fund"]
 438                 }
 439             }
 440         ]) or return $e->die_event;
 441
 442         return $e->die_event unless
 443             $e->allowed("ADMIN_ACQ_DISTRIB_FORMULA", $dist_formula->owner);
 444
 445         # If the distribution formula has a fund, there's an additional perm
 446         # test to do before proceeding.
 447         for my $entry (@{$dist_formula->entries}) {
 448             if ($entry->fund) {
 449                 return $e->die_event unless $e->allowed(
 450                     ["ADMIN_FUND", "MANAGE_FUND"],
 451                     $entry->fund->org, $entry->fund
 452                 );
 453             }
 454         }
 455
 456         # The following sort is crucial later.
 457         $dist_formula->entries([
 458             sort { $a->position cmp $b->position } @{$dist_formula->entries}
 459         ]);
 460     }
 461
 462     # Next, test permissions on fund to set, if any, from $changes.
 463     if ($changes->{fund}) {
 464         my $fund = $e->retrieve_acq_fund($changes->{fund}) or
 465             return $e->die_event;
 466
 467         return $e->die_event unless
 468             $e->allowed(["ADMIN_FUND", "MANAGE_FUND"], $fund->org, $fund);
 469     }
 470
 471     # Now test permissions on the targets.  lineitem_batch_update_perm_test()
 472     # calls die_event() for us if needed.  Has side-effect of target
 473     # sanitization.
 474     my $evt = lineitem_batch_update_perm_test($e, $target);
 475     return $evt if $U->event_code($evt);
 476
 477     # Finally do the actual work.
 478     return lineitem_batch_update_impl(
 479         $conn, $e, scalar($self->api_name =~ /dry_run/),
 480         $target, $changes, $dist_formula
 481     );
 482 }
 483
 484 1;