Open-ILS/src/perlmods/OpenILS/Application/Acq/Order.pm

   1 package OpenILS::Application::Acq::BatchManager;
   2 use strict; use warnings;
   3
   4 sub new {
   5     my($class, %args) = @_;
   6     my $self = bless(\%args, $class);
   7     $self->{args} = {
   8         lid => 0,
   9         li => 0,
  10         copies => 0,
  11         progress => 0,
  12         debits_accrued => 0,
  13         purchase_order => undef,
  14         picklist => undef,
  15         complete => 0
  16     };
  17     return $self;
  18 }
  19
  20 sub conn {
  21     my($self, $val) = @_;
  22     $self->{conn} = $val if $val;
  23     return $self->{conn};
  24 }
  25 sub respond {
  26     my($self, %other_args) = @_;
  27     $self->conn->respond({ %{$self->{args}}, %other_args });
  28 }
  29 sub respond_complete {
  30     my($self, %other_args) = @_;
  31     $self->complete;
  32     $self->conn->respond_complete({ %{$self->{args}}, %other_args });
  33     return undef;
  34 }
  35 sub total {
  36     my($self, $val) = @_;
  37     $self->{total} = $val if defined $val;
  38     return $self->{total};
  39 }
  40 sub purchase_order {
  41     my($self, $val) = @_;
  42     $self->{purchase_order} = $val if $val;
  43     return $self;
  44 }
  45 sub picklist {
  46     my($self, $val) = @_;
  47     $self->{picklist} = $val if $val;
  48     return $self;
  49 }
  50 sub add_lid {
  51     my $self = shift;
  52     $self->{args}->{lid} += 1;
  53     $self->{args}->{progress} += 1;
  54     return $self;
  55 }
  56 sub add_li {
  57     my $self = shift;
  58     $self->{args}->{li} += 1;
  59     $self->{args}->{progress} += 1;
  60     return $self;
  61 }
  62 sub add_copy {
  63     my $self = shift;
  64     $self->{args}->{copies} += 1;
  65     $self->{args}->{progress} += 1;
  66     return $self;
  67 }
  68 sub add_debit {
  69     my($self, $amount) = @_;
  70     $self->{args}->{debits_accrued} += $amount;
  71     $self->{args}->{progress} += 1;
  72     return $self;
  73 }
  74 sub editor {
  75     my($self, $editor) = @_;
  76     $self->{editor} = $editor if defined $editor;
  77     return $self->{editor};
  78 }
  79 sub complete {
  80     my $self = shift;
  81     $self->{args}->{complete} = 1;
  82     return $self;
  83 }
  84
  85
  86 package OpenILS::Application::Acq::Order;
  87 use base qw/OpenILS::Application/;
  88 use strict; use warnings;
  89 # ----------------------------------------------------------------------------
  90 # Break up each component of the order process and pieces into managable
  91 # actions that can be shared across different workflows
  92 # ----------------------------------------------------------------------------
  93 use OpenILS::Event;
  94 use OpenSRF::Utils::Logger qw(:logger);
  95 use OpenILS::Utils::Fieldmapper;
  96 use OpenILS::Utils::CStoreEditor q/:funcs/;
  97 use OpenILS::Const qw/:const/;
  98 use OpenILS::Application::AppUtils;
  99 use OpenILS::Application::Cat::BibCommon;
 100 use OpenILS::Application::Cat::AssetCommon;
 101 my $U = 'OpenILS::Application::AppUtils';
 102
 103
 104 # ----------------------------------------------------------------------------
 105 # Lineitem
 106 # ----------------------------------------------------------------------------
 107 sub create_lineitem {
 108     my($mgr, %args) = @_;
 109     my $li = Fieldmapper::acq::lineitem->new;
 110     $li->creator($mgr->editor->requestor->id);
 111     $li->selector($li->creator);
 112     $li->editor($li->creator);
 113     $li->create_time('now');
 114     $li->edit_time('now');
 115     $li->state('new');
 116     $li->$_($args{$_}) for keys %args;
 117     if($li->picklist) {
 118         return 0 unless update_picklist($mgr, $li->picklist);
 119     }
 120     $mgr->add_li;
 121     return $mgr->editor->create_acq_lineitem($li);
 122 }
 123
 124 sub update_lineitem {
 125     my($mgr, $li) = @_;
 126     $li->edit_time('now');
 127     $li->editor($mgr->editor->requestor->id);
 128     return $li if $mgr->editor->update_acq_lineitem($li);
 129     return undef;
 130 }
 131
 132 sub delete_lineitem {
 133     my($mgr, $li) = @_;
 134     $li = $mgr->editor->retrieve_acq_lineitem($li) unless ref $li;
 135
 136     if($li->picklist) {
 137         return 0 unless update_picklist($mgr, $li->picklist);
 138     }
 139
 140     if($li->purchase_order) {
 141         return 0 unless update_purchase_order($mgr, $li->purchase_order);
 142     }
 143
 144     # delete the attached lineitem_details
 145     my $lid_ids = $mgr->editor->search_acq_lineitem_detail({lineitem => $li->id}, {idlist=>1});
 146     for my $lid_id (@$lid_ids) {
 147         return 0 unless delete_lineitem_detail($mgr, undef, $lid_id);
 148     }
 149
 150     return $mgr->editor->delete_acq_lineitem($li);
 151 }
 152
 153 # ----------------------------------------------------------------------------
 154 # Lineitem Detail
 155 # ----------------------------------------------------------------------------
 156 sub create_lineitem_detail {
 157     my($mgr, %args) = @_;
 158     my $lid = Fieldmapper::acq::lineitem_detail->new;
 159     $lid->$_($args{$_}) for keys %args;
 160
 161     # create some default values
 162     unless($lid->barcode) {
 163         my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_barcode_prefix') || 'ACQ';
 164         $lid->barcode($pfx.$lid->id);
 165     }
 166
 167     unless($lid->cn_label) {
 168         my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_callnumber_prefix') || 'ACQ';
 169         $lid->cn_label($pfx.$lid->id);
 170     }
 171
 172     if(!$lid->location and my $loc = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.default_copy_location')) {
 173         $lid->location($loc);
 174     }
 175
 176     my $li = $mgr->editor->retrieve_acq_lineitem($lid->lineitem) or return 0;
 177     return 0 unless update_lineitem($mgr, $li);
 178     return $mgr->editor->create_acq_lineitem_detail($lid);
 179 }
 180
 181 sub delete_lineitem_detail {
 182     my($mgr, $lid) = @_;
 183     $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid) unless ref $lid;
 184     return $mgr->editor->delete_acq_lineitem_detail($lid);
 185 }
 186
 187 # ----------------------------------------------------------------------------
 188 # Picklist
 189 # ----------------------------------------------------------------------------
 190 sub create_picklist {
 191     my($mgr, %args) = @_;
 192     my $picklist = Fieldmapper::acq::picklist->new;
 193     $picklist->creator($mgr->editor->requestor->id);
 194     $picklist->owner($picklist->creator);
 195     $picklist->editor($picklist->creator);
 196     $picklist->create_time('now');
 197     $picklist->edit_time('now');
 198     $picklist->org_unit($mgr->editor->requestor->ws_ou);
 199     $picklist->owner($mgr->editor->requestor->id);
 200     $picklist->$_($args{$_}) for keys %args;
 201     $mgr->picklist($picklist);
 202     return $mgr->editor->create_acq_picklist($picklist);
 203 }
 204
 205 sub update_picklist {
 206     my($mgr, $picklist) = @_;
 207     $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
 208     $picklist->edit_time('now');
 209     $picklist->editor($mgr->editor->requestor->id);
 210     return $picklist if $mgr->editor->update_acq_picklist($picklist);
 211     return undef;
 212 }
 213
 214 sub delete_picklist {
 215     my($mgr, $picklist) = @_;
 216     $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
 217
 218     # delete all 'new' lineitems
 219     my $lis = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => 'new'});
 220     for my $li (@$lis) {
 221         return 0 unless delete_lineitem($mgr, $li);
 222     }
 223
 224     # detach all non-'new' lineitems
 225     $lis = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => {'!=' => 'new'}});
 226     for my $li (@$lis) {
 227         $li->clear_picklist;
 228         return 0 unless update_lineitem($li);
 229     }
 230
 231     # remove any picklist-specific object perms
 232     my $ops = $mgr->editor->search_permission_usr_object_perm_map({object_type => 'acqpl', object_id => "".$picklist->id});
 233     for my $op (@$ops) {
 234         return 0 unless $mgr->editor->delete_usr_object_perm_map($op);
 235     }
 236
 237     return $mgr->editor->delete_acq_picklist($picklist);
 238 }
 239
 240 # ----------------------------------------------------------------------------
 241 # Purchase Order
 242 # ----------------------------------------------------------------------------
 243 sub update_purchase_order {
 244     my($mgr, $po) = @_;
 245     $po = $mgr->editor->retrieve_acq_purchase_order($po) unless ref $po;
 246     $po->editor($mgr->editor->requestor->id);
 247     $po->edit_date('now');
 248     return $po if $mgr->editor->update_acq_purchase_order($po);
 249     return undef;
 250 }
 251
 252 sub create_purchase_order {
 253     my($mgr, %args) = @_;
 254     my $po = Fieldmapper::acq::purchase_order->new;
 255     $po->creator($mgr->editor->requestor->id);
 256     $po->editor($mgr->editor->requestor->id);
 257     $po->owner($mgr->editor->requestor->id);
 258     $po->edit_time('now');
 259     $po->create_time('now');
 260     $po->ordering_agency($mgr->editor->requestor->ws_ou);
 261     $po->$_($args{$_}) for keys %args;
 262     return $mgr->editor->create_acq_purchase_order($po);
 263 }
 264
 265
 266 # ----------------------------------------------------------------------------
 267 # Bib, Callnumber, and Copy data
 268 # ----------------------------------------------------------------------------
 269
 270 sub create_lineitem_assets {
 271     my($mgr, $li_id) = @_;
 272     my $evt;
 273
 274     my $li = $mgr->editor->retrieve_acq_lineitem([
 275         $li_id,
 276         {   flesh => 1,
 277             flesh_fields => {jub => ['purchase_order', 'attributes']}
 278         }
 279     ]) or return 0;
 280
 281     # -----------------------------------------------------------------
 282     # first, create the bib record if necessary
 283     # -----------------------------------------------------------------
 284     unless($li->eg_bib_id) {
 285         create_bib($mgr, $li) or return 0;
 286     }
 287
 288     my $li_details = $mgr->editor->search_acq_lineitem_detail({lineitem => $li_id}, {idlist=>1});
 289
 290     # -----------------------------------------------------------------
 291     # for each lineitem_detail, create the volume if necessary, create
 292     # a copy, and link them all together.
 293     # -----------------------------------------------------------------
 294     my %cache;
 295     for my $lid_id (@{$li_details}) {
 296
 297         my $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid_id) or return 0;
 298         my $org = $lid->owning_lib;
 299         my $label = $lid->cn_label;
 300
 301         $cache{$org} = {} unless $cache{$org};
 302         my $volume = $cache{$org}{$label};
 303         unless($volume) {
 304             $volume = $cache{$org}{$label} = create_volume($li, $lid) or return 0;
 305         }
 306         create_copy($mgr, $volume, $lid) or return 0;
 307     }
 308
 309     return 1;
 310 }
 311
 312 sub create_bib {
 313     my($mgr, $li) = @_;
 314
 315     my $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import(
 316         $mgr->editor, $li->marc, undef, undef, undef, 1); #$rec->bib_source
 317
 318     if($U->event_code($record)) {
 319         $mgr->editor->event($record);
 320         $mgr->editor->rollback;
 321         return 0;
 322     }
 323
 324     $li->eg_bib_id($record->id);
 325     return update_lineitem($mgr, $li);
 326 }
 327
 328 sub create_volume {
 329     my($mgr, $li, $lid) = @_;
 330
 331     my ($volume, $evt) =
 332         OpenILS::Application::Cat::AssetCommon->find_or_create_volume(
 333             $mgr->editor,
 334             $lid->cn_label,
 335             $li->eg_bib_id,
 336             $lid->owning_lib
 337         );
 338
 339     if($evt) {
 340         $mgr->editor->event($evt);
 341         return 0;
 342     }
 343
 344     return $volume;
 345 }
 346
 347 sub create_copy {
 348     my($mgr, $volume, $lid) = @_;
 349     my $copy = Fieldmapper::asset::copy->new;
 350     $copy->isnew(1);
 351     $copy->loan_duration(2);
 352     $copy->fine_level(2);
 353     $copy->status(OILS_COPY_STATUS_ON_ORDER);
 354     $copy->barcode($lid->barcode);
 355     $copy->location($lid->location);
 356     $copy->call_number($volume->id);
 357     $copy->circ_lib($volume->owning_lib);
 358     $copy->circ_modifier('book'); # XXX
 359
 360     my $evt = OpenILS::Application::Cat::AssetCommon->create_copy($mgr->editor, $volume, $copy);
 361     if($evt) {
 362         $mgr->editor->event($evt);
 363         return 0;
 364     }
 365
 366     $mgr->add_copy;
 367     $lid->eg_copy_id($copy->id);
 368     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
 369 }
 370
 371
 372
 373
 374
 375
 376 # ----------------------------------------------------------------------------
 377 # Workflow: Build a selection list from a Z39.50 search
 378 # ----------------------------------------------------------------------------
 379
 380 __PACKAGE__->register_method(
 381         method => 'zsearch',
 382         api_name => 'open-ils.acq.picklist.search.z3950',
 383     stream => 1,
 384         signature => {
 385         desc => 'Performs a z3950 federated search and creates a picklist and associated lineitems',
 386         params => [
 387             {desc => 'Authentication token', type => 'string'},
 388             {desc => 'Search definition', type => 'object'},
 389             {desc => 'Picklist name, optional', type => 'string'},
 390         ]
 391     }
 392 );
 393
 394 sub zsearch {
 395     my($self, $conn, $auth, $search, $name, $options) = @_;
 396     my $e = new_editor(authtoken=>$auth);
 397     return $e->event unless $e->checkauth;
 398     return $e->event unless $e->allowed('CREATE_PICKLIST');
 399
 400     $search->{limit} ||= 10;
 401     $options ||= {};
 402
 403     my $ses = OpenSRF::AppSession->create('open-ils.search');
 404     my $req = $ses->request('open-ils.search.z3950.search_class', $auth, $search);
 405
 406     my $first = 1;
 407     my $picklist;
 408     my $mgr;
 409     while(my $resp = $req->recv(timeout=>60)) {
 410
 411         if($first) {
 412             my $e = new_editor(requestor=>$e->requestor, xact=>1);
 413             $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
 414             $picklist = zsearch_build_pl($mgr, $name);
 415             $first = 0;
 416         }
 417
 418         my $result = $resp->content;
 419         my $count = $result->{count};
 420         $mgr->total( (($count < $search->{limit}) ? $count : $search->{limit})+1 );
 421
 422         for my $rec (@{$result->{records}}) {
 423
 424             my $li = create_lineitem($mgr,
 425                 picklist => $picklist->id,
 426                 source_label => $result->{service},
 427                 marc => $rec->{marcxml},
 428                 eg_bib_id => $rec->{bibid}
 429             );
 430
 431             if($$options{respond_li}) {
 432                 $li->attributes($mgr->editor->search_acq_lineitem_attr({lineitem => $li->id}))
 433                     if $$options{flesh_attrs};
 434                 $li->clear_marc if $$options{clear_marc};
 435                 $mgr->respond(lineitem => $li);
 436             } else {
 437                 $mgr->respond;
 438             }
 439         }
 440     }
 441
 442     $mgr->editor->commit;
 443     return $mgr->respond_complete;
 444 }
 445
 446 sub zsearch_build_pl {
 447     my($mgr, $name) = @_;
 448     $name ||= '';
 449
 450     my $picklist = $mgr->editor->search_acq_picklist({
 451         owner => $mgr->editor->requestor->id,
 452         name => $name
 453     })->[0];
 454
 455     if($name eq '' and $picklist) {
 456         return 0 unless delete_picklist($mgr, $picklist);
 457         $picklist = undef;
 458     }
 459
 460     return update_picklist($mgr, $picklist) if $picklist;
 461     return create_picklist($mgr, name => $name);
 462 }
 463
 464
 465 # ----------------------------------------------------------------------------
 466 # Workflow: Build a selection list / PO by importing a batch of MARC records
 467 # ----------------------------------------------------------------------------
 468
 469 __PACKAGE__->register_method(
 470     method => 'upload_records',
 471     api_name => 'open-ils.acq.process_upload_records',
 472     stream => 1,
 473 );
 474
 475 my %fund_code_map;
 476 sub upload_records {
 477     my($self, $conn, $auth, $key) = @_;
 478
 479         my $e = new_editor(authtoken => $auth, xact => 1);
 480     return $e->die_event unless $e->checkauth;
 481     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
 482
 483     my $cache = OpenSRF::Utils::Cache->new;
 484     my $evt;
 485
 486     my $data = $cache->get_cache("vandelay_import_spool_$key");
 487         my $purpose = $data->{purpose};
 488     my $filename = $data->{path};
 489     my $provider = $data->{provider};
 490     my $picklist = $data->{picklist};
 491     my $create_po = $data->{create_po};
 492     my $ordering_agency = $data->{ordering_agency};
 493     my $purchase_order;
 494
 495     unless(-r $filename) {
 496         $logger->error("unable to read MARC file $filename");
 497         $e->rollback;
 498         return OpenILS::Event->new('FILE_UPLOAD_ERROR', payload => {filename => $filename});
 499     }
 500
 501     $provider = $e->retrieve_acq_provider($provider) or return $e->die_event;
 502
 503     if($picklist) {
 504         $picklist = $e->retrieve_acq_picklist($picklist) or return $e->die_event;
 505         if($picklist->owner != $e->requestor->id) {
 506             return $e->die_event unless
 507                 $e->allowed('CREATE_PICKLIST', $picklist->org_unit, $picklist);
 508         }
 509     }
 510
 511     if($create_po) {
 512         $purchase_order = Fieldmapper::acq::purchase_order->new;
 513         $purchase_order->provider($provider->id);
 514         $purchase_order->ordering_agency($ordering_agency);
 515         $evt = OpenILS::Application::Acq::Financials::create_purchase_order_impl($e, $purchase_order);
 516         return $evt if $evt;
 517     }
 518
 519     $logger->info("acq processing MARC file=$filename");
 520
 521     my $marctype = 'USMARC'; # ?
 522         my $batch = new MARC::Batch ($marctype, $filename);
 523         $batch->strict_off;
 524
 525         my $count = 0;
 526
 527         while(1) {
 528
 529             my $r;
 530                 $logger->info("processing record $count");
 531
 532         try {
 533             $r = $batch->next
 534         } catch Error with { $r = -1; };
 535
 536         last unless $r;
 537
 538         if($r == -1) {
 539                         $logger->warn("Proccessing of record $count in set $key failed.  Skipping this record");
 540                         $count++;
 541             next;
 542                 }
 543
 544                 try {
 545
 546                         (my $xml = $r->as_xml_record()) =~ s/\n//sog;
 547                         $xml =~ s/^<\?xml.+\?\s*>//go;
 548                         $xml =~ s/>\s+</></go;
 549                         $xml =~ s/\p{Cc}//go;
 550                         $xml = $U->entityize($xml);
 551                         $xml =~ s/[\x00-\x1f]//go;
 552
 553             my $li = Fieldmapper::acq::lineitem->new;
 554             $li->picklist($picklist->id) if $picklist;
 555             $li->purchase_order($purchase_order->id) if $purchase_order;
 556             $li->source_label($provider->code); # XXX ??
 557             $li->provider($provider->id);
 558             $li->selector($e->requestor->id);
 559             $li->creator($e->requestor->id);
 560             $li->editor($e->requestor->id);
 561             $li->edit_time('now');
 562             $li->create_time('now');
 563             $li->marc($xml);
 564             $li->state('on-order') if $purchase_order;
 565             $e->create_acq_lineitem($li) or die $e->die_event;
 566
 567                         $conn->respond({count => $count}) if (++$count % 5) == 0;
 568
 569             $evt = create_lineitem_details($conn, \$count, $e, $ordering_agency, $li, $purchase_order);
 570             die $evt if $evt; # caught below
 571
 572                 } catch Error with {
 573                         my $error = shift;
 574                         $logger->warn("Encountered a bad record at Vandelay ingest: ".$error);
 575                 }
 576         }
 577
 578         $e->commit;
 579     unlink($filename);
 580     $cache->delete_cache('vandelay_import_spool_' . $key);
 581
 582     # clear the cached funds
 583     delete $fund_code_map{$_} for keys %fund_code_map;
 584
 585         return {
 586         complete => 1,
 587         purchase_order => $purchase_order,
 588         picklist => $picklist
 589     };
 590 }
 591
 592 sub create_lineitem_details {
 593     my($conn, $countref, $e, $ordering_agency, $li, $purchase_order) = @_;
 594
 595     my $holdings = $e->json_query({from => ['acq.extract_provider_holding_data', $li->id]});
 596     return undef unless @$holdings;
 597     my $org_path = $U->get_org_ancestors($ordering_agency);
 598
 599     my $idx = 1;
 600     while(1) {
 601         my $compiled = extract_lineitem_detail_data($e, $org_path, $holdings, $idx);
 602         last unless $compiled;
 603
 604         for(1..$$compiled{quantity}) {
 605             my $lid = Fieldmapper::acq::lineitem_detail->new;
 606             $lid->lineitem($li->id);
 607             $lid->owning_lib($$compiled{owning_lib});
 608             $lid->cn_label($$compiled{call_number});
 609             $lid->fund($$compiled{fund});
 610
 611             if($purchase_order) {
 612             }
 613
 614         }
 615
 616         $idx++;
 617     }
 618     return undef;
 619 }
 620
 621 sub extract_lineitem_detail_data {
 622     my($e, $org_path, $holdings, $holding_index) = @_;
 623
 624     my @data_list = { grep { $_->holding eq $holding_index } @$holdings };
 625     my %compiled = map { $_->{attr} => $_->{data} } @data_list;
 626     my $err_evt = OpenILS::Event->new('ACQ_IMPORT_ERROR');
 627
 628     $compiled{quantity} ||= 1;
 629
 630     # ----------------------------------------------------
 631     # find the fund
 632     if(my $code = $compiled{fund_code}) {
 633
 634         my $fund = $fund_code_map{$code};
 635         unless($fund) {
 636             # search up the org tree for the most appropriate fund
 637             for my $org (@$org_path) {
 638                 $fund = $e->search_acq_fund({org => $org, code => $code, year => DateTime->now->year})->[0];
 639                 last if $fund;
 640             }
 641             unless($fund) {
 642                 $logger->error("Import error: there is no fund with code $code at orgs $org_path");
 643                 $e->rollback;
 644                 return $err_evt;
 645             }
 646         }
 647         $compiled{fund} = $fund->id;
 648         $fund_code_map{$code} = $fund;
 649
 650     } else {
 651         # XXX perhaps a default fund?
 652         $logger->error("Import error: no fund code provided");
 653         $e->rollback;
 654         return $err_evt;
 655     }
 656
 657     $compiled{owning_lib} = $e->search_actor_org_unit({shortname => $compiled{owning_lib}})->[0]
 658         or return $e->die_event;
 659
 660     # ----------------------------------------------------
 661     # find the collection code
 662
 663     return \%compiled;
 664 }
 665
 666
 667 1;