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

   1 package OpenILS::Application::Acq::Search;
   2 use base "OpenILS::Application";
   3
   4 use strict;
   5 use warnings;
   6
   7 use OpenSRF::AppSession;
   8 use OpenSRF::Utils::Logger qw/:logger/;
   9 use OpenILS::Event;
  10 use OpenILS::Utils::CStoreEditor q/:funcs/;
  11 use OpenILS::Utils::Fieldmapper;
  12 use OpenILS::Application::Acq::Lineitem;
  13 use OpenILS::Application::Acq::Financials;
  14 use OpenILS::Application::Acq::Picklist;
  15 use OpenILS::Application::Acq::Invoice;
  16 use OpenILS::Application::Acq::Order;
  17
  18 my %RETRIEVERS = (
  19     "lineitem" =>
  20         \&{"OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl"},
  21     "picklist" =>
  22         \&{"OpenILS::Application::Acq::Picklist::retrieve_picklist_impl"},
  23     "purchase_order" => \&{
  24         "OpenILS::Application::Acq::Financials::retrieve_purchase_order_impl"
  25     },
  26     "invoice" => \&{
  27         "OpenILS::Application::Acq::Invoice::fetch_invoice_impl"
  28     },
  29 );
  30
  31 sub F { $Fieldmapper::fieldmap->{"Fieldmapper::" . $_[0]}; }
  32
  33 # This subroutine returns 1 if the argument is a) a scalar OR
  34 # b) an array of ONLY scalars. Otherwise it returns 0.
  35 sub check_1d_max {
  36     my ($o) = @_;
  37     return 1 unless ref $o;
  38     if (ref($o) eq "ARRAY") {
  39         foreach (@$o) { return 0 if ref $_; }
  40         return 1;
  41     }
  42     0;
  43 }
  44
  45 # Returns 1 if and only if argument is an array of exactly two scalars.
  46 sub could_be_range {
  47     my ($o) = @_;
  48     if (ref $o eq "ARRAY") {
  49         return 1 if (scalar(@$o) == 2 && (!ref $o->[0] && !ref $o->[1]));
  50     }
  51     0;
  52 }
  53
  54 sub castdate {
  55     my ($value, $gte, $lte) = @_;
  56
  57     my $op = "=";
  58     $op = ">=" if $gte;
  59     $op = "<=" if $lte;
  60
  61     +{$op => {"transform" => "date", "value" => $value}};
  62 }
  63
  64 sub prepare_acqlia_search_and {
  65     my ($acqlia) = @_;
  66
  67     my @phrases = ();
  68     foreach my $unit (@{$acqlia}) {
  69         my $subquery = {
  70             "select" => {"acqlia" => ["id"]},
  71             "from" => "acqlia",
  72             "where" => {"-and" => [{"lineitem" => {"=" => {"+jub" => "id"}}}]}
  73         };
  74
  75         # castdate not supported for acqlia fields: they're all type text
  76         my ($k, $v, $fuzzy, $between, $not) = breakdown_term($unit);
  77         my $point = $subquery->{"where"}->{"-and"};
  78         my $term_clause;
  79
  80         push @$point, {"definition" => $k};
  81
  82         if ($fuzzy and not ref $v) {
  83             push @$point, {"attr_value" => {"ilike" => "%" . $v . "%"}};
  84         } elsif ($between and could_be_range($v)) {
  85             push @$point, {"attr_value" => {"between" => $v}};
  86         } elsif (check_1d_max($v)) {
  87             push @$point, {"attr_value" => $v};
  88         } else {
  89             next;
  90         }
  91
  92         my $operator = $not ? "-not-exists" : "-exists";
  93         push @phrases, {$operator => $subquery};
  94     }
  95     @phrases;
  96 }
  97
  98 sub prepare_acqlia_search_or {
  99     my ($acqlia) = @_;
 100
 101     my $point = [];
 102     my $result = {"+acqlia" => {"-or" => $point}};
 103
 104     foreach my $unit (@$acqlia) {
 105         # castdate not supported for acqlia fields: they're all type text
 106         my ($k, $v, $fuzzy, $between, $not) = breakdown_term($unit);
 107         my $term_clause;
 108         if ($fuzzy and not ref $v) {
 109             $term_clause = {
 110                 "-and" => {
 111                     "definition" => $k,
 112                     "attr_value" => {"ilike" => "%" . $v . "%"}
 113                 }
 114             };
 115         } elsif ($between and could_be_range($v)) {
 116             $term_clause = {
 117                 "-and" => {
 118                     "definition" => $k, "attr_value" => {"between" => $v}
 119                 }
 120             };
 121         } elsif (check_1d_max($v)) {
 122             $term_clause = {
 123                 "-and" => {"definition" => $k, "attr_value" => $v}
 124             };
 125         } else {
 126             next;
 127         }
 128
 129         push @$point, $not ? {"-not" => $term_clause} : $term_clause;
 130     }
 131     $result;
 132 }
 133
 134 sub breakdown_term {
 135     my ($term) = @_;
 136
 137     my $key = (grep { !/^__/ } keys %$term)[0];
 138     (
 139         $key, $term->{$key},
 140         $term->{"__fuzzy"} ? 1 : 0,
 141         $term->{"__between"} ? 1 : 0,
 142         $term->{"__not"} ? 1 : 0,
 143         $term->{"__castdate"} ? 1 : 0,
 144         $term->{"__gte"} ? 1 : 0,
 145         $term->{"__lte"} ? 1 : 0
 146     );
 147 }
 148
 149 sub get_fm_links_by_hint {
 150     my ($hint) = @_;
 151     foreach my $field (values %{$Fieldmapper::fieldmap}) {
 152         return $field->{"links"} if $field->{"hint"} eq $hint;
 153     }
 154     undef;
 155 }
 156
 157 sub gen_au_term {
 158     my ($value, $n) = @_;
 159     +{
 160         "-or" => [
 161             {"+au$n" => {"usrname" => $value}},
 162             {"+au$n" => {"first_given_name" => $value}},
 163             {"+au$n" => {"second_given_name" => $value}},
 164             {"+au$n" => {"family_name" => $value}},
 165             {"+ac$n" => {"barcode" => $value}}
 166         ]
 167     };
 168 }
 169
 170 # go through the terms hash, find keys that correspond to fields links
 171 # to actor.usr, and rewrite the search as one that searches not by
 172 # actor.usr.id but by any of these user properties: card barcode, username,
 173 # given names and family name.
 174 sub prepare_au_terms {
 175     my ($terms, $join_num) = @_;
 176
 177     my @joins = ();
 178     my $nots = 0;
 179     $join_num ||= 0;
 180
 181     foreach my $conj (qw/-and -or/) {
 182         next unless exists $terms->{$conj};
 183
 184         my @new_outer_terms = ();
 185         HINT_UNIT: foreach my $hint_unit (@{$terms->{$conj}}) {
 186             my $hint = (keys %$hint_unit)[0];
 187             (my $plain_hint = $hint) =~ y/+//d;
 188             if ($hint eq "-not") {
 189                 $hint_unit = $hint_unit->{$hint};
 190                 $nots++;
 191                 redo HINT_UNIT;
 192             }
 193
 194             if (my $links = get_fm_links_by_hint($plain_hint) and
 195                 $plain_hint ne "acqlia") {
 196                 my @new_terms = ();
 197                 my ($attr, $value) = breakdown_term($hint_unit->{$hint});
 198                 if ($links->{$attr} and
 199                     $links->{$attr}->{"class"} eq "au") {
 200                     push @joins, [$plain_hint, $attr, $join_num];
 201                     my $au_term = gen_au_term($value, $join_num);
 202                     if ($nots > 0) {
 203                         $au_term = {"-not" => $au_term};
 204                         $nots--;
 205                     }
 206                     push @new_outer_terms, $au_term;
 207                     $join_num++;
 208                     delete $hint_unit->{$hint};
 209                 }
 210             }
 211             if ($nots > 0) {
 212                 $hint_unit = {"-not" => $hint_unit};
 213                 $nots--;
 214             }
 215             push @new_outer_terms, $hint_unit if scalar keys %$hint_unit;
 216         }
 217         $terms->{$conj} = [ @new_outer_terms ];
 218     }
 219     @joins;
 220 }
 221
 222 sub prepare_terms {
 223     my ($terms, $is_and) = @_;
 224
 225     my $conj = $is_and ? "-and" : "-or";
 226     my $outer_clause = {};
 227
 228     foreach my $class (qw/acqpo acqpl acqinv jub/) {
 229         next if not exists $terms->{$class};
 230
 231         $outer_clause->{$conj} = [] unless $outer_clause->{$conj};
 232         foreach my $unit (@{$terms->{$class}}) {
 233             my ($k, $v, $fuzzy, $between, $not, $castdate, $gte, $lte) =
 234                 breakdown_term($unit);
 235
 236             my $term_clause;
 237             if ($fuzzy and not ref $v) {
 238                 $term_clause = {$k => {"ilike" => "%" . $v . "%"}};
 239             } elsif ($between and could_be_range($v)) {
 240                 $term_clause = {$k => {"between" => $v}};
 241             } elsif (check_1d_max($v)) {
 242                 $v = castdate($v, $gte, $lte) if $castdate;
 243                 $term_clause = {$k => $v};
 244             } else {
 245                 next;
 246             }
 247
 248             my $clause = {"+" . $class => $term_clause};
 249             $clause = {"-not" => $clause} if $not;
 250             push @{$outer_clause->{$conj}}, $clause;
 251         }
 252     }
 253
 254     if ($terms->{"acqlia"}) {
 255         push @{$outer_clause->{$conj}},
 256             $is_and ? prepare_acqlia_search_and($terms->{"acqlia"}) :
 257                 prepare_acqlia_search_or($terms->{"acqlia"});
 258     }
 259
 260     return undef unless scalar keys %$outer_clause;
 261     $outer_clause;
 262 }
 263
 264 sub add_au_joins {
 265     my ($from) = shift;
 266
 267     my $n = 0;
 268     foreach my $join (@_) {
 269         my ($hint, $attr, $num) = @$join;
 270         my $start;
 271         if ($hint eq "jub") {
 272             $start = $from->{$hint};
 273         } elsif ($hint eq "acqinv") {
 274             $start = $from->{"jub"}->{"acqie"}->{"join"}->{$hint};
 275         } else {
 276             $start = $from->{"jub"}->{$hint};
 277         }
 278         my $clause = {
 279             "class" => "au",
 280             "type" => "left",
 281             "field" => "id",
 282             "fkey" => $attr,
 283             "join" => {
 284                 "ac$num" => {
 285                     "class" => "ac",
 286                     "type" => "left",
 287                     "field" => "id",
 288                     "fkey" => "card"
 289                 }
 290             }
 291         };
 292         if ($hint eq "jub") {
 293             $start->{"au$num"} = $clause;
 294         } else {
 295             $start->{"join"} ||= {};
 296             $start->{"join"}->{"au$num"} = $clause;
 297         }
 298         $n++;
 299     }
 300     $n;
 301 }
 302
 303 __PACKAGE__->register_method(
 304     method    => "unified_search",
 305     api_name  => "open-ils.acq.lineitem.unified_search",
 306     stream    => 1,
 307     signature => {
 308         desc   => q/Returns lineitems based on flexible search terms./,
 309         params => [
 310             {desc => "Authentication token", type => "string"},
 311             {desc => "Field/value pairs for AND'ing", type => "object"},
 312             {desc => "Field/value pairs for OR'ing", type => "object"},
 313             {desc => "Conjunction between AND pairs and OR pairs " .
 314                 "(can be 'and' or 'or')", type => "string"},
 315             {desc => "Retrieval options (clear_marc, flesh_notes, etc) " .
 316                 "- XXX detail all the options",
 317                 type => "object"}
 318         ],
 319         return => {desc => "A stream of LIs on success, Event on failure"}
 320     }
 321 );
 322
 323 __PACKAGE__->register_method(
 324     method    => "unified_search",
 325     api_name  => "open-ils.acq.purchase_order.unified_search",
 326     stream    => 1,
 327     signature => {
 328         desc   => q/Returns purchase orders based on flexible search terms.
 329             See open-ils.acq.lineitem.unified_search/,
 330         return => {desc => "A stream of POs on success, Event on failure"}
 331     }
 332 );
 333
 334 __PACKAGE__->register_method(
 335     method    => "unified_search",
 336     api_name  => "open-ils.acq.picklist.unified_search",
 337     stream    => 1,
 338     signature => {
 339         desc   => q/Returns pick lists based on flexible search terms.
 340             See open-ils.acq.lineitem.unified_search/,
 341         return => {desc => "A stream of PLs on success, Event on failure"}
 342     }
 343 );
 344
 345 __PACKAGE__->register_method(
 346     method    => "unified_search",
 347     api_name  => "open-ils.acq.invoice.unified_search",
 348     stream    => 1,
 349     signature => {
 350         desc   => q/Returns invoices lists based on flexible search terms.
 351             See open-ils.acq.lineitem.unified_search/,
 352         return => {desc => "A stream of invoices on success, Event on failure"}
 353     }
 354 );
 355
 356 sub unified_search {
 357     my ($self, $conn, $auth, $and_terms, $or_terms, $conj, $options) = @_;
 358     $options ||= {};
 359
 360     my $e = new_editor("authtoken" => $auth);
 361     return $e->die_event unless $e->checkauth;
 362
 363     # What kind of object are we returning? Important: (\w+) had better be
 364     # a legit acq classname particle, so don't register any crazy api_names.
 365     my $ret_type = ($self->api_name =~ /cq.(\w+).un/)[0];
 366     my $retriever = $RETRIEVERS{$ret_type};
 367     my $hint = F("acq::$ret_type")->{"hint"};
 368
 369     my $select_clause = {
 370         $hint => [{"column" => "id", "transform" => "distinct"}]
 371     };
 372
 373     if ($options->{"order_by"}) {
 374         # What's the point of this block?  When using ORDER BY in conjuction
 375         # with SELECT DISTINCT, the fields present in ORDER BY have to also
 376         # be in the SELECT clause.  This will take _one_ such field and add
 377         # it to the SELECT clause as needed.
 378         my ($order_by, $class, $field);
 379         unless (
 380             ($order_by = $options->{"order_by"}->[0]) &&
 381             ($class = $order_by->{"class"}) =~ /^[\da-z_]+$/ &&
 382             ($field = $order_by->{"field"}) =~ /^[\da-z_]+$/
 383         ) {
 384             $e->disconnect;
 385             return new OpenILS::Event(
 386                 "BAD_PARAMS", "note" =>
 387 q/order_by clause must be of the long form, like:
 388 "order_by": [{"class": "foo", "field": "bar", "direction": "asc"}]/
 389             );
 390         } else {
 391             $select_clause->{$class} ||= [];
 392             push @{$select_clause->{$class}}, $field;
 393         }
 394     }
 395
 396     my $query = {
 397         "select" => $select_clause,
 398         "from" => {
 399             "jub" => {
 400                 "acqpo" => {
 401                     "type" => "full",
 402                     "field" => "id",
 403                     "fkey" => "purchase_order"
 404                 },
 405                 "acqpl" => {
 406                     "type" => "full",
 407                     "field" => "id",
 408                     "fkey" => "picklist"
 409                 },
 410                 "acqie" => {
 411                     "type" => "full",
 412                     "field" => "lineitem",
 413                     "fkey" => "id",
 414                     "join" => {
 415                         "acqinv" => {
 416                             "type" => "full",
 417                             "fkey" => "invoice",
 418                             "field" => "id"
 419                         }
 420                     }
 421                 }
 422             }
 423         },
 424         "order_by" => ($options->{"order_by"} || {$hint => {"id" => {}}}),
 425         "offset" => ($options->{"offset"} || 0)
 426     };
 427
 428     $query->{"limit"} = $options->{"limit"} if $options->{"limit"};
 429
 430     # XXX for the future? but it doesn't quite work as is.
 431 #    # Remove anything in temporary picklists from search results.
 432 #    $and_terms ||= {};
 433 #    $and_terms->{"acqpl"} ||= [];
 434 #    push @{$and_terms->{"acqpl"}}, {"name" => "", "__not" => 1};
 435
 436     $and_terms = prepare_terms($and_terms, 1);
 437     $or_terms = prepare_terms($or_terms, 0) and do {
 438         $query->{"from"}->{"jub"}->{"acqlia"} = {
 439             "type" => "left", "field" => "lineitem", "fkey" => "id",
 440         };
 441     };
 442
 443     my $offset = add_au_joins($query->{"from"}, prepare_au_terms($and_terms));
 444     add_au_joins($query->{"from"}, prepare_au_terms($or_terms, $offset));
 445
 446     if ($and_terms and $or_terms) {
 447         $query->{"where"} = {
 448             "-" . (lc $conj eq "or" ? "or" : "and") => [$and_terms, $or_terms]
 449         };
 450     } elsif ($and_terms) {
 451         $query->{"where"} = $and_terms;
 452     } elsif ($or_terms) {
 453         $query->{"where"} = $or_terms;
 454     } else {
 455         $e->disconnect;
 456         return new OpenILS::Event("BAD_PARAMS", "desc" => "No usable terms");
 457     }
 458
 459     my $results = $e->json_query($query) or return $e->die_event;
 460     my @id_list = map { $_->{"id"} } (grep { $_->{"id"} } @$results);
 461
 462     if ($options->{"id_list"}) {
 463         $conn->respond($_) foreach @id_list;
 464     } else {
 465         $conn->respond($retriever->($e, $_, $options)) foreach @id_list;
 466     }
 467
 468     $e->disconnect;
 469     undef;
 470 }
 471
 472 __PACKAGE__->register_method(
 473     method    => "bib_search",
 474     api_name  => "open-ils.acq.biblio.wrapped_search",
 475     stream    => 1,
 476     signature => {
 477         desc   => q/Returns new lineitems for each matching bib record/,
 478         params => [
 479             {desc => "Authentication token", type => "string"},
 480             {desc => "search string", type => "string"},
 481             {desc => "search options", type => "object"}
 482         ],
 483         return => {desc => "A stream of LIs on success, Event on failure"}
 484     }
 485 );
 486
 487 __PACKAGE__->register_method(
 488     method    => "bib_search",
 489     api_name  => "open-ils.acq.biblio.create_by_id",
 490     stream    => 1,
 491     signature => {
 492         desc   => q/Returns new lineitems for each matching bib record/,
 493         params => [
 494             {desc => "Authentication token", type => "string"},
 495             {desc => "list of bib IDs", type => "array"},
 496             {desc => "options (for lineitem fleshing)", type => "object"}
 497         ],
 498         return => {desc => "A stream of LIs on success, Event on failure"}
 499     }
 500 );
 501
 502 # This is very similar to zsearch() in Order.pm
 503 sub bib_search {
 504     my ($self, $conn, $auth, $search, $opts) = @_;
 505
 506     my $e = new_editor("authtoken" => $auth, "xact" => 1);
 507     return $e->die_event unless $e->checkauth;
 508     return $e->die_event unless $e->allowed("CREATE_PICKLIST");
 509
 510     my $mgr = new OpenILS::Application::Acq::BatchManager(
 511         "editor" => $e, "conn" => $conn
 512     );
 513
 514     $opts ||= {};
 515
 516     my $picklist;
 517     my @li_ids = ();
 518     if ($self->api_name =~ /create_by_id/) {
 519         $search = [ sort @$search ]; # for consitency
 520         my $bibs = $e->search_biblio_record_entry(
 521             {"id" => $search}, {"order_by" => {"bre" => ["id"]}}
 522         ) or return $e->die_event;
 523
 524         if ($opts->{"reuse_picklist"}) {
 525             $picklist = $e->retrieve_acq_picklist($opts->{"reuse_picklist"}) or
 526                 return $e->die_event;
 527             return $e->die_event unless
 528                 $e->allowed("UPDATE_PICKLIST", $picklist->org_unit);
 529
 530             # If we're reusing an existing picklist, we don't need to
 531             # create new lineitems for any bib records for which we already
 532
 533             my $already_have = $e->search_acq_lineitem({
 534                 "picklist" => $picklist->id,
 535                 "eg_bib_id" => [ map { $_->id } @$bibs ]
 536             }) or return $e->die_event;
 537
 538             # So in that case we a) save the lineitem id's of the relevant
 539             # items that already exist so that we can return those items later,
 540             # and b) remove the bib id's in question from our list of bib
 541             # id's to lineitemize.
 542             if (@$already_have) {
 543                 push @li_ids, $_->id foreach (@$already_have);
 544                 my @new_bibs = ();
 545                 foreach my $bib (@$bibs) {
 546                     push @new_bibs, $bib unless
 547                         grep { $_->eg_bib_id == $bib->id } @$already_have;
 548                 }
 549                 $bibs = [ @new_bibs ];
 550             }
 551         } else {
 552             $picklist = OpenILS::Application::Acq::Order::zsearch_build_pl($mgr, undef)
 553                 or return $e->die_event;
 554         }
 555
 556         $conn->respond($picklist->id);
 557
 558         push @li_ids, map {
 559             OpenILS::Application::Acq::Order::create_lineitem(
 560                 $mgr,
 561                 "picklist" => $picklist->id,
 562                 "source_label" => "native-evergreen-catalog",
 563                 "marc" => $_->marc,
 564                 "eg_bib_id" => $_->id
 565             )->id;
 566         } (@$bibs);
 567     } else {
 568         $opts->{"limit"} ||= 10;
 569
 570         my $ses = create OpenSRF::AppSession("open-ils.search");
 571         my $req = $ses->request(
 572             "open-ils.search.biblio.multiclass.query.staff", $opts, $search
 573         );
 574
 575         my $count = 0;
 576         while (my $resp = $req->recv("timeout" => 60)) {
 577             $picklist = OpenILS::Application::Acq::Order::zsearch_build_pl(
 578                 $mgr, undef
 579             ) unless $count++;
 580
 581             my $result = $resp->content;
 582             next if not ref $result;
 583
 584             # The result object contains a whole heck of a lot more information
 585             # than just bib IDs, so maybe we could tell the client something
 586             # useful (progress meter at least) in the future...
 587             push @li_ids, map {
 588                 my $bib = $_->[0];
 589                 OpenILS::Application::Acq::Order::create_lineitem(
 590                     $mgr,
 591                     "picklist" => $picklist->id,
 592                     "source_label" => "native-evergreen-catalog",
 593                     "marc" => $e->retrieve_biblio_record_entry($bib)->marc,
 594                     "eg_bib_id" => $bib
 595                 )->id;
 596             } (@{$result->{"ids"}});
 597         }
 598         $ses->disconnect;
 599     }
 600
 601     $e->commit;
 602
 603     $logger->info("created @li_ids new lineitems for picklist $picklist");
 604
 605     # new editor, no transaction needed this time
 606     $e = new_editor("authtoken" => $auth) or return $e->die_event;
 607     return $e->die_event unless $e->checkauth;
 608     $conn->respond($RETRIEVERS{"lineitem"}->($e, $_, $opts)) foreach @li_ids;
 609     $e->disconnect;
 610
 611     undef;
 612 }
 613
 614 1;