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