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
 472     # Build the search class+field uber-regexp
 473     my $search_class_re = '^\s*(';
 474     my $first_class = 1;
 475
 476     my %seen_classes;
 477     for my $class ( keys %{$pkg->search_fields} ) {
 478
 479         for my $field ( @{$pkg->search_fields->{$class}} ) {
 480
 481             for my $alias ( @{$pkg->search_field_aliases->{$class}{$field}} ) {
 482                 $alias = qr/$alias/;
 483                 s/(^|\s+)$alias[:=]/$1$class\|$field:/g;
 484             }
 485         }
 486
 487         $search_class_re .= '|' unless ($first_class);
 488         $first_class = 0;
 489         $search_class_re .= $class . '(?:\|\w+)*';
 490         $seen_classes{$class} = 1;
 491     }
 492
 493     for my $class ( keys %{$pkg->search_class_aliases} ) {
 494
 495         for my $alias ( @{$pkg->search_class_aliases->{$class}} ) {
 496             $alias = qr/$alias/;
 497             s/(^|[^|])\b$alias\|/$1$class\|/g;
 498             s/(^|[^|])\b$alias[:=]/$1$class:/g;
 499         }
 500
 501         if (!$seen_classes{$class}) {
 502             $search_class_re .= '|' unless ($first_class);
 503             $first_class = 0;
 504
 505             $search_class_re .= $class . '(?:\|\w+)*';
 506             $seen_classes{$class} = 1;
 507         }
 508     }
 509     $search_class_re .= '):';
 510
 511     warn " ** Search class RE: $search_class_re\n" if $self->debug;
 512
 513     my $required_re = $pkg->operator('required');
 514     $required_re = qr/\Q$required_re\E/;
 515
 516     my $disallowed_re = $pkg->operator('disallowed');
 517     $disallowed_re = qr/\Q$disallowed_re\E/;
 518
 519     my $and_re = $pkg->operator('and');
 520     $and_re = qr/^\s*\Q$and_re\E/;
 521
 522     my $or_re = $pkg->operator('or');
 523     $or_re = qr/^\s*\Q$or_re\E/;
 524
 525     my $group_start_re = $pkg->operator('group_start');
 526     $group_start_re = qr/^\s*\Q$group_start_re\E/;
 527
 528     my $group_end = $pkg->operator('group_end');
 529     my $group_end_re = qr/^\s*\Q$group_end\E/;
 530
 531     my $modifier_tag_re = $pkg->operator('modifier');
 532     $modifier_tag_re = qr/^\s*\Q$modifier_tag_re\E/;
 533
 534
 535     # Build the filter and modifier uber-regexps
 536     my $facet_re = '^\s*(-?)((?:' . join( '|', @{$pkg->facet_classes}) . ')(?:\|\w+)*)\[(.+?)\]';
 537     warn " Facet RE: $facet_re\n" if $self->debug;
 538
 539     my $filter_re = '^\s*(-?)(' . join( '|', @{$pkg->filters}) . ')\(([^()]+)\)';
 540     my $filter_as_class_re = '^\s*(-?)(' . join( '|', @{$pkg->filters}) . '):\s*(\S+)';
 541
 542     my $modifier_re = '^\s*'.$modifier_tag_re.'(' . join( '|', @{$pkg->modifiers}) . ')\b';
 543     my $modifier_as_class_re = '^\s*(' . join( '|', @{$pkg->modifiers}) . '):\s*(\S+)';
 544
 545     my $struct = $self->new_plan( level => $recursing );
 546     my $remainder = '';
 547
 548     my $last_type = '';
 549     while (!$remainder) {
 550         if (/^\s*$/) { # end of an explicit group
 551             last;
 552         } elsif (/$group_end_re/) { # end of an explicit group
 553             warn "Encountered explicit group end\n" if $self->debug;
 554
 555             $_ = $';
 556             $remainder = $struct->top_plan ? '' : $';
 557
 558             $last_type = '';
 559         } elsif ($self->filter_count && /$filter_re/) { # found a filter
 560             warn "Encountered search filter: $1$2 set to $3\n" if $self->debug;
 561
 562             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 563             $_ = $';
 564             $struct->new_filter( $2 => [ split '[,]+', $3 ], $negate );
 565
 566             $last_type = '';
 567         } elsif ($self->filter_count && /$filter_as_class_re/) { # found a filter
 568             warn "Encountered search filter: $1$2 set to $3\n" if $self->debug;
 569
 570             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 571             $_ = $';
 572             $struct->new_filter( $2 => [ split '[,]+', $3 ], $negate );
 573
 574             $last_type = '';
 575         } elsif ($self->modifier_count && /$modifier_re/) { # found a modifier
 576             warn "Encountered search modifier: $1\n" if $self->debug;
 577
 578             $_ = $';
 579             if (!$struct->top_plan) {
 580                 warn "  Search modifiers only allowed at the top level of the query\n" if $self->debug;
 581             } else {
 582                 $struct->new_modifier($1);
 583             }
 584
 585             $last_type = '';
 586         } elsif ($self->modifier_count && /$modifier_as_class_re/) { # found a modifier
 587             warn "Encountered search modifier: $1\n" if $self->debug;
 588
 589             my $mod = $1;
 590
 591             $_ = $';
 592             if (!$struct->top_plan) {
 593                 warn "  Search modifiers only allowed at the top level of the query\n" if $self->debug;
 594             } elsif ($2 =~ /^[ty1]/i) {
 595                 $struct->new_modifier($mod);
 596             }
 597
 598             $last_type = '';
 599         } elsif (/$group_start_re/) { # start of an explicit group
 600             warn "Encountered explicit group start\n" if $self->debug;
 601
 602             my ($substruct, $subremainder) = $self->decompose( $', $current_class, $recursing + 1 );
 603             $struct->add_node( $substruct ) if ($substruct);
 604             $_ = $subremainder;
 605
 606             $last_type = '';
 607         } elsif (/$and_re/) { # ANDed expression
 608             $_ = $';
 609             next if ($last_type eq 'AND');
 610             next if ($last_type eq 'OR');
 611             warn "Encountered AND\n" if $self->debug;
 612
 613             $struct->joiner( '&' );
 614
 615             $last_type = 'AND';
 616         } elsif (/$or_re/) { # ORed expression
 617             $_ = $';
 618             next if ($last_type eq 'AND');
 619             next if ($last_type eq 'OR');
 620             warn "Encountered OR\n" if $self->debug;
 621
 622             $struct->joiner( '|' );
 623
 624             $last_type = 'OR';
 625         } elsif ($self->facet_class_count && /$facet_re/) { # changing current class
 626             warn "Encountered facet: $1$2 => $3\n" if $self->debug;
 627
 628             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 629             my $facet = $2;
 630             my $facet_value = [ split '\s*#\s*', $3 ];
 631             $struct->new_facet( $facet => $facet_value, $negate );
 632             $_ = $';
 633
 634             $last_type = '';
 635         } elsif ($self->search_class_count && /$search_class_re/) { # changing current class
 636
 637             if ($last_type eq 'CLASS') {
 638                 $struct->remove_last_node( $current_class );
 639                 warn "Encountered class change with no searches!\n" if $self->debug;
 640             }
 641
 642             warn "Encountered class change: $1\n" if $self->debug;
 643
 644             $current_class = $1;
 645             $struct->classed_node( $current_class );
 646             $_ = $';
 647
 648             $last_type = 'CLASS';
 649         } elsif (/^\s*($required_re|$disallowed_re)?"([^"]+)"/) { # phrase, always anded
 650             warn 'Encountered' . ($1 ? " ['$1' modified]" : '') . " phrase: $2\n" if $self->debug;
 651
 652             $struct->joiner( '&' );
 653             my $req_ness = $1;
 654             my $phrase = $2;
 655
 656             my $class_node = $struct->classed_node($current_class);
 657
 658             if ($req_ness eq $pkg->operator('disallowed')) {
 659                 $class_node->add_dummy_atom( node => $class_node );
 660                 $class_node->add_unphrase( $phrase );
 661                 $phrase = '';
 662                 #$phrase =~ s/(^|\s)\b/$1-/g;
 663             } else {
 664                 $class_node->add_phrase( $phrase );
 665             }
 666             $_ = $phrase . $';
 667
 668             $last_type = '';
 669 #        } elsif (/^\s*$required_re([^\s"]+)/) { # phrase, always anded
 670 #            warn "Encountered required atom (mini phrase): $1\n" if $self->debug;
 671 #
 672 #            my $phrase = $1;
 673 #
 674 #            my $class_node = $struct->classed_node($current_class);
 675 #            $class_node->add_phrase( $phrase );
 676 #            $_ = $phrase . $';
 677 #            $struct->joiner( '&' );
 678 #
 679 #            $last_type = '';
 680         } elsif (/^\s*([^$group_end\s]+)/o) { # atom
 681             warn "Encountered atom: $1\n" if $self->debug;
 682             warn "Remainder: $'\n" if $self->debug;
 683
 684             my $atom = $1;
 685             my $after = $';
 686
 687             $_ = $after;
 688             $last_type = '';
 689
 690             my $class_node = $struct->classed_node($current_class);
 691
 692             my $prefix = ($atom =~ s/^$disallowed_re//o) ? '!' : '';
 693             my $truncate = ($atom =~ s/\*$//o) ? '*' : '';
 694
 695             if ($atom ne '' and !grep { $atom =~ /^\Q$_\E+$/ } ('&','|','-','+')) { # throw away & and |, not allowed in tsquery, and not really useful anyway
 696 #                $class_node->add_phrase( $atom ) if ($atom =~ s/^$required_re//o);
 697 #                $class_node->add_unphrase( $atom ) if ($prefix eq '!');
 698
 699                 $class_node->add_fts_atom( $atom, suffix => $truncate, prefix => $prefix, node => $class_node );
 700                 $struct->joiner( '&' );
 701             }
 702         }
 703
 704         last unless ($_);
 705
 706     }
 707
 708     $struct = undef if (scalar(@{$struct->query_nodes}) == 0 && !$struct->top_plan);
 709
 710     return $struct if !wantarray;
 711     return ($struct, $remainder);
 712 }
 713
 714 sub find_class_index {
 715     my $class = shift;
 716     my $query = shift;
 717
 718     my ($class_part, @field_parts) = split '\|', $class;
 719     $class_part ||= $class;
 720
 721     for my $idx ( 0 .. scalar(@$query) - 1 ) {
 722         next unless ref($$query[$idx]);
 723         return $idx if ( $$query[$idx]{requested_class} && $class eq $$query[$idx]{requested_class} );
 724     }
 725
 726     push(@$query, { classname => $class_part, (@field_parts ? (fields => \@field_parts) : ()), requested_class => $class, ftsquery => [], phrases => [] });
 727     return -1;
 728 }
 729
 730 sub core_limit {
 731     my $self = shift;
 732     my $l = shift;
 733     $self->{core_limit} = $l if ($l);
 734     return $self->{core_limit};
 735 }
 736
 737 sub superpage {
 738     my $self = shift;
 739     my $l = shift;
 740     $self->{superpage} = $l if ($l);
 741     return $self->{superpage};
 742 }
 743
 744 sub superpage_size {
 745     my $self = shift;
 746     my $l = shift;
 747     $self->{superpage_size} = $l if ($l);
 748     return $self->{superpage_size};
 749 }
 750
 751
 752 #-------------------------------
 753 package QueryParser::query_plan;
 754
 755 sub QueryParser {
 756     my $self = shift;
 757     return undef unless ref($self);
 758     return $self->{QueryParser};
 759 }
 760
 761 sub new {
 762     my $pkg = shift;
 763     $pkg = ref($pkg) || $pkg;
 764     my %args = (query => [], joiner => '&', @_);
 765
 766     return bless \%args => $pkg;
 767 }
 768
 769 sub new_node {
 770     my $self = shift;
 771     my $pkg = ref($self) || $self;
 772     my $node = do{$pkg.'::node'}->new( plan => $self, @_ );
 773     $self->add_node( $node );
 774     return $node;
 775 }
 776
 777 sub new_facet {
 778     my $self = shift;
 779     my $pkg = ref($self) || $self;
 780     my $name = shift;
 781     my $args = shift;
 782     my $negate = shift;
 783
 784     my $node = do{$pkg.'::facet'}->new( plan => $self, name => $name, 'values' => $args, negate => $negate );
 785     $self->add_node( $node );
 786
 787     return $node;
 788 }
 789
 790 sub new_filter {
 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.'::filter'}->new( plan => $self, name => $name, args => $args, negate => $negate );
 798     $self->add_filter( $node );
 799
 800     return $node;
 801 }
 802
 803 sub find_filter {
 804     my $self = shift;
 805     my $needle = shift;;
 806     return undef unless ($needle);
 807     return grep { $_->name eq $needle } @{ $self->filters };
 808 }
 809
 810 sub find_modifier {
 811     my $self = shift;
 812     my $needle = shift;;
 813     return undef unless ($needle);
 814     return grep { $_->name eq $needle } @{ $self->modifiers };
 815 }
 816
 817 sub new_modifier {
 818     my $self = shift;
 819     my $pkg = ref($self) || $self;
 820     my $name = shift;
 821
 822     my $node = do{$pkg.'::modifier'}->new( $name );
 823     $self->add_modifier( $node );
 824
 825     return $node;
 826 }
 827
 828 sub classed_node {
 829     my $self = shift;
 830     my $requested_class = shift;
 831
 832     my $node;
 833     for my $n (@{$self->{query}}) {
 834         next unless (ref($n) && $n->isa( 'QueryParser::query_plan::node' ));
 835         if ($n->requested_class eq $requested_class) {
 836             $node = $n;
 837             last;
 838         }
 839     }
 840
 841     if (!$node) {
 842         $node = $self->new_node;
 843         $node->requested_class( $requested_class );
 844     }
 845
 846     return $node;
 847 }
 848
 849 sub remove_last_node {
 850     my $self = shift;
 851     my $requested_class = shift;
 852
 853     my $old = pop(@{$self->query_nodes});
 854     pop(@{$self->query_nodes}) if (@{$self->query_nodes});
 855
 856     return $old;
 857 }
 858
 859 sub query_nodes {
 860     my $self = shift;
 861     return $self->{query};
 862 }
 863
 864 sub add_node {
 865     my $self = shift;
 866     my $node = shift;
 867
 868     $self->{query} ||= [];
 869     push(@{$self->{query}}, $self->joiner) if (@{$self->{query}});
 870     push(@{$self->{query}}, $node);
 871
 872     return $self;
 873 }
 874
 875 sub top_plan {
 876     my $self = shift;
 877
 878     return $self->{level} ? 0 : 1;
 879 }
 880
 881 sub plan_level {
 882     my $self = shift;
 883     return $self->{level};
 884 }
 885
 886 sub joiner {
 887     my $self = shift;
 888     my $joiner = shift;
 889
 890     $self->{joiner} = $joiner if ($joiner);
 891     return $self->{joiner};
 892 }
 893
 894 sub modifiers {
 895     my $self = shift;
 896     $self->{modifiers} ||= [];
 897     return $self->{modifiers};
 898 }
 899
 900 sub add_modifier {
 901     my $self = shift;
 902     my $modifier = shift;
 903
 904     $self->{modifiers} ||= [];
 905     return $self if (grep {$$_ eq $$modifier} @{$self->{modifiers}});
 906
 907     push(@{$self->{modifiers}}, $modifier);
 908
 909     return $self;
 910 }
 911
 912 sub facets {
 913     my $self = shift;
 914     $self->{facets} ||= [];
 915     return $self->{facets};
 916 }
 917
 918 sub add_facet {
 919     my $self = shift;
 920     my $facet = shift;
 921
 922     $self->{facets} ||= [];
 923     return $self if (grep {$_->name eq $facet->name} @{$self->{facets}});
 924
 925     push(@{$self->{facets}}, $facet);
 926
 927     return $self;
 928 }
 929
 930 sub filters {
 931     my $self = shift;
 932     $self->{filters} ||= [];
 933     return $self->{filters};
 934 }
 935
 936 sub add_filter {
 937     my $self = shift;
 938     my $filter = shift;
 939
 940     $self->{filters} ||= [];
 941     return $self if (grep {$_->name eq $filter->name} @{$self->{filters}});
 942
 943     push(@{$self->{filters}}, $filter);
 944
 945     return $self;
 946 }
 947
 948
 949 #-------------------------------
 950 package QueryParser::query_plan::node;
 951
 952 sub new {
 953     my $pkg = shift;
 954     $pkg = ref($pkg) || $pkg;
 955     my %args = @_;
 956
 957     return bless \%args => $pkg;
 958 }
 959
 960 sub new_atom {
 961     my $self = shift;
 962     my $pkg = ref($self) || $self;
 963     return do{$pkg.'::atom'}->new( @_ );
 964 }
 965
 966 sub requested_class { # also split into classname and fields
 967     my $self = shift;
 968     my $class = shift;
 969
 970     if ($class) {
 971         my ($class_part, @field_parts) = split '\|', $class;
 972         $class_part ||= $class;
 973
 974         $self->{requested_class} = $class;
 975         $self->{classname} = $class_part;
 976         $self->{fields} = \@field_parts;
 977     }
 978
 979     return $self->{requested_class};
 980 }
 981
 982 sub plan {
 983     my $self = shift;
 984     my $plan = shift;
 985
 986     $self->{plan} = $plan if ($plan);
 987     return $self->{plan};
 988 }
 989
 990 sub classname {
 991     my $self = shift;
 992     my $class = shift;
 993
 994     $self->{classname} = $class if ($class);
 995     return $self->{classname};
 996 }
 997
 998 sub fields {
 999     my $self = shift;
1000     my @fields = @_;
1001
1002     $self->{fields} ||= [];
1003     $self->{fields} = \@fields if (@fields);
1004     return $self->{fields};
1005 }
1006
1007 sub phrases {
1008     my $self = shift;
1009     my @phrases = @_;
1010
1011     $self->{phrases} ||= [];
1012     $self->{phrases} = \@phrases if (@phrases);
1013     return $self->{phrases};
1014 }
1015
1016 sub unphrases {
1017     my $self = shift;
1018     my @phrases = @_;
1019
1020     $self->{unphrases} ||= [];
1021     $self->{unphrases} = \@phrases if (@phrases);
1022     return $self->{unphrases};
1023 }
1024
1025 sub add_phrase {
1026     my $self = shift;
1027     my $phrase = shift;
1028
1029     push(@{$self->phrases}, $phrase);
1030
1031     return $self;
1032 }
1033
1034 sub add_unphrase {
1035     my $self = shift;
1036     my $phrase = shift;
1037
1038     push(@{$self->unphrases}, $phrase);
1039
1040     return $self;
1041 }
1042
1043 sub query_atoms {
1044     my $self = shift;
1045     my @query_atoms = @_;
1046
1047     $self->{query_atoms} ||= [];
1048     $self->{query_atoms} = \@query_atoms if (@query_atoms);
1049     return $self->{query_atoms};
1050 }
1051
1052 sub add_fts_atom {
1053     my $self = shift;
1054     my $atom = shift;
1055
1056     if (!ref($atom)) {
1057         my $content = $atom;
1058         my @parts = @_;
1059
1060         $atom = $self->new_atom( content => $content, @parts );
1061     }
1062
1063     push(@{$self->query_atoms}, $self->plan->joiner) if (@{$self->query_atoms});
1064     push(@{$self->query_atoms}, $atom);
1065
1066     return $self;
1067 }
1068
1069 sub add_dummy_atom {
1070     my $self = shift;
1071     my @parts = @_;
1072
1073     my $atom = $self->new_atom( @parts, dummy => 1 );
1074
1075     push(@{$self->query_atoms}, $self->plan->joiner) if (@{$self->query_atoms});
1076     push(@{$self->query_atoms}, $atom);
1077
1078     return $self;
1079 }
1080
1081 #-------------------------------
1082 package QueryParser::query_plan::node::atom;
1083
1084 sub new {
1085     my $pkg = shift;
1086     $pkg = ref($pkg) || $pkg;
1087     my %args = @_;
1088
1089     return bless \%args => $pkg;
1090 }
1091
1092 sub node {
1093     my $self = shift;
1094     return undef unless (ref $self);
1095     return $self->{node};
1096 }
1097
1098 sub content {
1099     my $self = shift;
1100     return undef unless (ref $self);
1101     return $self->{content};
1102 }
1103
1104 sub prefix {
1105     my $self = shift;
1106     return undef unless (ref $self);
1107     return $self->{prefix};
1108 }
1109
1110 sub suffix {
1111     my $self = shift;
1112     return undef unless (ref $self);
1113     return $self->{suffix};
1114 }
1115
1116 #-------------------------------
1117 package QueryParser::query_plan::filter;
1118
1119 sub new {
1120     my $pkg = shift;
1121     $pkg = ref($pkg) || $pkg;
1122     my %args = @_;
1123
1124     return bless \%args => $pkg;
1125 }
1126
1127 sub plan {
1128     my $self = shift;
1129     return $self->{plan};
1130 }
1131
1132 sub name {
1133     my $self = shift;
1134     return $self->{name};
1135 }
1136
1137 sub negate {
1138     my $self = shift;
1139     return $self->{negate};
1140 }
1141
1142 sub args {
1143     my $self = shift;
1144     return $self->{args};
1145 }
1146
1147 #-------------------------------
1148 package QueryParser::query_plan::facet;
1149
1150 sub new {
1151     my $pkg = shift;
1152     $pkg = ref($pkg) || $pkg;
1153     my %args = @_;
1154
1155     return bless \%args => $pkg;
1156 }
1157
1158 sub plan {
1159     my $self = shift;
1160     return $self->{plan};
1161 }
1162
1163 sub name {
1164     my $self = shift;
1165     return $self->{name};
1166 }
1167
1168 sub negate {
1169     my $self = shift;
1170     return $self->{negate};
1171 }
1172
1173 sub values {
1174     my $self = shift;
1175     return $self->{'values'};
1176 }
1177
1178 #-------------------------------
1179 package QueryParser::query_plan::modifier;
1180
1181 sub new {
1182     my $pkg = shift;
1183     $pkg = ref($pkg) || $pkg;
1184     my $modifier = shift;
1185
1186     return bless \$modifier => $pkg;
1187 }
1188
1189 sub name {
1190     my $self = shift;
1191     return $$self;
1192 }
1193
1194 1;
1195