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