Need to die if we fail to find a picklist, symmetric to the top of the conditional.
[working/Evergreen.git] / 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;