Open-ILS/src/perlmods/lib/OpenILS/Application/Storage/QueryParser.pm

   1 use strict;
   2 use warnings;
   3
   4 package QueryParser;
   5 use OpenSRF::Utils::JSON;
   6 our %parser_config = (
   7     QueryParser => {
   8         filters => [],
   9         modifiers => [],
  10         operators => {
  11             'and' => '&&',
  12             'or' => '||',
  13             group_start => '(',
  14             group_end => ')',
  15             required => '+',
  16             disallowed => '-',
  17             modifier => '#'
  18         }
  19     }
  20 );
  21
  22 sub facet_class_count {
  23     my $self = shift;
  24     return @{$self->facet_classes};
  25 }
  26
  27 sub search_class_count {
  28     my $self = shift;
  29     return @{$self->search_classes};
  30 }
  31
  32 sub filter_count {
  33     my $self = shift;
  34     return @{$self->filters};
  35 }
  36
  37 sub modifier_count {
  38     my $self = shift;
  39     return @{$self->modifiers};
  40 }
  41
  42 sub custom_data {
  43     my $class = shift;
  44     $class = ref($class) || $class;
  45
  46     $parser_config{$class}{custom_data} ||= {};
  47     return $parser_config{$class}{custom_data};
  48 }
  49
  50 sub operators {
  51     my $class = shift;
  52     $class = ref($class) || $class;
  53
  54     $parser_config{$class}{operators} ||= {};
  55     return $parser_config{$class}{operators};
  56 }
  57
  58 sub filters {
  59     my $class = shift;
  60     $class = ref($class) || $class;
  61
  62     $parser_config{$class}{filters} ||= [];
  63     return $parser_config{$class}{filters};
  64 }
  65
  66 sub modifiers {
  67     my $class = shift;
  68     $class = ref($class) || $class;
  69
  70     $parser_config{$class}{modifiers} ||= [];
  71     return $parser_config{$class}{modifiers};
  72 }
  73
  74 sub new {
  75     my $class = shift;
  76     $class = ref($class) || $class;
  77
  78     my %opts = @_;
  79
  80     my $self = bless {} => $class;
  81
  82     for my $o (keys %{QueryParser->operators}) {
  83         $class->operator($o => QueryParser->operator($o)) unless ($class->operator($o));
  84     }
  85
  86     for my $opt ( keys %opts) {
  87         $self->$opt( $opts{$opt} ) if ($self->can($opt));
  88     }
  89
  90     return $self;
  91 }
  92
  93 sub new_plan {
  94     my $self = shift;
  95     my $pkg = ref($self) || $self;
  96     return do{$pkg.'::query_plan'}->new( QueryParser => $self, @_ );
  97 }
  98
  99 sub add_search_filter {
 100     my $pkg = shift;
 101     $pkg = ref($pkg) || $pkg;
 102     my $filter = shift;
 103
 104     return $filter if (grep { $_ eq $filter } @{$pkg->filters});
 105     push @{$pkg->filters}, $filter;
 106     return $filter;
 107 }
 108
 109 sub add_search_modifier {
 110     my $pkg = shift;
 111     $pkg = ref($pkg) || $pkg;
 112     my $modifier = shift;
 113
 114     return $modifier if (grep { $_ eq $modifier } @{$pkg->modifiers});
 115     push @{$pkg->modifiers}, $modifier;
 116     return $modifier;
 117 }
 118
 119 sub add_facet_class {
 120     my $pkg = shift;
 121     $pkg = ref($pkg) || $pkg;
 122     my $class = shift;
 123
 124     return $class if (grep { $_ eq $class } @{$pkg->facet_classes});
 125
 126     push @{$pkg->facet_classes}, $class;
 127     $pkg->facet_fields->{$class} = [];
 128
 129     return $class;
 130 }
 131
 132 sub add_search_class {
 133     my $pkg = shift;
 134     $pkg = ref($pkg) || $pkg;
 135     my $class = shift;
 136
 137     return $class if (grep { $_ eq $class } @{$pkg->search_classes});
 138
 139     push @{$pkg->search_classes}, $class;
 140     $pkg->search_fields->{$class} = [];
 141     $pkg->default_search_class( $pkg->search_classes->[0] ) if (@{$pkg->search_classes} == 1);
 142
 143     return $class;
 144 }
 145
 146 sub operator {
 147     my $class = shift;
 148     $class = ref($class) || $class;
 149     my $opname = shift;
 150     my $op = shift;
 151
 152     return undef unless ($opname);
 153
 154     $parser_config{$class}{operators} ||= {};
 155     $parser_config{$class}{operators}{$opname} = $op if ($op);
 156
 157     return $parser_config{$class}{operators}{$opname};
 158 }
 159
 160 sub facet_classes {
 161     my $class = shift;
 162     $class = ref($class) || $class;
 163     my $classes = shift;
 164
 165     $parser_config{$class}{facet_classes} ||= [];
 166     $parser_config{$class}{facet_classes} = $classes if (ref($classes) && @$classes);
 167     return $parser_config{$class}{facet_classes};
 168 }
 169
 170 sub search_classes {
 171     my $class = shift;
 172     $class = ref($class) || $class;
 173     my $classes = shift;
 174
 175     $parser_config{$class}{classes} ||= [];
 176     $parser_config{$class}{classes} = $classes if (ref($classes) && @$classes);
 177     return $parser_config{$class}{classes};
 178 }
 179
 180 sub add_query_normalizer {
 181     my $pkg = shift;
 182     $pkg = ref($pkg) || $pkg;
 183     my $class = shift;
 184     my $field = shift;
 185     my $func = shift;
 186     my $params = shift || [];
 187
 188     # do not add if function AND params are identical to existing member
 189     return $func if (grep {
 190         $_->{function} eq $func and
 191         OpenSRF::Utils::JSON->perl2JSON($_->{params}) eq OpenSRF::Utils::JSON->perl2JSON($params)
 192     } @{$pkg->query_normalizers->{$class}->{$field}});
 193
 194     push(@{$pkg->query_normalizers->{$class}->{$field}}, { function => $func, params => $params });
 195
 196     return $func;
 197 }
 198
 199 sub query_normalizers {
 200     my $pkg = shift;
 201     $pkg = ref($pkg) || $pkg;
 202
 203     my $class = shift;
 204     my $field = shift;
 205
 206     $parser_config{$pkg}{normalizers} ||= {};
 207     if ($class) {
 208         if ($field) {
 209             $parser_config{$pkg}{normalizers}{$class}{$field} ||= [];
 210             return $parser_config{$pkg}{normalizers}{$class}{$field};
 211         } else {
 212             return $parser_config{$pkg}{normalizers}{$class};
 213         }
 214     }
 215
 216     return $parser_config{$pkg}{normalizers};
 217 }
 218
 219 sub add_filter_normalizer {
 220     my $pkg = shift;
 221     $pkg = ref($pkg) || $pkg;
 222     my $filter = shift;
 223     my $func = shift;
 224     my $params = shift || [];
 225
 226     return $func if (grep { $_ eq $func } @{$pkg->filter_normalizers->{$filter}});
 227
 228     push(@{$pkg->filter_normalizers->{$filter}}, { function => $func, params => $params });
 229
 230     return $func;
 231 }
 232
 233 sub filter_normalizers {
 234     my $pkg = shift;
 235     $pkg = ref($pkg) || $pkg;
 236
 237     my $filter = shift;
 238
 239     $parser_config{$pkg}{filter_normalizers} ||= {};
 240     if ($filter) {
 241         $parser_config{$pkg}{filter_normalizers}{$filter} ||= [];
 242         return $parser_config{$pkg}{filter_normalizers}{$filter};
 243     }
 244
 245     return $parser_config{$pkg}{filter_normalizers};
 246 }
 247
 248 sub default_search_class {
 249     my $pkg = shift;
 250     $pkg = ref($pkg) || $pkg;
 251     my $class = shift;
 252     $QueryParser::parser_config{$pkg}{default_class} = $pkg->add_search_class( $class ) if $class;
 253
 254     return $QueryParser::parser_config{$pkg}{default_class};
 255 }
 256
 257 sub remove_facet_class {
 258     my $pkg = shift;
 259     $pkg = ref($pkg) || $pkg;
 260     my $class = shift;
 261
 262     return $class if (!grep { $_ eq $class } @{$pkg->facet_classes});
 263
 264     $pkg->facet_classes( [ grep { $_ ne $class } @{$pkg->facet_classes} ] );
 265     delete $QueryParser::parser_config{$pkg}{facet_fields}{$class};
 266
 267     return $class;
 268 }
 269
 270 sub remove_search_class {
 271     my $pkg = shift;
 272     $pkg = ref($pkg) || $pkg;
 273     my $class = shift;
 274
 275     return $class if (!grep { $_ eq $class } @{$pkg->search_classes});
 276
 277     $pkg->search_classes( [ grep { $_ ne $class } @{$pkg->search_classes} ] );
 278     delete $QueryParser::parser_config{$pkg}{fields}{$class};
 279
 280     return $class;
 281 }
 282
 283 sub add_facet_field {
 284     my $pkg = shift;
 285     $pkg = ref($pkg) || $pkg;
 286     my $class = shift;
 287     my $field = shift;
 288
 289     $pkg->add_facet_class( $class );
 290
 291     return { $class => $field }  if (grep { $_ eq $field } @{$pkg->facet_fields->{$class}});
 292
 293     push @{$pkg->facet_fields->{$class}}, $field;
 294
 295     return { $class => $field };
 296 }
 297
 298 sub facet_fields {
 299     my $class = shift;
 300     $class = ref($class) || $class;
 301
 302     $parser_config{$class}{facet_fields} ||= {};
 303     return $parser_config{$class}{facet_fields};
 304 }
 305
 306 sub add_search_field {
 307     my $pkg = shift;
 308     $pkg = ref($pkg) || $pkg;
 309     my $class = shift;
 310     my $field = shift;
 311
 312     $pkg->add_search_class( $class );
 313
 314     return { $class => $field }  if (grep { $_ eq $field } @{$pkg->search_fields->{$class}});
 315
 316     push @{$pkg->search_fields->{$class}}, $field;
 317
 318     return { $class => $field };
 319 }
 320
 321 sub search_fields {
 322     my $class = shift;
 323     $class = ref($class) || $class;
 324
 325     $parser_config{$class}{fields} ||= {};
 326     return $parser_config{$class}{fields};
 327 }
 328
 329 sub add_search_class_alias {
 330     my $pkg = shift;
 331     $pkg = ref($pkg) || $pkg;
 332     my $class = shift;
 333     my $alias = shift;
 334
 335     $pkg->add_search_class( $class );
 336
 337     return { $class => $alias }  if (grep { $_ eq $alias } @{$pkg->search_class_aliases->{$class}});
 338
 339     push @{$pkg->search_class_aliases->{$class}}, $alias;
 340
 341     return { $class => $alias };
 342 }
 343
 344 sub search_class_aliases {
 345     my $class = shift;
 346     $class = ref($class) || $class;
 347
 348     $parser_config{$class}{class_map} ||= {};
 349     return $parser_config{$class}{class_map};
 350 }
 351
 352 sub add_search_field_alias {
 353     my $pkg = shift;
 354     $pkg = ref($pkg) || $pkg;
 355     my $class = shift;
 356     my $field = shift;
 357     my $alias = shift;
 358
 359     return { $class => { $field => $alias } }  if (grep { $_ eq $alias } @{$pkg->search_field_aliases->{$class}{$field}});
 360
 361     push @{$pkg->search_field_aliases->{$class}{$field}}, $alias;
 362
 363     return { $class => { $field => $alias } };
 364 }
 365
 366 sub search_field_aliases {
 367     my $class = shift;
 368     $class = ref($class) || $class;
 369
 370     $parser_config{$class}{field_alias_map} ||= {};
 371     return $parser_config{$class}{field_alias_map};
 372 }
 373
 374 sub remove_facet_field {
 375     my $pkg = shift;
 376     $pkg = ref($pkg) || $pkg;
 377     my $class = shift;
 378     my $field = shift;
 379
 380     return { $class => $field }  if (!$pkg->facet_fields->{$class} || !grep { $_ eq $field } @{$pkg->facet_fields->{$class}});
 381
 382     $pkg->facet_fields->{$class} = [ grep { $_ ne $field } @{$pkg->facet_fields->{$class}} ];
 383
 384     return { $class => $field };
 385 }
 386
 387 sub remove_search_field {
 388     my $pkg = shift;
 389     $pkg = ref($pkg) || $pkg;
 390     my $class = shift;
 391     my $field = shift;
 392
 393     return { $class => $field }  if (!$pkg->search_fields->{$class} || !grep { $_ eq $field } @{$pkg->search_fields->{$class}});
 394
 395     $pkg->search_fields->{$class} = [ grep { $_ ne $field } @{$pkg->search_fields->{$class}} ];
 396
 397     return { $class => $field };
 398 }
 399
 400 sub remove_search_field_alias {
 401     my $pkg = shift;
 402     $pkg = ref($pkg) || $pkg;
 403     my $class = shift;
 404     my $field = shift;
 405     my $alias = shift;
 406
 407     return { $class => { $field => $alias } }  if (!$pkg->search_field_aliases->{$class}{$field} || !grep { $_ eq $alias } @{$pkg->search_field_aliases->{$class}{$field}});
 408
 409     $pkg->search_field_aliases->{$class}{$field} = [ grep { $_ ne $alias } @{$pkg->search_field_aliases->{$class}{$field}} ];
 410
 411     return { $class => { $field => $alias } };
 412 }
 413
 414 sub remove_search_class_alias {
 415     my $pkg = shift;
 416     $pkg = ref($pkg) || $pkg;
 417     my $class = shift;
 418     my $alias = shift;
 419
 420     return { $class => $alias }  if (!$pkg->search_class_aliases->{$class} || !grep { $_ eq $alias } @{$pkg->search_class_aliases->{$class}});
 421
 422     $pkg->search_class_aliases->{$class} = [ grep { $_ ne $alias } @{$pkg->search_class_aliases->{$class}} ];
 423
 424     return { $class => $alias };
 425 }
 426
 427 sub debug {
 428     my $self = shift;
 429     my $q = shift;
 430     $self->{_debug} = $q if (defined $q);
 431     return $self->{_debug};
 432 }
 433
 434 sub query {
 435     my $self = shift;
 436     my $q = shift;
 437     $self->{_query} = $q if (defined $q);
 438     return $self->{_query};
 439 }
 440
 441 sub parse_tree {
 442     my $self = shift;
 443     my $q = shift;
 444     $self->{_parse_tree} = $q if (defined $q);
 445     return $self->{_parse_tree};
 446 }
 447
 448 sub parse {
 449     my $self = shift;
 450     my $pkg = ref($self) || $self;
 451     warn " ** parse package is $pkg\n" if $self->debug;
 452     $self->parse_tree(
 453         $self->decompose(
 454             $self->query( shift() )
 455         )
 456     );
 457
 458     return $self;
 459 }
 460
 461 sub decompose {
 462     my $self = shift;
 463     my $pkg = ref($self) || $self;
 464
 465     warn " ** decompose package is $pkg\n" if $self->debug;
 466
 467     $_ = shift;
 468     my $current_class = shift || $self->default_search_class;
 469
 470     my $recursing = shift || 0;
 471     my $phrase_helper = shift || 0;
 472
 473     # Build the search class+field uber-regexp
 474     my $search_class_re = '^\s*(';
 475     my $first_class = 1;
 476
 477     my %seen_classes;
 478     for my $class ( keys %{$pkg->search_fields} ) {
 479
 480         for my $field ( @{$pkg->search_fields->{$class}} ) {
 481
 482             for my $alias ( @{$pkg->search_field_aliases->{$class}{$field}} ) {
 483                 $alias = qr/$alias/;
 484                 s/(^|\s+)$alias[:=]/$1$class\|$field:/g;
 485             }
 486         }
 487
 488         $search_class_re .= '|' unless ($first_class);
 489         $first_class = 0;
 490         $search_class_re .= $class . '(?:\|\w+)*';
 491         $seen_classes{$class} = 1;
 492     }
 493
 494     for my $class ( keys %{$pkg->search_class_aliases} ) {
 495
 496         for my $alias ( @{$pkg->search_class_aliases->{$class}} ) {
 497             $alias = qr/$alias/;
 498             s/(^|[^|])\b$alias\|/$1$class\|/g;
 499             s/(^|[^|])\b$alias[:=]/$1$class:/g;
 500         }
 501
 502         if (!$seen_classes{$class}) {
 503             $search_class_re .= '|' unless ($first_class);
 504             $first_class = 0;
 505
 506             $search_class_re .= $class . '(?:\|\w+)*';
 507             $seen_classes{$class} = 1;
 508         }
 509     }
 510     $search_class_re .= '):';
 511
 512     warn " ** Search class RE: $search_class_re\n" if $self->debug;
 513
 514     my $required_re = $pkg->operator('required');
 515     $required_re = qr/\Q$required_re\E/;
 516
 517     my $disallowed_re = $pkg->operator('disallowed');
 518     $disallowed_re = qr/\Q$disallowed_re\E/;
 519
 520     my $and_re = $pkg->operator('and');
 521     $and_re = qr/^\s*\Q$and_re\E/;
 522
 523     my $or_re = $pkg->operator('or');
 524     $or_re = qr/^\s*\Q$or_re\E/;
 525
 526     my $group_start_re = $pkg->operator('group_start');
 527     $group_start_re = qr/^\s*\Q$group_start_re\E/;
 528
 529     my $group_end = $pkg->operator('group_end');
 530     my $group_end_re = qr/^\s*\Q$group_end\E/;
 531
 532     my $modifier_tag_re = $pkg->operator('modifier');
 533     $modifier_tag_re = qr/^\s*\Q$modifier_tag_re\E/;
 534
 535
 536     # Build the filter and modifier uber-regexps
 537     my $facet_re = '^\s*(-?)((?:' . join( '|', @{$pkg->facet_classes}) . ')(?:\|\w+)*)\[(.+?)\]';
 538     warn " Facet RE: $facet_re\n" if $self->debug;
 539
 540     my $filter_re = '^\s*(-?)(' . join( '|', @{$pkg->filters}) . ')\(([^()]+)\)';
 541     my $filter_as_class_re = '^\s*(-?)(' . join( '|', @{$pkg->filters}) . '):\s*(\S+)';
 542
 543     my $modifier_re = '^\s*'.$modifier_tag_re.'(' . join( '|', @{$pkg->modifiers}) . ')\b';
 544     my $modifier_as_class_re = '^\s*(' . join( '|', @{$pkg->modifiers}) . '):\s*(\S+)';
 545
 546     my $struct = $self->new_plan( level => $recursing );
 547     my $remainder = '';
 548
 549     my $last_type = '';
 550     while (!$remainder) {
 551         if (/^\s*$/) { # end of an explicit group
 552             last;
 553         } elsif (/$group_end_re/) { # end of an explicit group
 554             warn "Encountered explicit group end\n" if $self->debug;
 555
 556             $_ = $';
 557             $remainder = $struct->top_plan ? '' : $';
 558
 559             $last_type = '';
 560         } elsif ($self->filter_count && /$filter_re/) { # found a filter
 561             warn "Encountered search filter: $1$2 set to $3\n" if $self->debug;
 562
 563             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 564             $_ = $';
 565             $struct->new_filter( $2 => [ split '[,]+', $3 ], $negate );
 566
 567             $last_type = '';
 568         } elsif ($self->filter_count && /$filter_as_class_re/) { # found a filter
 569             warn "Encountered search filter: $1$2 set to $3\n" if $self->debug;
 570
 571             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 572             $_ = $';
 573             $struct->new_filter( $2 => [ split '[,]+', $3 ], $negate );
 574
 575             $last_type = '';
 576         } elsif ($self->modifier_count && /$modifier_re/) { # found a modifier
 577             warn "Encountered search modifier: $1\n" if $self->debug;
 578
 579             $_ = $';
 580             if (!$struct->top_plan) {
 581                 warn "  Search modifiers only allowed at the top level of the query\n" if $self->debug;
 582             } else {
 583                 $struct->new_modifier($1);
 584             }
 585
 586             $last_type = '';
 587         } elsif ($self->modifier_count && /$modifier_as_class_re/) { # found a modifier
 588             warn "Encountered search modifier: $1\n" if $self->debug;
 589
 590             my $mod = $1;
 591
 592             $_ = $';
 593             if (!$struct->top_plan) {
 594                 warn "  Search modifiers only allowed at the top level of the query\n" if $self->debug;
 595             } elsif ($2 =~ /^[ty1]/i) {
 596                 $struct->new_modifier($mod);
 597             }
 598
 599             $last_type = '';
 600         } elsif (/$group_start_re/) { # start of an explicit group
 601             warn "Encountered explicit group start\n" if $self->debug;
 602
 603             my ($substruct, $subremainder) = $self->decompose( $', $current_class, $recursing + 1 );
 604             $struct->add_node( $substruct ) if ($substruct);
 605             $_ = $subremainder;
 606
 607             $last_type = '';
 608         } elsif (/$and_re/) { # ANDed expression
 609             $_ = $';
 610             next if ($last_type eq 'AND');
 611             next if ($last_type eq 'OR');
 612             warn "Encountered AND\n" if $self->debug;
 613
 614             $struct->joiner( '&' );
 615
 616             $last_type = 'AND';
 617         } elsif (/$or_re/) { # ORed expression
 618             $_ = $';
 619             next if ($last_type eq 'AND');
 620             next if ($last_type eq 'OR');
 621             warn "Encountered OR\n" if $self->debug;
 622
 623             $struct->joiner( '|' );
 624
 625             $last_type = 'OR';
 626         } elsif ($self->facet_class_count && /$facet_re/) { # changing current class
 627             warn "Encountered facet: $1$2 => $3\n" if $self->debug;
 628
 629             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 630             my $facet = $2;
 631             my $facet_value = [ split '\s*#\s*', $3 ];
 632             $struct->new_facet( $facet => $facet_value, $negate );
 633             $_ = $';
 634
 635             $last_type = '';
 636         } elsif ($self->search_class_count && /$search_class_re/) { # changing current class
 637
 638             if ($last_type eq 'CLASS') {
 639                 $struct->remove_last_node( $current_class );
 640                 warn "Encountered class change with no searches!\n" if $self->debug;
 641             }
 642
 643             warn "Encountered class change: $1\n" if $self->debug;
 644
 645             $current_class = $1;
 646             $struct->classed_node( $current_class );
 647             $_ = $';
 648
 649             $last_type = 'CLASS';
 650         } elsif (/^\s*($required_re|$disallowed_re)?"([^"]+)"/) { # phrase, always anded
 651             warn 'Encountered' . ($1 ? " ['$1' modified]" : '') . " phrase: $2\n" if $self->debug;
 652
 653             my $req_ness = $1 || '';
 654             my $phrase = $2;
 655
 656             if (!$phrase_helper) {
 657                 warn "Recursing into decompose with the phrase as a subquery\n" if $self->debug;
 658                 my $after = $';
 659                 my ($substruct, $subremainder) = $self->decompose( qq/$req_ness"$phrase"/, $current_class, $recursing + 1, 1 );
 660                 $struct->add_node( $substruct ) if ($substruct);
 661                 $_ = $after;
 662             } else {
 663                 warn "Directly parsing the phrase subquery\n" if $self->debug;
 664                 $struct->joiner( '&' );
 665
 666                 my $class_node = $struct->classed_node($current_class);
 667
 668                 if ($req_ness eq $pkg->operator('disallowed')) {
 669                     $class_node->add_dummy_atom( node => $class_node );
 670                     $class_node->add_unphrase( $phrase );
 671                     $phrase = '';
 672                     #$phrase =~ s/(^|\s)\b/$1-/g;
 673                 } else {
 674                     $class_node->add_phrase( $phrase );
 675                 }
 676                 $_ = $phrase . $';
 677
 678             }
 679
 680             $last_type = '';
 681
 682 #        } elsif (/^\s*$required_re([^\s"]+)/) { # phrase, always anded
 683 #            warn "Encountered required atom (mini phrase): $1\n" if $self->debug;
 684 #
 685 #            my $phrase = $1;
 686 #
 687 #            my $class_node = $struct->classed_node($current_class);
 688 #            $class_node->add_phrase( $phrase );
 689 #            $_ = $phrase . $';
 690 #            $struct->joiner( '&' );
 691 #
 692 #            $last_type = '';
 693         } elsif (/^\s*([^$group_end\s]+)/o) { # atom
 694             warn "Encountered atom: $1\n" if $self->debug;
 695             warn "Remainder: $'\n" if $self->debug;
 696
 697             my $atom = $1;
 698             my $after = $';
 699
 700             $_ = $after;
 701             $last_type = '';
 702
 703             my $class_node = $struct->classed_node($current_class);
 704
 705             my $prefix = ($atom =~ s/^$disallowed_re//o) ? '!' : '';
 706             my $truncate = ($atom =~ s/\*$//o) ? '*' : '';
 707
 708             if ($atom ne '' and !grep { $atom =~ /^\Q$_\E+$/ } ('&','|','-','+')) { # throw away & and |, not allowed in tsquery, and not really useful anyway
 709 #                $class_node->add_phrase( $atom ) if ($atom =~ s/^$required_re//o);
 710 #                $class_node->add_unphrase( $atom ) if ($prefix eq '!');
 711
 712                 $class_node->add_fts_atom( $atom, suffix => $truncate, prefix => $prefix, node => $class_node );
 713                 $struct->joiner( '&' );
 714             }
 715         }
 716
 717         last unless ($_);
 718
 719     }
 720
 721     $struct = undef if (scalar(@{$struct->query_nodes}) == 0 && !$struct->top_plan);
 722
 723     return $struct if !wantarray;
 724     return ($struct, $remainder);
 725 }
 726
 727 sub find_class_index {
 728     my $class = shift;
 729     my $query = shift;
 730
 731     my ($class_part, @field_parts) = split '\|', $class;
 732     $class_part ||= $class;
 733
 734     for my $idx ( 0 .. scalar(@$query) - 1 ) {
 735         next unless ref($$query[$idx]);
 736         return $idx if ( $$query[$idx]{requested_class} && $class eq $$query[$idx]{requested_class} );
 737     }
 738
 739     push(@$query, { classname => $class_part, (@field_parts ? (fields => \@field_parts) : ()), requested_class => $class, ftsquery => [], phrases => [] });
 740     return -1;
 741 }
 742
 743 sub core_limit {
 744     my $self = shift;
 745     my $l = shift;
 746     $self->{core_limit} = $l if ($l);
 747     return $self->{core_limit};
 748 }
 749
 750 sub superpage {
 751     my $self = shift;
 752     my $l = shift;
 753     $self->{superpage} = $l if ($l);
 754     return $self->{superpage};
 755 }
 756
 757 sub superpage_size {
 758     my $self = shift;
 759     my $l = shift;
 760     $self->{superpage_size} = $l if ($l);
 761     return $self->{superpage_size};
 762 }
 763
 764
 765 #-------------------------------
 766 package QueryParser::query_plan;
 767
 768 sub QueryParser {
 769     my $self = shift;
 770     return undef unless ref($self);
 771     return $self->{QueryParser};
 772 }
 773
 774 sub new {
 775     my $pkg = shift;
 776     $pkg = ref($pkg) || $pkg;
 777     my %args = (query => [], joiner => '&', @_);
 778
 779     return bless \%args => $pkg;
 780 }
 781
 782 sub new_node {
 783     my $self = shift;
 784     my $pkg = ref($self) || $self;
 785     my $node = do{$pkg.'::node'}->new( plan => $self, @_ );
 786     $self->add_node( $node );
 787     return $node;
 788 }
 789
 790 sub new_facet {
 791     my $self = shift;
 792     my $pkg = ref($self) || $self;
 793     my $name = shift;
 794     my $args = shift;
 795     my $negate = shift;
 796
 797     my $node = do{$pkg.'::facet'}->new( plan => $self, name => $name, 'values' => $args, negate => $negate );
 798     $self->add_node( $node );
 799
 800     return $node;
 801 }
 802
 803 sub new_filter {
 804     my $self = shift;
 805     my $pkg = ref($self) || $self;
 806     my $name = shift;
 807     my $args = shift;
 808     my $negate = shift;
 809
 810     my $node = do{$pkg.'::filter'}->new( plan => $self, name => $name, args => $args, negate => $negate );
 811     $self->add_filter( $node );
 812
 813     return $node;
 814 }
 815
 816 sub find_filter {
 817     my $self = shift;
 818     my $needle = shift;;
 819     return undef unless ($needle);
 820     return grep { $_->name eq $needle } @{ $self->filters };
 821 }
 822
 823 sub find_modifier {
 824     my $self = shift;
 825     my $needle = shift;;
 826     return undef unless ($needle);
 827     return grep { $_->name eq $needle } @{ $self->modifiers };
 828 }
 829
 830 sub new_modifier {
 831     my $self = shift;
 832     my $pkg = ref($self) || $self;
 833     my $name = shift;
 834
 835     my $node = do{$pkg.'::modifier'}->new( $name );
 836     $self->add_modifier( $node );
 837
 838     return $node;
 839 }
 840
 841 sub classed_node {
 842     my $self = shift;
 843     my $requested_class = shift;
 844
 845     my $node;
 846     for my $n (@{$self->{query}}) {
 847         next unless (ref($n) && $n->isa( 'QueryParser::query_plan::node' ));
 848         if ($n->requested_class eq $requested_class) {
 849             $node = $n;
 850             last;
 851         }
 852     }
 853
 854     if (!$node) {
 855         $node = $self->new_node;
 856         $node->requested_class( $requested_class );
 857     }
 858
 859     return $node;
 860 }
 861
 862 sub remove_last_node {
 863     my $self = shift;
 864     my $requested_class = shift;
 865
 866     my $old = pop(@{$self->query_nodes});
 867     pop(@{$self->query_nodes}) if (@{$self->query_nodes});
 868
 869     return $old;
 870 }
 871
 872 sub query_nodes {
 873     my $self = shift;
 874     return $self->{query};
 875 }
 876
 877 sub add_node {
 878     my $self = shift;
 879     my $node = shift;
 880
 881     $self->{query} ||= [];
 882     push(@{$self->{query}}, $self->joiner) if (@{$self->{query}});
 883     push(@{$self->{query}}, $node);
 884
 885     return $self;
 886 }
 887
 888 sub top_plan {
 889     my $self = shift;
 890
 891     return $self->{level} ? 0 : 1;
 892 }
 893
 894 sub plan_level {
 895     my $self = shift;
 896     return $self->{level};
 897 }
 898
 899 sub joiner {
 900     my $self = shift;
 901     my $joiner = shift;
 902
 903     $self->{joiner} = $joiner if ($joiner);
 904     return $self->{joiner};
 905 }
 906
 907 sub modifiers {
 908     my $self = shift;
 909     $self->{modifiers} ||= [];
 910     return $self->{modifiers};
 911 }
 912
 913 sub add_modifier {
 914     my $self = shift;
 915     my $modifier = shift;
 916
 917     $self->{modifiers} ||= [];
 918     return $self if (grep {$$_ eq $$modifier} @{$self->{modifiers}});
 919
 920     push(@{$self->{modifiers}}, $modifier);
 921
 922     return $self;
 923 }
 924
 925 sub facets {
 926     my $self = shift;
 927     $self->{facets} ||= [];
 928     return $self->{facets};
 929 }
 930
 931 sub add_facet {
 932     my $self = shift;
 933     my $facet = shift;
 934
 935     $self->{facets} ||= [];
 936     return $self if (grep {$_->name eq $facet->name} @{$self->{facets}});
 937
 938     push(@{$self->{facets}}, $facet);
 939
 940     return $self;
 941 }
 942
 943 sub filters {
 944     my $self = shift;
 945     $self->{filters} ||= [];
 946     return $self->{filters};
 947 }
 948
 949 sub add_filter {
 950     my $self = shift;
 951     my $filter = shift;
 952
 953     $self->{filters} ||= [];
 954     return $self if (grep {$_->name eq $filter->name} @{$self->{filters}});
 955
 956     push(@{$self->{filters}}, $filter);
 957
 958     return $self;
 959 }
 960
 961
 962 #-------------------------------
 963 package QueryParser::query_plan::node;
 964
 965 sub new {
 966     my $pkg = shift;
 967     $pkg = ref($pkg) || $pkg;
 968     my %args = @_;
 969
 970     return bless \%args => $pkg;
 971 }
 972
 973 sub new_atom {
 974     my $self = shift;
 975     my $pkg = ref($self) || $self;
 976     return do{$pkg.'::atom'}->new( @_ );
 977 }
 978
 979 sub requested_class { # also split into classname and fields
 980     my $self = shift;
 981     my $class = shift;
 982
 983     if ($class) {
 984         my ($class_part, @field_parts) = split '\|', $class;
 985         $class_part ||= $class;
 986
 987         $self->{requested_class} = $class;
 988         $self->{classname} = $class_part;
 989         $self->{fields} = \@field_parts;
 990     }
 991
 992     return $self->{requested_class};
 993 }
 994
 995 sub plan {
 996     my $self = shift;
 997     my $plan = shift;
 998
 999     $self->{plan} = $plan if ($plan);
1000     return $self->{plan};
1001 }
1002
1003 sub classname {
1004     my $self = shift;
1005     my $class = shift;
1006
1007     $self->{classname} = $class if ($class);
1008     return $self->{classname};
1009 }
1010
1011 sub fields {
1012     my $self = shift;
1013     my @fields = @_;
1014
1015     $self->{fields} ||= [];
1016     $self->{fields} = \@fields if (@fields);
1017     return $self->{fields};
1018 }
1019
1020 sub phrases {
1021     my $self = shift;
1022     my @phrases = @_;
1023
1024     $self->{phrases} ||= [];
1025     $self->{phrases} = \@phrases if (@phrases);
1026     return $self->{phrases};
1027 }
1028
1029 sub unphrases {
1030     my $self = shift;
1031     my @phrases = @_;
1032
1033     $self->{unphrases} ||= [];
1034     $self->{unphrases} = \@phrases if (@phrases);
1035     return $self->{unphrases};
1036 }
1037
1038 sub add_phrase {
1039     my $self = shift;
1040     my $phrase = shift;
1041
1042     push(@{$self->phrases}, $phrase);
1043
1044     return $self;
1045 }
1046
1047 sub add_unphrase {
1048     my $self = shift;
1049     my $phrase = shift;
1050
1051     push(@{$self->unphrases}, $phrase);
1052
1053     return $self;
1054 }
1055
1056 sub query_atoms {
1057     my $self = shift;
1058     my @query_atoms = @_;
1059
1060     $self->{query_atoms} ||= [];
1061     $self->{query_atoms} = \@query_atoms if (@query_atoms);
1062     return $self->{query_atoms};
1063 }
1064
1065 sub add_fts_atom {
1066     my $self = shift;
1067     my $atom = shift;
1068
1069     if (!ref($atom)) {
1070         my $content = $atom;
1071         my @parts = @_;
1072
1073         $atom = $self->new_atom( content => $content, @parts );
1074     }
1075
1076     push(@{$self->query_atoms}, $self->plan->joiner) if (@{$self->query_atoms});
1077     push(@{$self->query_atoms}, $atom);
1078
1079     return $self;
1080 }
1081
1082 sub add_dummy_atom {
1083     my $self = shift;
1084     my @parts = @_;
1085
1086     my $atom = $self->new_atom( @parts, dummy => 1 );
1087
1088     push(@{$self->query_atoms}, $self->plan->joiner) if (@{$self->query_atoms});
1089     push(@{$self->query_atoms}, $atom);
1090
1091     return $self;
1092 }
1093
1094 #-------------------------------
1095 package QueryParser::query_plan::node::atom;
1096
1097 sub new {
1098     my $pkg = shift;
1099     $pkg = ref($pkg) || $pkg;
1100     my %args = @_;
1101
1102     return bless \%args => $pkg;
1103 }
1104
1105 sub node {
1106     my $self = shift;
1107     return undef unless (ref $self);
1108     return $self->{node};
1109 }
1110
1111 sub content {
1112     my $self = shift;
1113     return undef unless (ref $self);
1114     return $self->{content};
1115 }
1116
1117 sub prefix {
1118     my $self = shift;
1119     return undef unless (ref $self);
1120     return $self->{prefix};
1121 }
1122
1123 sub suffix {
1124     my $self = shift;
1125     return undef unless (ref $self);
1126     return $self->{suffix};
1127 }
1128
1129 #-------------------------------
1130 package QueryParser::query_plan::filter;
1131
1132 sub new {
1133     my $pkg = shift;
1134     $pkg = ref($pkg) || $pkg;
1135     my %args = @_;
1136
1137     return bless \%args => $pkg;
1138 }
1139
1140 sub plan {
1141     my $self = shift;
1142     return $self->{plan};
1143 }
1144
1145 sub name {
1146     my $self = shift;
1147     return $self->{name};
1148 }
1149
1150 sub negate {
1151     my $self = shift;
1152     return $self->{negate};
1153 }
1154
1155 sub args {
1156     my $self = shift;
1157     return $self->{args};
1158 }
1159
1160 #-------------------------------
1161 package QueryParser::query_plan::facet;
1162
1163 sub new {
1164     my $pkg = shift;
1165     $pkg = ref($pkg) || $pkg;
1166     my %args = @_;
1167
1168     return bless \%args => $pkg;
1169 }
1170
1171 sub plan {
1172     my $self = shift;
1173     return $self->{plan};
1174 }
1175
1176 sub name {
1177     my $self = shift;
1178     return $self->{name};
1179 }
1180
1181 sub negate {
1182     my $self = shift;
1183     return $self->{negate};
1184 }
1185
1186 sub values {
1187     my $self = shift;
1188     return $self->{'values'};
1189 }
1190
1191 #-------------------------------
1192 package QueryParser::query_plan::modifier;
1193
1194 sub new {
1195     my $pkg = shift;
1196     $pkg = ref($pkg) || $pkg;
1197     my $modifier = shift;
1198
1199     return bless \$modifier => $pkg;
1200 }
1201
1202 sub name {
1203     my $self = shift;
1204     return $$self;
1205 }
1206
1207 1;
1208