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