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
  14 my %RETRIEVERS = (
  15     "lineitem" =>
  16         \&{"OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl"},
  17     "picklist" =>
  18         \&{"OpenILS::Application::Acq::Picklist::retrieve_picklist_impl"},
  19     "purchase_order" => \&{
  20         "OpenILS::Application::Acq::Financials::retrieve_purchase_order_impl"
  21     }
  22 );
  23
  24 sub F { $Fieldmapper::fieldmap->{"Fieldmapper::" . $_[0]}; }
  25
  26 # This subroutine returns 1 if the argument is a) a scalar OR
  27 # b) an array of ONLY scalars. Otherwise it returns 0.
  28 sub check_1d_max {
  29     my ($o) = @_;
  30     return 1 unless ref $o;
  31     if (ref($o) eq "ARRAY") {
  32         foreach (@$o) { return 0 if ref $_; }
  33         return 1;
  34     }
  35     0;
  36 }
  37
  38 # Returns 1 if and only if argument is an array of exactly two scalars.
  39 sub could_be_range {
  40     my ($o) = @_;
  41     if (ref $o eq "ARRAY") {
  42         return 1 if (scalar(@$o) == 2 && (!ref $o->[0] && !ref $o->[1]));
  43     }
  44     0;
  45 }
  46
  47 sub castdate { +{"=" => {"transform" => "date", "value" => $_[0]}}; }
  48
  49 sub prepare_acqlia_search_and {
  50     my ($acqlia) = @_;
  51
  52     my @phrases = ();
  53     foreach my $unit (@{$acqlia}) {
  54         my $subquery = {
  55             "select" => {"acqlia" => ["id"]},
  56             "from" => "acqlia",
  57             "where" => {"-and" => [{"lineitem" => {"=" => {"+jub" => "id"}}}]}
  58         };
  59
  60         # castdate not supported for acqlia fields: they're all type text
  61         my ($k, $v, $fuzzy, $between, $not) = breakdown_term($unit);
  62         my $point = $subquery->{"where"}->{"-and"};
  63         my $term_clause;
  64
  65         push @$point, {"definition" => $k};
  66
  67         if ($fuzzy and not ref $v) {
  68             push @$point, {"attr_value" => {"ilike" => "%" . $v . "%"}};
  69         } elsif ($between and could_be_range($v)) {
  70             push @$point, {"attr_value" => {"between" => $v}};
  71         } elsif (check_1d_max($v)) {
  72             push @$point, {"attr_value" => $v};
  73         } else {
  74             next;
  75         }
  76
  77         my $operator = $not ? "-not-exists" : "-exists";
  78         push @phrases, {$operator => $subquery};
  79     }
  80     @phrases;
  81 }
  82
  83 sub prepare_acqlia_search_or {
  84     my ($acqlia) = @_;
  85
  86     my $point = [];
  87     my $result = {"+acqlia" => {"-or" => $point}};
  88
  89     foreach my $unit (@$acqlia) {
  90         # castdate not supported for acqlia fields: they're all type text
  91         my ($k, $v, $fuzzy, $between, $not) = breakdown_term($unit);
  92         my $term_clause;
  93         if ($fuzzy and not ref $v) {
  94             $term_clause = {
  95                 "-and" => {
  96                     "definition" => $k,
  97                     "attr_value" => {"ilike" => "%" . $v . "%"}
  98                 }
  99             };
 100         } elsif ($between and could_be_range($v)) {
 101             $term_clause = {
 102                 "-and" => {
 103                     "definition" => $k, "attr_value" => {"between" => $v}
 104                 }
 105             };
 106         } elsif (check_1d_max($v)) {
 107             $term_clause = {
 108                 "-and" => {"definition" => $k, "attr_value" => $v}
 109             };
 110         } else {
 111             next;
 112         }
 113
 114         push @$point, $not ? {"-not" => $term_clause} : $term_clause;
 115     }
 116     $result;
 117 }
 118
 119 sub breakdown_term {
 120     my ($term) = @_;
 121
 122     my $key = (grep { !/^__/ } keys %$term)[0];
 123     (
 124         $key, $term->{$key},
 125         $term->{"__fuzzy"} ? 1 : 0,
 126         $term->{"__between"} ? 1 : 0,
 127         $term->{"__not"} ? 1 : 0,
 128         $term->{"__castdate"} ? 1 : 0
 129     );
 130 }
 131
 132 sub get_fm_links_by_hint {
 133     my ($hint) = @_;
 134     foreach my $field (values %{$Fieldmapper::fieldmap}) {
 135         return $field->{"links"} if $field->{"hint"} eq $hint;
 136     }
 137     undef;
 138 }
 139
 140 sub gen_au_term {
 141     my ($value, $n) = @_;
 142     +{
 143         "-or" => [
 144             {"+au$n" => {"usrname" => $value}},
 145             {"+au$n" => {"first_given_name" => $value}},
 146             {"+au$n" => {"second_given_name" => $value}},
 147             {"+au$n" => {"family_name" => $value}},
 148             {"+ac$n" => {"barcode" => $value}}
 149         ]
 150     };
 151 }
 152
 153 # go through the terms hash, find keys that correspond to fields links
 154 # to actor.usr, and rewrite the search as one that searches not by
 155 # actor.usr.id but by any of these user properties: card barcode, username,
 156 # given names and family name.
 157 sub prepare_au_terms {
 158     my ($terms, $join_num) = @_;
 159
 160     my @joins = ();
 161     my $nots = 0;
 162     $join_num ||= 0;
 163
 164     foreach my $conj (qw/-and -or/) {
 165         next unless exists $terms->{$conj};
 166
 167         my @new_outer_terms = ();
 168         HINT_UNIT: foreach my $hint_unit (@{$terms->{$conj}}) {
 169             my $hint = (keys %$hint_unit)[0];
 170             (my $plain_hint = $hint) =~ y/+//d;
 171             if ($hint eq "-not") {
 172                 $hint_unit = $hint_unit->{$hint};
 173                 $nots++;
 174                 redo HINT_UNIT;
 175             }
 176
 177             if (my $links = get_fm_links_by_hint($plain_hint) and
 178                 $plain_hint ne "acqlia") {
 179                 my @new_terms = ();
 180                 my ($attr, $value) = breakdown_term($hint_unit->{$hint});
 181                 if ($links->{$attr} and
 182                     $links->{$attr}->{"class"} eq "au") {
 183                     push @joins, [$plain_hint, $attr, $join_num];
 184                     my $au_term = gen_au_term($value, $join_num);
 185                     if ($nots > 0) {
 186                         $au_term = {"-not" => $au_term};
 187                         $nots--;
 188                     }
 189                     push @new_outer_terms, $au_term;
 190                     $join_num++;
 191                     delete $hint_unit->{$hint};
 192                 }
 193             }
 194             if ($nots > 0) {
 195                 $hint_unit = {"-not" => $hint_unit};
 196                 $nots--;
 197             }
 198             push @new_outer_terms, $hint_unit if scalar keys %$hint_unit;
 199         }
 200         $terms->{$conj} = [ @new_outer_terms ];
 201     }
 202     @joins;
 203 }
 204
 205 sub prepare_terms {
 206     my ($terms, $is_and) = @_;
 207
 208     my $conj = $is_and ? "-and" : "-or";
 209     my $outer_clause = {};
 210
 211     foreach my $class (qw/acqpo acqpl jub/) {
 212         next if not exists $terms->{$class};
 213
 214         $outer_clause->{$conj} = [] unless $outer_clause->{$conj};
 215         foreach my $unit (@{$terms->{$class}}) {
 216             my ($k, $v, $fuzzy, $between, $not, $castdate) =
 217                 breakdown_term($unit);
 218
 219             my $term_clause;
 220             if ($fuzzy and not ref $v) {
 221                 $term_clause = {$k => {"ilike" => "%" . $v . "%"}};
 222             } elsif ($between and could_be_range($v)) {
 223                 $term_clause = {$k => {"between" => $v}};
 224             } elsif (check_1d_max($v)) {
 225                 $v = castdate($v) if $castdate;
 226                 $term_clause = {$k => $v};
 227             } else {
 228                 next;
 229             }
 230
 231             my $clause = {"+" . $class => $term_clause};
 232             $clause = {"-not" => $clause} if $not;
 233             push @{$outer_clause->{$conj}}, $clause;
 234         }
 235     }
 236
 237     if ($terms->{"acqlia"}) {
 238         push @{$outer_clause->{$conj}},
 239             $is_and ? prepare_acqlia_search_and($terms->{"acqlia"}) :
 240                 prepare_acqlia_search_or($terms->{"acqlia"});
 241     }
 242
 243     return undef unless scalar keys %$outer_clause;
 244     $outer_clause;
 245 }
 246
 247 sub add_au_joins {
 248     my ($from) = shift;
 249
 250     my $n = 0;
 251     foreach my $join (@_) {
 252         my ($hint, $attr, $num) = @$join;
 253         my $start = $hint eq "jub" ? $from->{$hint} : $from->{"jub"}->{$hint};
 254         my $clause = {
 255             "class" => "au",
 256             "type" => "left",
 257             "field" => "id",
 258             "fkey" => $attr,
 259             "join" => {
 260                 "ac$num" => {
 261                     "class" => "ac",
 262                     "type" => "left",
 263                     "field" => "id",
 264                     "fkey" => "card"
 265                 }
 266             }
 267         };
 268         if ($hint eq "jub") {
 269             $start->{"au$num"} = $clause;
 270         } else {
 271             $start->{"join"} ||= {};
 272             $start->{"join"}->{"au$num"} = $clause;
 273         }
 274         $n++;
 275     }
 276     $n;
 277 }
 278
 279 __PACKAGE__->register_method(
 280     method    => "unified_search",
 281     api_name  => "open-ils.acq.lineitem.unified_search",
 282     stream    => 1,
 283     signature => {
 284         desc   => q/Returns lineitems based on flexible search terms./,
 285         params => [
 286             {desc => "Authentication token", type => "string"},
 287             {desc => "Field/value pairs for AND'ing", type => "object"},
 288             {desc => "Field/value pairs for OR'ing", type => "object"},
 289             {desc => "Conjunction between AND pairs and OR pairs " .
 290                 "(can be 'and' or 'or')", type => "string"},
 291             {desc => "Retrieval options (clear_marc, flesh_notes, etc) " .
 292                 "- XXX detail all the options",
 293                 type => "object"}
 294         ],
 295         return => {desc => "A stream of LIs on success, Event on failure"}
 296     }
 297 );
 298
 299 __PACKAGE__->register_method(
 300     method    => "unified_search",
 301     api_name  => "open-ils.acq.purchase_order.unified_search",
 302     stream    => 1,
 303     signature => {
 304         desc   => q/Returns purchase orders based on flexible search terms.
 305             See open-ils.acq.lineitem.unified_search/,
 306         return => {desc => "A stream of POs on success, Event on failure"}
 307     }
 308 );
 309
 310 __PACKAGE__->register_method(
 311     method    => "unified_search",
 312     api_name  => "open-ils.acq.picklist.unified_search",
 313     stream    => 1,
 314     signature => {
 315         desc   => q/Returns pick lists based on flexible search terms.
 316             See open-ils.acq.lineitem.unified_search/,
 317         return => {desc => "A stream of PLs on success, Event on failure"}
 318     }
 319 );
 320
 321 sub unified_search {
 322     my ($self, $conn, $auth, $and_terms, $or_terms, $conj, $options) = @_;
 323     $options ||= {};
 324
 325     my $e = new_editor("authtoken" => $auth);
 326     return $e->die_event unless $e->checkauth;
 327
 328     # What kind of object are we returning? Important: (\w+) had better be
 329     # a legit acq classname particle, so don't register any crazy api_names.
 330     my $ret_type = ($self->api_name =~ /cq.(\w+).un/)[0];
 331     my $retriever = $RETRIEVERS{$ret_type};
 332     my $hint = F("acq::$ret_type")->{"hint"};
 333
 334     my $query = {
 335         "select" => {
 336             $hint =>
 337                 [{"column" => "id", "transform" => "distinct"}]
 338         },
 339         "from" => {
 340             "jub" => {
 341                 "acqpo" => {
 342                     "type" => "full",
 343                     "field" => "id",
 344                     "fkey" => "purchase_order"
 345                 },
 346                 "acqpl" => {
 347                     "type" => "full",
 348                     "field" => "id",
 349                     "fkey" => "picklist"
 350                 }
 351             }
 352         },
 353         "order_by" => { $hint => {"id" => {}}},
 354         "offset" => ($options->{"offset"} || 0)
 355     };
 356
 357     $query->{"limit"} = $options->{"limit"} if $options->{"limit"};
 358
 359     $and_terms = prepare_terms($and_terms, 1);
 360     $or_terms = prepare_terms($or_terms, 0) and do {
 361         $query->{"from"}->{"jub"}->{"acqlia"} = {
 362             "type" => "left", "field" => "lineitem", "fkey" => "id",
 363         };
 364     };
 365
 366     # TODO find instances of fields of type "timestamp" and massage the
 367     # comparison to match search input (which is only at date precision,
 368     # not timestamp).
 369     my $offset = add_au_joins($query->{"from"}, prepare_au_terms($and_terms));
 370     add_au_joins($query->{"from"}, prepare_au_terms($or_terms, $offset));
 371
 372     if ($and_terms and $or_terms) {
 373         $query->{"where"} = {
 374             "-" . (lc $conj eq "or" ? "or" : "and") => [$and_terms, $or_terms]
 375         };
 376     } elsif ($and_terms) {
 377         $query->{"where"} = $and_terms;
 378     } elsif ($or_terms) {
 379         $query->{"where"} = $or_terms;
 380     } else {
 381         $e->disconnect;
 382         return new OpenILS::Event("BAD_PARAMS", "desc" => "No usable terms");
 383     }
 384
 385     my $results = $e->json_query($query) or return $e->die_event;
 386     if ($options->{"id_list"}) {
 387         foreach (@$results) {
 388             $conn->respond($_->{"id"}) if $_->{"id"};
 389         }
 390     } else {
 391         foreach (@$results) {
 392             $conn->respond($retriever->($e, $_->{"id"}, $options))
 393                 if $_->{"id"};
 394         }
 395     }
 396     $e->disconnect;
 397     undef;
 398 }
 399
 400 1;