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_field_aliases} ) {
 479         warn " *** ... Looking for search fields in $class\n" if $self->debug;
 480
 481         for my $field ( keys %{$pkg->search_field_aliases->{$class}} ) {
 482             warn " *** ... Looking for aliases of $field\n" if $self->debug;
 483
 484             for my $alias ( @{$pkg->search_field_aliases->{$class}{$field}} ) {
 485                 my $aliasr = qr/$alias/;
 486                 s/(^|\s+)$aliasr\|/$1$class\|$field#$alias\|/g;
 487                 s/(^|\s+)$aliasr[:=]/$1$class\|$field#$alias:/g;
 488                 warn " *** Rewriting: $alias ($aliasr) as $class\|$field\n" if $self->debug;
 489             }
 490         }
 491
 492         $search_class_re .= '|' unless ($first_class);
 493         $first_class = 0;
 494         $search_class_re .= $class . '(?:[|#][^:|]+)*';
 495         $seen_classes{$class} = 1;
 496     }
 497
 498     for my $class ( keys %{$pkg->search_class_aliases} ) {
 499
 500         for my $alias ( @{$pkg->search_class_aliases->{$class}} ) {
 501             my $aliasr = qr/$alias/;
 502             s/(^|[^|])\b$aliasr\|/$1$class#$alias\|/g;
 503             s/(^|[^|])\b$aliasr[:=]/$1$class#$alias:/g;
 504             warn " *** Rewriting: $alias ($aliasr) as $class\n" if $self->debug;
 505         }
 506
 507         if (!$seen_classes{$class}) {
 508             $search_class_re .= '|' unless ($first_class);
 509             $first_class = 0;
 510
 511             $search_class_re .= $class . '(?:[|#][^:|]+)*';
 512             $seen_classes{$class} = 1;
 513         }
 514     }
 515     $search_class_re .= '):';
 516
 517     warn " ** Rewritten query: $_\n" if $self->debug;
 518     warn " ** Search class RE: $search_class_re\n" if $self->debug;
 519
 520     my $required_re = $pkg->operator('required');
 521     $required_re = qr/\Q$required_re\E/;
 522
 523     my $disallowed_re = $pkg->operator('disallowed');
 524     $disallowed_re = qr/\Q$disallowed_re\E/;
 525
 526     my $and_re = $pkg->operator('and');
 527     $and_re = qr/^\s*\Q$and_re\E/;
 528
 529     my $or_re = $pkg->operator('or');
 530     $or_re = qr/^\s*\Q$or_re\E/;
 531
 532     my $group_start_re = $pkg->operator('group_start');
 533     $group_start_re = qr/^\s*\Q$group_start_re\E/;
 534
 535     my $group_end = $pkg->operator('group_end');
 536     my $group_end_re = qr/^\s*\Q$group_end\E/;
 537
 538     my $modifier_tag_re = $pkg->operator('modifier');
 539     $modifier_tag_re = qr/^\s*\Q$modifier_tag_re\E/;
 540
 541
 542     # Build the filter and modifier uber-regexps
 543     my $facet_re = '^\s*(-?)((?:' . join( '|', @{$pkg->facet_classes}) . ')(?:\|\w+)*)\[(.+?)\]';
 544     warn " ** Facet RE: $facet_re\n" if $self->debug;
 545
 546     my $filter_re = '^\s*(-?)(' . join( '|', @{$pkg->filters}) . ')\(([^()]+)\)';
 547     my $filter_as_class_re = '^\s*(-?)(' . join( '|', @{$pkg->filters}) . '):\s*(\S+)';
 548
 549     my $modifier_re = '^\s*'.$modifier_tag_re.'(' . join( '|', @{$pkg->modifiers}) . ')\b';
 550     my $modifier_as_class_re = '^\s*(' . join( '|', @{$pkg->modifiers}) . '):\s*(\S+)';
 551
 552     my $struct = $self->new_plan( level => $recursing );
 553     my $remainder = '';
 554
 555     my $last_type = '';
 556     while (!$remainder) {
 557         if (/^\s*$/) { # end of an explicit group
 558             last;
 559         } elsif (/$group_end_re/) { # end of an explicit group
 560             warn "Encountered explicit group end\n" if $self->debug;
 561
 562             $_ = $';
 563             $remainder = $struct->top_plan ? '' : $';
 564
 565             $last_type = '';
 566         } elsif ($self->filter_count && /$filter_re/) { # found a filter
 567             warn "Encountered search filter: $1$2 set to $3\n" if $self->debug;
 568
 569             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 570             $_ = $';
 571             $struct->new_filter( $2 => [ split '[,]+', $3 ], $negate );
 572
 573             $last_type = '';
 574         } elsif ($self->filter_count && /$filter_as_class_re/) { # found a filter
 575             warn "Encountered search filter: $1$2 set to $3\n" if $self->debug;
 576
 577             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 578             $_ = $';
 579             $struct->new_filter( $2 => [ split '[,]+', $3 ], $negate );
 580
 581             $last_type = '';
 582         } elsif ($self->modifier_count && /$modifier_re/) { # found a modifier
 583             warn "Encountered search modifier: $1\n" if $self->debug;
 584
 585             $_ = $';
 586             if (!$struct->top_plan) {
 587                 warn "  Search modifiers only allowed at the top level of the query\n" if $self->debug;
 588             } else {
 589                 $struct->new_modifier($1);
 590             }
 591
 592             $last_type = '';
 593         } elsif ($self->modifier_count && /$modifier_as_class_re/) { # found a modifier
 594             warn "Encountered search modifier: $1\n" if $self->debug;
 595
 596             my $mod = $1;
 597
 598             $_ = $';
 599             if (!$struct->top_plan) {
 600                 warn "  Search modifiers only allowed at the top level of the query\n" if $self->debug;
 601             } elsif ($2 =~ /^[ty1]/i) {
 602                 $struct->new_modifier($mod);
 603             }
 604
 605             $last_type = '';
 606         } elsif (/$group_start_re/) { # start of an explicit group
 607             warn "Encountered explicit group start\n" if $self->debug;
 608
 609             my ($substruct, $subremainder) = $self->decompose( $', $current_class, $recursing + 1 );
 610             $struct->add_node( $substruct ) if ($substruct);
 611             $_ = $subremainder;
 612
 613             $last_type = '';
 614         } elsif (/$and_re/) { # ANDed expression
 615             $_ = $';
 616             next if ($last_type eq 'AND');
 617             next if ($last_type eq 'OR');
 618             warn "Encountered AND\n" if $self->debug;
 619
 620             $struct->joiner( '&' );
 621
 622             $last_type = 'AND';
 623         } elsif (/$or_re/) { # ORed expression
 624             $_ = $';
 625             next if ($last_type eq 'AND');
 626             next if ($last_type eq 'OR');
 627             warn "Encountered OR\n" if $self->debug;
 628
 629             $struct->joiner( '|' );
 630
 631             $last_type = 'OR';
 632         } elsif ($self->facet_class_count && /$facet_re/) { # changing current class
 633             warn "Encountered facet: $1$2 => $3\n" if $self->debug;
 634
 635             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 636             my $facet = $2;
 637             my $facet_value = [ split '\s*#\s*', $3 ];
 638             $struct->new_facet( $facet => $facet_value, $negate );
 639             $_ = $';
 640
 641             $last_type = '';
 642         } elsif ($self->search_class_count && /$search_class_re/) { # changing current class
 643
 644             if ($last_type eq 'CLASS') {
 645                 $struct->remove_last_node( $current_class );
 646                 warn "Encountered class change with no searches!\n" if $self->debug;
 647             }
 648
 649             warn "Encountered class change: $1\n" if $self->debug;
 650
 651             $current_class = $struct->classed_node( $1 )->requested_class();
 652             $_ = $';
 653
 654             $last_type = 'CLASS';
 655         } elsif (/^\s*($required_re|$disallowed_re)?"([^"]+)"/) { # phrase, always anded
 656             warn 'Encountered' . ($1 ? " ['$1' modified]" : '') . " phrase: $2\n" if $self->debug;
 657
 658             my $req_ness = $1 || '';
 659             my $phrase = $2;
 660
 661             if (!$phrase_helper) {
 662                 warn "Recursing into decompose with the phrase as a subquery\n" if $self->debug;
 663                 my $after = $';
 664                 my ($substruct, $subremainder) = $self->decompose( qq/$req_ness"$phrase"/, $current_class, $recursing + 1, 1 );
 665                 $struct->add_node( $substruct ) if ($substruct);
 666                 $_ = $after;
 667             } else {
 668                 warn "Directly parsing the phrase subquery\n" if $self->debug;
 669                 $struct->joiner( '&' );
 670
 671                 my $class_node = $struct->classed_node($current_class);
 672
 673                 if ($req_ness eq $pkg->operator('disallowed')) {
 674                     $class_node->add_dummy_atom( node => $class_node );
 675                     $class_node->add_unphrase( $phrase );
 676                     $phrase = '';
 677                     #$phrase =~ s/(^|\s)\b/$1-/g;
 678                 } else {
 679                     $class_node->add_phrase( $phrase );
 680                 }
 681                 $_ = $phrase . $';
 682
 683             }
 684
 685             $last_type = '';
 686
 687 #        } elsif (/^\s*$required_re([^\s"]+)/) { # phrase, always anded
 688 #            warn "Encountered required atom (mini phrase): $1\n" if $self->debug;
 689 #
 690 #            my $phrase = $1;
 691 #
 692 #            my $class_node = $struct->classed_node($current_class);
 693 #            $class_node->add_phrase( $phrase );
 694 #            $_ = $phrase . $';
 695 #            $struct->joiner( '&' );
 696 #
 697 #            $last_type = '';
 698         } elsif (/^\s*([^$group_end\s]+)/o) { # atom
 699             warn "Encountered atom: $1\n" if $self->debug;
 700             warn "Remainder: $'\n" if $self->debug;
 701
 702             my $atom = $1;
 703             my $after = $';
 704
 705             $_ = $after;
 706             $last_type = '';
 707
 708             my $class_node = $struct->classed_node($current_class);
 709
 710             my $prefix = ($atom =~ s/^$disallowed_re//o) ? '!' : '';
 711             my $truncate = ($atom =~ s/\*$//o) ? '*' : '';
 712
 713             if ($atom ne '' and !grep { $atom =~ /^\Q$_\E+$/ } ('&','|','-','+')) { # throw away & and |, not allowed in tsquery, and not really useful anyway
 714 #                $class_node->add_phrase( $atom ) if ($atom =~ s/^$required_re//o);
 715 #                $class_node->add_unphrase( $atom ) if ($prefix eq '!');
 716
 717                 $class_node->add_fts_atom( $atom, suffix => $truncate, prefix => $prefix, node => $class_node );
 718                 $struct->joiner( '&' );
 719             }
 720         }
 721
 722         last unless ($_);
 723
 724     }
 725
 726     $struct = undef if
 727         scalar(@{$struct->query_nodes}) == 0 &&
 728         scalar(@{$struct->filters}) == 0 &&
 729         !$struct->top_plan;
 730
 731     return $struct if !wantarray;
 732     return ($struct, $remainder);
 733 }
 734
 735 sub find_class_index {
 736     my $class = shift;
 737     my $query = shift;
 738
 739     my ($class_part, @field_parts) = split '\|', $class;
 740     $class_part ||= $class;
 741
 742     for my $idx ( 0 .. scalar(@$query) - 1 ) {
 743         next unless ref($$query[$idx]);
 744         return $idx if ( $$query[$idx]{requested_class} && $class eq $$query[$idx]{requested_class} );
 745     }
 746
 747     push(@$query, { classname => $class_part, (@field_parts ? (fields => \@field_parts) : ()), requested_class => $class, ftsquery => [], phrases => [] });
 748     return -1;
 749 }
 750
 751 sub core_limit {
 752     my $self = shift;
 753     my $l = shift;
 754     $self->{core_limit} = $l if ($l);
 755     return $self->{core_limit};
 756 }
 757
 758 sub superpage {
 759     my $self = shift;
 760     my $l = shift;
 761     $self->{superpage} = $l if ($l);
 762     return $self->{superpage};
 763 }
 764
 765 sub superpage_size {
 766     my $self = shift;
 767     my $l = shift;
 768     $self->{superpage_size} = $l if ($l);
 769     return $self->{superpage_size};
 770 }
 771
 772
 773 #-------------------------------
 774 package QueryParser::_util;
 775
 776 # At this level, joiners are always & or |.  This is not
 777 # the external, configurable representation of joiners that
 778 # defaults to # && and ||.
 779 sub is_joiner {
 780     my $str = shift;
 781
 782     return (not ref $str and ($str eq '&' or $str eq '|'));
 783 }
 784
 785 sub default_joiner { '&' }
 786
 787 # 0 for different, 1 for the same.
 788 sub compare_abstract_atoms {
 789     my ($left, $right) = @_;
 790
 791     foreach (qw/prefix suffix content/) {
 792         no warnings;    # undef can stand in for '' here
 793         return 0 unless $left->{$_} eq $right->{$_};
 794     }
 795
 796     return 1;
 797 }
 798
 799 sub fake_abstract_atom_from_phrase {
 800     my ($phrase, $neg) = @_;
 801
 802     my $prefix = '"';
 803     if ($neg) {
 804         $prefix =
 805             $QueryParser::parser_config{QueryParser}{operators}{disallowed} .
 806             $prefix;
 807     }
 808
 809     return {
 810         "type" => "atom", "prefix" => $prefix, "suffix" => '"',
 811         "content" => $phrase
 812     }
 813 }
 814
 815 sub find_arrays_in_abstract {
 816     my ($hash) = @_;
 817
 818     my @arrays;
 819     foreach my $key (keys %$hash) {
 820         if (ref $hash->{$key} eq "ARRAY") {
 821             push @arrays, $hash->{$key};
 822             foreach (@{$hash->{$key}}) {
 823                 push @arrays, find_arrays_in_abstract($_);
 824             }
 825         }
 826     }
 827
 828     return @arrays;
 829 }
 830
 831 #-------------------------------
 832 package QueryParser::Canonicalize;  # not OO
 833
 834 sub _abstract_query2str_filter {
 835     my $f = shift;
 836     my $qpconfig = $parser_config{QueryParser};
 837
 838     return sprintf(
 839         "%s%s(%s)",
 840         $f->{negate} ? $qpconfig->{operators}{disallowed} : "",
 841         $f->{name},
 842         join(",", @{$f->{args}})
 843     );
 844 }
 845
 846 sub _abstract_query2str_modifier {
 847     my $f = shift;
 848     my $qpconfig = $parser_config{QueryParser};
 849
 850     return $qpconfig->{operators}{modifier} . $f;
 851 }
 852
 853 # This should produce an equivalent query to the original, given an
 854 # abstract_query.
 855 sub abstract_query2str_impl {
 856     my ($abstract_query, $depth) = @_;
 857
 858     my $qpconfig = $parser_config{QueryParser};
 859
 860     my $gs = $qpconfig->{operators}{group_start};
 861     my $ge = $qpconfig->{operators}{group_end};
 862     my $and = $qpconfig->{operators}{and};
 863     my $or = $qpconfig->{operators}{or};
 864
 865     my $q = "";
 866     $q .= $gs if $abstract_query->{type} and $abstract_query->{type} eq "query_plan" and $depth;
 867
 868     if (exists $abstract_query->{type}) {
 869         if ($abstract_query->{type} eq 'query_plan') {
 870             $q .= join(" ", map { _abstract_query2str_filter($_) } @{$abstract_query->{filters}}) if
 871                 exists $abstract_query->{filters};
 872             $q .= " ";
 873
 874             $q .= join(" ", map { _abstract_query2str_modifier($_) } @{$abstract_query->{modifiers}}) if
 875                 exists $abstract_query->{modifiers};
 876         } elsif ($abstract_query->{type} eq 'node') {
 877             if ($abstract_query->{alias}) {
 878                 $q .= " " . $abstract_query->{alias};
 879                 $q .= "|$_" foreach @{$abstract_query->{alias_fields}};
 880             } else {
 881                 $q .= " " . $abstract_query->{class};
 882                 $q .= "|$_" foreach @{$abstract_query->{fields}};
 883             }
 884             $q .= ":";
 885         } elsif ($abstract_query->{type} eq 'atom') {
 886             my $prefix = $abstract_query->{prefix} || '';
 887             $prefix = $qpconfig->{operators}{disallowed} if $prefix eq '!';
 888             $q .= $prefix .
 889                 ($abstract_query->{content} || '') .
 890                 ($abstract_query->{suffix} || '');
 891         } elsif ($abstract_query->{type} eq 'facet') {
 892             # facet syntax [ # ] is hardcoded I guess?
 893             my $prefix = $abstract_query->{negate} ? $qpconfig->{operators}{disallowed} : '';
 894             $q .= $prefix . $abstract_query->{name} . "[" .
 895                 join(" # ", @{$abstract_query->{values}}) . "]";
 896         }
 897     }
 898
 899     if (exists $abstract_query->{children}) {
 900         my $op = (keys(%{$abstract_query->{children}}))[0];
 901         $q .= join(
 902             " " . ($op eq '&' ? $and : $or) . " ",
 903             map {
 904                 abstract_query2str_impl($_, $depth + 1)
 905             } @{$abstract_query->{children}{$op}}
 906         );
 907     } elsif ($abstract_query->{'&'} or $abstract_query->{'|'}) {
 908         my $op = (keys(%{$abstract_query}))[0];
 909         $q .= join(
 910             " " . ($op eq '&' ? $and : $or) . " ",
 911             map {
 912                 abstract_query2str_impl($_, $depth + 1)
 913             } @{$abstract_query->{$op}}
 914         );
 915     }
 916     $q .= " ";
 917
 918     $q .= $ge if $abstract_query->{type} and $abstract_query->{type} eq "query_plan" and $depth;
 919
 920     return $q;
 921 }
 922
 923 #-------------------------------
 924 package QueryParser::query_plan;
 925
 926 sub QueryParser {
 927     my $self = shift;
 928     return undef unless ref($self);
 929     return $self->{QueryParser};
 930 }
 931
 932 sub new {
 933     my $pkg = shift;
 934     $pkg = ref($pkg) || $pkg;
 935     my %args = (query => [], joiner => '&', @_);
 936
 937     return bless \%args => $pkg;
 938 }
 939
 940 sub new_node {
 941     my $self = shift;
 942     my $pkg = ref($self) || $self;
 943     my $node = do{$pkg.'::node'}->new( plan => $self, @_ );
 944     $self->add_node( $node );
 945     return $node;
 946 }
 947
 948 sub new_facet {
 949     my $self = shift;
 950     my $pkg = ref($self) || $self;
 951     my $name = shift;
 952     my $args = shift;
 953     my $negate = shift;
 954
 955     my $node = do{$pkg.'::facet'}->new( plan => $self, name => $name, 'values' => $args, negate => $negate );
 956     $self->add_node( $node );
 957
 958     return $node;
 959 }
 960
 961 sub new_filter {
 962     my $self = shift;
 963     my $pkg = ref($self) || $self;
 964     my $name = shift;
 965     my $args = shift;
 966     my $negate = shift;
 967
 968     my $node = do{$pkg.'::filter'}->new( plan => $self, name => $name, args => $args, negate => $negate );
 969     $self->add_filter( $node );
 970
 971     return $node;
 972 }
 973
 974
 975 sub _merge_filters {
 976     my $left_filter = shift;
 977     my $right_filter = shift;
 978     my $join = shift;
 979
 980     return undef unless $left_filter or $right_filter;
 981     return $right_filter unless $left_filter;
 982     return $left_filter unless $right_filter;
 983
 984     my $args = $left_filter->{args} || [];
 985
 986     if ($join eq '|') {
 987         push(@$args, @{$right_filter->{args}});
 988
 989     } else {
 990         # find the intersect values
 991         my %new_vals;
 992         map { $new_vals{$_} = 1 } @{$right_filter->{args} || []};
 993         $args = [ grep { $new_vals{$_} } @$args ];
 994     }
 995
 996     $left_filter->{args} = $args;
 997     return $left_filter;
 998 }
 999
1000 sub collapse_filters {
1001     my $self = shift;
1002     my $name = shift;
1003
1004     # start by merging any filters at this level.
1005     # like-level filters are always ORed together
1006
1007     my $cur_filter;
1008     my @cur_filters = grep {$_->name eq $name } @{ $self->filters };
1009     if (@cur_filters) {
1010         $cur_filter = shift @cur_filters;
1011         my $args = $cur_filter->{args} || [];
1012         $cur_filter = _merge_filters($cur_filter, $_, '|') for @cur_filters;
1013     }
1014
1015     # next gather the collapsed filters from sub-plans and
1016     # merge them with our own
1017
1018     my @subquery = @{$self->{query}};
1019
1020     while (@subquery) {
1021         my $blob = shift @subquery;
1022         shift @subquery; # joiner
1023         next unless $blob->isa('QueryParser::query_plan');
1024         my $sub_filter = $blob->collapse_filters($name);
1025         $cur_filter = _merge_filters($cur_filter, $sub_filter, $self->joiner);
1026     }
1027
1028     if ($self->QueryParser->debug) {
1029         my @args = ($cur_filter and $cur_filter->{args}) ? @{$cur_filter->{args}} : ();
1030         warn "collapse_filters($name) => [@args]\n";
1031     }
1032
1033     return $cur_filter;
1034 }
1035
1036 sub find_filter {
1037     my $self = shift;
1038     my $needle = shift;;
1039     return undef unless ($needle);
1040
1041     my $filter = $self->collapse_filters($needle);
1042
1043     warn "find_filter($needle) => " .
1044         (($filter and $filter->{args}) ? "@{$filter->{args}}" : '[]') . "\n"
1045         if $self->QueryParser->debug;
1046
1047     return $filter ? ($filter) : ();
1048 }
1049
1050 sub find_modifier {
1051     my $self = shift;
1052     my $needle = shift;;
1053     return undef unless ($needle);
1054     return grep { $_->name eq $needle } @{ $self->modifiers };
1055 }
1056
1057 sub new_modifier {
1058     my $self = shift;
1059     my $pkg = ref($self) || $self;
1060     my $name = shift;
1061
1062     my $node = do{$pkg.'::modifier'}->new( $name );
1063     $self->add_modifier( $node );
1064
1065     return $node;
1066 }
1067
1068 sub classed_node {
1069     my $self = shift;
1070     my $requested_class = shift;
1071
1072     my $node;
1073     for my $n (@{$self->{query}}) {
1074         next unless (ref($n) && $n->isa( 'QueryParser::query_plan::node' ));
1075         if ($n->requested_class eq $requested_class) {
1076             $node = $n;
1077             last;
1078         }
1079     }
1080
1081     if (!$node) {
1082         $node = $self->new_node;
1083         $node->requested_class( $requested_class );
1084     }
1085
1086     return $node;
1087 }
1088
1089 sub remove_last_node {
1090     my $self = shift;
1091     my $requested_class = shift;
1092
1093     my $old = pop(@{$self->query_nodes});
1094     pop(@{$self->query_nodes}) if (@{$self->query_nodes});
1095
1096     return $old;
1097 }
1098
1099 sub query_nodes {
1100     my $self = shift;
1101     return $self->{query};
1102 }
1103
1104 sub add_node {
1105     my $self = shift;
1106     my $node = shift;
1107
1108     $self->{query} ||= [];
1109     push(@{$self->{query}}, $self->joiner) if (@{$self->{query}});
1110     push(@{$self->{query}}, $node);
1111
1112     return $self;
1113 }
1114
1115 sub top_plan {
1116     my $self = shift;
1117
1118     return $self->{level} ? 0 : 1;
1119 }
1120
1121 sub plan_level {
1122     my $self = shift;
1123     return $self->{level};
1124 }
1125
1126 sub joiner {
1127     my $self = shift;
1128     my $joiner = shift;
1129
1130     $self->{joiner} = $joiner if ($joiner);
1131     return $self->{joiner};
1132 }
1133
1134 sub modifiers {
1135     my $self = shift;
1136     $self->{modifiers} ||= [];
1137     return $self->{modifiers};
1138 }
1139
1140 sub add_modifier {
1141     my $self = shift;
1142     my $modifier = shift;
1143
1144     $self->{modifiers} ||= [];
1145     $self->{modifiers} = [ grep {$_->name ne $modifier->name} @{$self->{modifiers}} ];
1146
1147     push(@{$self->{modifiers}}, $modifier);
1148
1149     return $self;
1150 }
1151
1152 sub facets {
1153     my $self = shift;
1154     $self->{facets} ||= [];
1155     return $self->{facets};
1156 }
1157
1158 sub add_facet {
1159     my $self = shift;
1160     my $facet = shift;
1161
1162     $self->{facets} ||= [];
1163     $self->{facets} = [ grep {$_->name ne $facet->name} @{$self->{facets}} ];
1164
1165     push(@{$self->{facets}}, $facet);
1166
1167     return $self;
1168 }
1169
1170 sub filters {
1171     my $self = shift;
1172     $self->{filters} ||= [];
1173     return $self->{filters};
1174 }
1175
1176 sub add_filter {
1177     my $self = shift;
1178     my $filter = shift;
1179
1180     $self->{filters} ||= [];
1181
1182     push(@{$self->{filters}}, $filter);
1183
1184     return $self;
1185 }
1186
1187 # %opts supports two options at this time:
1188 #   no_phrases :
1189 #       If true, do not do anything to the phrases and unphrases
1190 #       fields on any discovered nodes.
1191 #   with_config :
1192 #       If true, also return the query parser config as part of the blob.
1193 #       This will get set back to 0 before recursion to avoid repetition.
1194 sub to_abstract_query {
1195     my $self = shift;
1196     my %opts = @_;
1197
1198     my $pkg = ref $self->QueryParser || $self->QueryParser;
1199
1200     my $abstract_query = {
1201         type => "query_plan",
1202         filters => [map { $_->to_abstract_query } @{$self->filters}],
1203         modifiers => [map { $_->to_abstract_query } @{$self->modifiers}]
1204     };
1205
1206     if ($opts{with_config}) {
1207         $opts{with_config} = 0;
1208         $abstract_query->{config} = $QueryParser::parser_config{$pkg};
1209     }
1210
1211     my $kids = [];
1212
1213     for my $qnode (@{$self->query_nodes}) {
1214         # Remember: qnode can be a joiner string, a node, or another query_plan
1215
1216         if (QueryParser::_util::is_joiner($qnode)) {
1217             if ($abstract_query->{children}) {
1218                 my $open_joiner = (keys(%{$abstract_query->{children}}))[0];
1219                 next if $open_joiner eq $qnode;
1220
1221                 my $oldroot = $abstract_query->{children};
1222                 $kids = [$oldroot];
1223                 $abstract_query->{children} = {$qnode => $kids};
1224             } else {
1225                 $abstract_query->{children} = {$qnode => $kids};
1226             }
1227         } else {
1228             push @$kids, $qnode->to_abstract_query(%opts);
1229         }
1230     }
1231
1232     $abstract_query->{children} ||= { QueryParser::_util::default_joiner() => $kids };
1233     return $abstract_query;
1234 }
1235
1236
1237 #-------------------------------
1238 package QueryParser::query_plan::node;
1239 use Data::Dumper;
1240 $Data::Dumper::Indent = 0;
1241
1242 sub new {
1243     my $pkg = shift;
1244     $pkg = ref($pkg) || $pkg;
1245     my %args = @_;
1246
1247     return bless \%args => $pkg;
1248 }
1249
1250 sub new_atom {
1251     my $self = shift;
1252     my $pkg = ref($self) || $self;
1253     return do{$pkg.'::atom'}->new( @_ );
1254 }
1255
1256 sub requested_class { # also split into classname, fields and alias
1257     my $self = shift;
1258     my $class = shift;
1259
1260     if ($class) {
1261         my @afields;
1262         my (undef, $alias) = split '#', $class;
1263         if ($alias) {
1264             $class =~ s/#[^|]+//;
1265             ($alias, @afields) = split '\|', $alias;
1266         }
1267
1268         my @fields = @afields;
1269         my ($class_part, @field_parts) = split '\|', $class;
1270         for my $f (@field_parts) {
1271              push(@fields, $f) unless (grep { $f eq $_ } @fields);
1272         }
1273
1274         $class_part ||= $class;
1275
1276         $self->{requested_class} = $class;
1277         $self->{alias} = $alias if $alias;
1278         $self->{alias_fields} = \@afields if $alias;
1279         $self->{classname} = $class_part;
1280         $self->{fields} = \@fields;
1281     }
1282
1283     return $self->{requested_class};
1284 }
1285
1286 sub plan {
1287     my $self = shift;
1288     my $plan = shift;
1289
1290     $self->{plan} = $plan if ($plan);
1291     return $self->{plan};
1292 }
1293
1294 sub alias {
1295     my $self = shift;
1296     my $alias = shift;
1297
1298     $self->{alias} = $alias if ($alias);
1299     return $self->{alias};
1300 }
1301
1302 sub alias_fields {
1303     my $self = shift;
1304     my $alias = shift;
1305
1306     $self->{alias_fields} = $alias if ($alias);
1307     return $self->{alias_fields};
1308 }
1309
1310 sub classname {
1311     my $self = shift;
1312     my $class = shift;
1313
1314     $self->{classname} = $class if ($class);
1315     return $self->{classname};
1316 }
1317
1318 sub fields {
1319     my $self = shift;
1320     my @fields = @_;
1321
1322     $self->{fields} ||= [];
1323     $self->{fields} = \@fields if (@fields);
1324     return $self->{fields};
1325 }
1326
1327 sub phrases {
1328     my $self = shift;
1329     my @phrases = @_;
1330
1331     $self->{phrases} ||= [];
1332     $self->{phrases} = \@phrases if (@phrases);
1333     return $self->{phrases};
1334 }
1335
1336 sub unphrases {
1337     my $self = shift;
1338     my @phrases = @_;
1339
1340     $self->{unphrases} ||= [];
1341     $self->{unphrases} = \@phrases if (@phrases);
1342     return $self->{unphrases};
1343 }
1344
1345 sub add_phrase {
1346     my $self = shift;
1347     my $phrase = shift;
1348
1349     push(@{$self->phrases}, $phrase);
1350
1351     return $self;
1352 }
1353
1354 sub add_unphrase {
1355     my $self = shift;
1356     my $phrase = shift;
1357
1358     push(@{$self->unphrases}, $phrase);
1359
1360     return $self;
1361 }
1362
1363 sub query_atoms {
1364     my $self = shift;
1365     my @query_atoms = @_;
1366
1367     $self->{query_atoms} ||= [];
1368     $self->{query_atoms} = \@query_atoms if (@query_atoms);
1369     return $self->{query_atoms};
1370 }
1371
1372 sub add_fts_atom {
1373     my $self = shift;
1374     my $atom = shift;
1375
1376     if (!ref($atom)) {
1377         my $content = $atom;
1378         my @parts = @_;
1379
1380         $atom = $self->new_atom( content => $content, @parts );
1381     }
1382
1383     push(@{$self->query_atoms}, $self->plan->joiner) if (@{$self->query_atoms});
1384     push(@{$self->query_atoms}, $atom);
1385
1386     return $self;
1387 }
1388
1389 sub add_dummy_atom {
1390     my $self = shift;
1391     my @parts = @_;
1392
1393     my $atom = $self->new_atom( @parts, dummy => 1 );
1394
1395     push(@{$self->query_atoms}, $self->plan->joiner) if (@{$self->query_atoms});
1396     push(@{$self->query_atoms}, $atom);
1397
1398     return $self;
1399 }
1400
1401 # This will find up to one occurence of @$short_list within @$long_list, and
1402 # replace it with the single atom $replacement.
1403 sub replace_phrase_in_abstract_query {
1404     my ($self, $short_list, $long_list, $replacement) = @_;
1405
1406     my $success = 0;
1407     my @already = ();
1408     my $goal = scalar @$short_list;
1409
1410     for (my $i = 0; $i < scalar (@$long_list); $i++) {
1411         my $right = $long_list->[$i];
1412
1413         if (QueryParser::_util::compare_abstract_atoms(
1414             $short_list->[scalar @already], $right
1415         )) {
1416             push @already, $i;
1417         } elsif (scalar @already) {
1418             @already = ();
1419             next;
1420         }
1421
1422         if (scalar @already == $goal) {
1423             splice @$long_list, $already[0], scalar(@already), $replacement;
1424             $success = 1;
1425             last;
1426         }
1427     }
1428
1429     return $success;
1430 }
1431
1432 sub to_abstract_query {
1433     my $self = shift;
1434     my %opts = @_;
1435
1436     my $pkg = ref $self->plan->QueryParser || $self->plan->QueryParser;
1437
1438     my $abstract_query = {
1439         "type" => "node",
1440         "alias" => $self->alias,
1441         "alias_fields" => $self->alias_fields,
1442         "class" => $self->classname,
1443         "fields" => $self->fields
1444     };
1445
1446     my $kids = [];
1447
1448     for my $qatom (@{$self->query_atoms}) {
1449         if (QueryParser::_util::is_joiner($qatom)) {
1450             if ($abstract_query->{children}) {
1451                 my $open_joiner = (keys(%{$abstract_query->{children}}))[0];
1452                 next if $open_joiner eq $qatom;
1453
1454                 my $oldroot = $abstract_query->{children};
1455                 $kids = [$oldroot];
1456                 $abstract_query->{children} = {$qatom => $kids};
1457             } else {
1458                 $abstract_query->{children} = {$qatom => $kids};
1459             }
1460         } else {
1461             push @$kids, $qatom->to_abstract_query;
1462         }
1463     }
1464
1465     if ($self->{phrases} and not $opts{no_phrases}) {
1466         for my $phrase (@{$self->{phrases}}) {
1467             # Phrases appear duplication in a real QP tree, and we don't want
1468             # that duplication in our abstract query.  So for all our phrases,
1469             # break them into atoms as QP would, and remove any matching
1470             # sequences of atoms from our abstract query.
1471
1472             my $tmptree = $self->{plan}->{QueryParser}->new(query => '"'.$phrase.'"')->parse->parse_tree;
1473             if ($tmptree) {
1474                 # For a well-behaved phrase, we should now have only one node
1475                 # in the $tmptree query plan, and that node should have an
1476                 # orderly list of atoms and joiners.
1477
1478                 if ($tmptree->{query} and scalar(@{$tmptree->{query}}) == 1) {
1479                     my $tmplist;
1480
1481                     eval {
1482                         $tmplist = $tmptree->{query}->[0]->to_abstract_query(
1483                             no_phrases => 1
1484                         )->{children}->{'&'}->[0]->{children}->{'&'};
1485                     };
1486                     next if $@;
1487
1488                     foreach (
1489                         QueryParser::_util::find_arrays_in_abstract($abstract_query->{children})
1490                     ) {
1491                         last if $self->replace_phrase_in_abstract_query(
1492                             $tmplist,
1493                             $_,
1494                             QueryParser::_util::fake_abstract_atom_from_phrase($phrase)
1495                         );
1496                     }
1497                 }
1498             }
1499         }
1500     }
1501
1502     # Do the same as the preceding block for unphrases (negated phrases).
1503     if ($self->{unphrases} and not $opts{no_phrases}) {
1504         for my $phrase (@{$self->{unphrases}}) {
1505             my $tmptree = $self->{plan}->{QueryParser}->new(
1506                 query => $QueryParser::parser_config{$pkg}{operators}{disallowed}.
1507                     '"' . $phrase . '"'
1508             )->parse->parse_tree;
1509
1510             if ($tmptree) {
1511                 if ($tmptree->{query} and scalar(@{$tmptree->{query}}) == 1) {
1512                     my $tmplist;
1513
1514                     eval {
1515                         $tmplist = $tmptree->{query}->[0]->to_abstract_query(
1516                             no_phrases => 1
1517                         )->{children}->{'&'}->[0]->{children}->{'&'};
1518                     };
1519                     next if $@;
1520
1521                     foreach (
1522                         QueryParser::_util::find_arrays_in_abstract($abstract_query->{children})
1523                     ) {
1524                         last if $self->replace_phrase_in_abstract_query(
1525                             $tmplist,
1526                             $_,
1527                             QueryParser::_util::fake_abstract_atom_from_phrase($phrase, 1)
1528                         );
1529                     }
1530                 }
1531             }
1532         }
1533     }
1534
1535     $abstract_query->{children} ||= { QueryParser::_util::default_joiner() => $kids };
1536     return $abstract_query;
1537 }
1538
1539 #-------------------------------
1540 package QueryParser::query_plan::node::atom;
1541
1542 sub new {
1543     my $pkg = shift;
1544     $pkg = ref($pkg) || $pkg;
1545     my %args = @_;
1546
1547     return bless \%args => $pkg;
1548 }
1549
1550 sub node {
1551     my $self = shift;
1552     return undef unless (ref $self);
1553     return $self->{node};
1554 }
1555
1556 sub content {
1557     my $self = shift;
1558     return undef unless (ref $self);
1559     return $self->{content};
1560 }
1561
1562 sub prefix {
1563     my $self = shift;
1564     return undef unless (ref $self);
1565     return $self->{prefix};
1566 }
1567
1568 sub suffix {
1569     my $self = shift;
1570     return undef unless (ref $self);
1571     return $self->{suffix};
1572 }
1573
1574 sub to_abstract_query {
1575     my ($self) = @_;
1576
1577     return {
1578         (map { $_ => $self->$_ } qw/prefix suffix content/),
1579         "type" => "atom"
1580     };
1581 }
1582 #-------------------------------
1583 package QueryParser::query_plan::filter;
1584
1585 sub new {
1586     my $pkg = shift;
1587     $pkg = ref($pkg) || $pkg;
1588     my %args = @_;
1589
1590     return bless \%args => $pkg;
1591 }
1592
1593 sub plan {
1594     my $self = shift;
1595     return $self->{plan};
1596 }
1597
1598 sub name {
1599     my $self = shift;
1600     return $self->{name};
1601 }
1602
1603 sub negate {
1604     my $self = shift;
1605     return $self->{negate};
1606 }
1607
1608 sub args {
1609     my $self = shift;
1610     return $self->{args};
1611 }
1612
1613 sub to_abstract_query {
1614     my ($self) = @_;
1615
1616     return {
1617         map { $_ => $self->$_ } qw/name negate args/
1618     };
1619 }
1620
1621 #-------------------------------
1622 package QueryParser::query_plan::facet;
1623
1624 sub new {
1625     my $pkg = shift;
1626     $pkg = ref($pkg) || $pkg;
1627     my %args = @_;
1628
1629     return bless \%args => $pkg;
1630 }
1631
1632 sub plan {
1633     my $self = shift;
1634     return $self->{plan};
1635 }
1636
1637 sub name {
1638     my $self = shift;
1639     return $self->{name};
1640 }
1641
1642 sub negate {
1643     my $self = shift;
1644     return $self->{negate};
1645 }
1646
1647 sub values {
1648     my $self = shift;
1649     return $self->{'values'};
1650 }
1651
1652 sub to_abstract_query {
1653     my ($self) = @_;
1654
1655     return {
1656         (map { $_ => $self->$_ } qw/name negate values/),
1657         "type" => "facet"
1658     };
1659 }
1660
1661 #-------------------------------
1662 package QueryParser::query_plan::modifier;
1663
1664 sub new {
1665     my $pkg = shift;
1666     $pkg = ref($pkg) || $pkg;
1667     my $modifier = shift;
1668     my $negate = shift;
1669
1670     return bless { name => $modifier, negate => $negate } => $pkg;
1671 }
1672
1673 sub name {
1674     my $self = shift;
1675     return $self->{name};
1676 }
1677
1678 sub negate {
1679     my $self = shift;
1680     return $self->{negate};
1681 }
1682
1683 sub to_abstract_query {
1684     my ($self) = @_;
1685
1686     return $self->name;
1687 }
1688 1;
1689