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 filter_callbacks {
  67     my $class = shift;
  68     $class = ref($class) || $class;
  69
  70     $parser_config{$class}{filter_callbacks} ||= {};
  71     return $parser_config{$class}{filter_callbacks};
  72 }
  73
  74 sub modifiers {
  75     my $class = shift;
  76     $class = ref($class) || $class;
  77
  78     $parser_config{$class}{modifiers} ||= [];
  79     return $parser_config{$class}{modifiers};
  80 }
  81
  82 sub new {
  83     my $class = shift;
  84     $class = ref($class) || $class;
  85
  86     my %opts = @_;
  87
  88     my $self = bless {} => $class;
  89
  90     for my $o (keys %{QueryParser->operators}) {
  91         $class->operator($o => QueryParser->operator($o)) unless ($class->operator($o));
  92     }
  93
  94     for my $opt ( keys %opts) {
  95         $self->$opt( $opts{$opt} ) if ($self->can($opt));
  96     }
  97
  98     return $self;
  99 }
 100
 101 sub new_plan {
 102     my $self = shift;
 103     my $pkg = ref($self) || $self;
 104     return do{$pkg.'::query_plan'}->new( QueryParser => $self, @_ );
 105 }
 106
 107 sub add_search_filter {
 108     my $pkg = shift;
 109     $pkg = ref($pkg) || $pkg;
 110     my $filter = shift;
 111     my $callback = shift;
 112
 113     return $filter if (grep { $_ eq $filter } @{$pkg->filters});
 114     push @{$pkg->filters}, $filter;
 115     $pkg->filter_callbacks->{$filter} = $callback if ($callback);
 116     return $filter;
 117 }
 118
 119 sub add_search_modifier {
 120     my $pkg = shift;
 121     $pkg = ref($pkg) || $pkg;
 122     my $modifier = shift;
 123
 124     return $modifier if (grep { $_ eq $modifier } @{$pkg->modifiers});
 125     push @{$pkg->modifiers}, $modifier;
 126     return $modifier;
 127 }
 128
 129 sub add_facet_class {
 130     my $pkg = shift;
 131     $pkg = ref($pkg) || $pkg;
 132     my $class = shift;
 133
 134     return $class if (grep { $_ eq $class } @{$pkg->facet_classes});
 135
 136     push @{$pkg->facet_classes}, $class;
 137     $pkg->facet_fields->{$class} = [];
 138
 139     return $class;
 140 }
 141
 142 sub add_search_class {
 143     my $pkg = shift;
 144     $pkg = ref($pkg) || $pkg;
 145     my $class = shift;
 146
 147     return $class if (grep { $_ eq $class } @{$pkg->search_classes});
 148
 149     push @{$pkg->search_classes}, $class;
 150     $pkg->search_fields->{$class} = [];
 151     $pkg->default_search_class( $pkg->search_classes->[0] ) if (@{$pkg->search_classes} == 1);
 152
 153     return $class;
 154 }
 155
 156 sub operator {
 157     my $class = shift;
 158     $class = ref($class) || $class;
 159     my $opname = shift;
 160     my $op = shift;
 161
 162     return undef unless ($opname);
 163
 164     $parser_config{$class}{operators} ||= {};
 165     $parser_config{$class}{operators}{$opname} = $op if ($op);
 166
 167     return $parser_config{$class}{operators}{$opname};
 168 }
 169
 170 sub facet_classes {
 171     my $class = shift;
 172     $class = ref($class) || $class;
 173     my $classes = shift;
 174
 175     $parser_config{$class}{facet_classes} ||= [];
 176     $parser_config{$class}{facet_classes} = $classes if (ref($classes) && @$classes);
 177     return $parser_config{$class}{facet_classes};
 178 }
 179
 180 sub search_classes {
 181     my $class = shift;
 182     $class = ref($class) || $class;
 183     my $classes = shift;
 184
 185     $parser_config{$class}{classes} ||= [];
 186     $parser_config{$class}{classes} = $classes if (ref($classes) && @$classes);
 187     return $parser_config{$class}{classes};
 188 }
 189
 190 sub add_query_normalizer {
 191     my $pkg = shift;
 192     $pkg = ref($pkg) || $pkg;
 193     my $class = shift;
 194     my $field = shift;
 195     my $func = shift;
 196     my $params = shift || [];
 197
 198     # do not add if function AND params are identical to existing member
 199     return $func if (grep {
 200         $_->{function} eq $func and
 201         OpenSRF::Utils::JSON->perl2JSON($_->{params}) eq OpenSRF::Utils::JSON->perl2JSON($params)
 202     } @{$pkg->query_normalizers->{$class}->{$field}});
 203
 204     push(@{$pkg->query_normalizers->{$class}->{$field}}, { function => $func, params => $params });
 205
 206     return $func;
 207 }
 208
 209 sub query_normalizers {
 210     my $pkg = shift;
 211     $pkg = ref($pkg) || $pkg;
 212
 213     my $class = shift;
 214     my $field = shift;
 215
 216     $parser_config{$pkg}{normalizers} ||= {};
 217     if ($class) {
 218         if ($field) {
 219             $parser_config{$pkg}{normalizers}{$class}{$field} ||= [];
 220             return $parser_config{$pkg}{normalizers}{$class}{$field};
 221         } else {
 222             return $parser_config{$pkg}{normalizers}{$class};
 223         }
 224     }
 225
 226     return $parser_config{$pkg}{normalizers};
 227 }
 228
 229 sub add_filter_normalizer {
 230     my $pkg = shift;
 231     $pkg = ref($pkg) || $pkg;
 232     my $filter = shift;
 233     my $func = shift;
 234     my $params = shift || [];
 235
 236     return $func if (grep { $_ eq $func } @{$pkg->filter_normalizers->{$filter}});
 237
 238     push(@{$pkg->filter_normalizers->{$filter}}, { function => $func, params => $params });
 239
 240     return $func;
 241 }
 242
 243 sub filter_normalizers {
 244     my $pkg = shift;
 245     $pkg = ref($pkg) || $pkg;
 246
 247     my $filter = shift;
 248
 249     $parser_config{$pkg}{filter_normalizers} ||= {};
 250     if ($filter) {
 251         $parser_config{$pkg}{filter_normalizers}{$filter} ||= [];
 252         return $parser_config{$pkg}{filter_normalizers}{$filter};
 253     }
 254
 255     return $parser_config{$pkg}{filter_normalizers};
 256 }
 257
 258 sub default_search_class {
 259     my $pkg = shift;
 260     $pkg = ref($pkg) || $pkg;
 261     my $class = shift;
 262     $QueryParser::parser_config{$pkg}{default_class} = $pkg->add_search_class( $class ) if $class;
 263
 264     return $QueryParser::parser_config{$pkg}{default_class};
 265 }
 266
 267 sub remove_facet_class {
 268     my $pkg = shift;
 269     $pkg = ref($pkg) || $pkg;
 270     my $class = shift;
 271
 272     return $class if (!grep { $_ eq $class } @{$pkg->facet_classes});
 273
 274     $pkg->facet_classes( [ grep { $_ ne $class } @{$pkg->facet_classes} ] );
 275     delete $QueryParser::parser_config{$pkg}{facet_fields}{$class};
 276
 277     return $class;
 278 }
 279
 280 sub remove_search_class {
 281     my $pkg = shift;
 282     $pkg = ref($pkg) || $pkg;
 283     my $class = shift;
 284
 285     return $class if (!grep { $_ eq $class } @{$pkg->search_classes});
 286
 287     $pkg->search_classes( [ grep { $_ ne $class } @{$pkg->search_classes} ] );
 288     delete $QueryParser::parser_config{$pkg}{fields}{$class};
 289
 290     return $class;
 291 }
 292
 293 sub add_facet_field {
 294     my $pkg = shift;
 295     $pkg = ref($pkg) || $pkg;
 296     my $class = shift;
 297     my $field = shift;
 298
 299     $pkg->add_facet_class( $class );
 300
 301     return { $class => $field }  if (grep { $_ eq $field } @{$pkg->facet_fields->{$class}});
 302
 303     push @{$pkg->facet_fields->{$class}}, $field;
 304
 305     return { $class => $field };
 306 }
 307
 308 sub facet_fields {
 309     my $class = shift;
 310     $class = ref($class) || $class;
 311
 312     $parser_config{$class}{facet_fields} ||= {};
 313     return $parser_config{$class}{facet_fields};
 314 }
 315
 316 sub add_search_field {
 317     my $pkg = shift;
 318     $pkg = ref($pkg) || $pkg;
 319     my $class = shift;
 320     my $field = shift;
 321
 322     $pkg->add_search_class( $class );
 323
 324     return { $class => $field }  if (grep { $_ eq $field } @{$pkg->search_fields->{$class}});
 325
 326     push @{$pkg->search_fields->{$class}}, $field;
 327
 328     return { $class => $field };
 329 }
 330
 331 sub search_fields {
 332     my $class = shift;
 333     $class = ref($class) || $class;
 334
 335     $parser_config{$class}{fields} ||= {};
 336     return $parser_config{$class}{fields};
 337 }
 338
 339 sub add_search_class_alias {
 340     my $pkg = shift;
 341     $pkg = ref($pkg) || $pkg;
 342     my $class = shift;
 343     my $alias = shift;
 344
 345     $pkg->add_search_class( $class );
 346
 347     return { $class => $alias }  if (grep { $_ eq $alias } @{$pkg->search_class_aliases->{$class}});
 348
 349     push @{$pkg->search_class_aliases->{$class}}, $alias;
 350
 351     return { $class => $alias };
 352 }
 353
 354 sub search_class_aliases {
 355     my $class = shift;
 356     $class = ref($class) || $class;
 357
 358     $parser_config{$class}{class_map} ||= {};
 359     return $parser_config{$class}{class_map};
 360 }
 361
 362 sub add_search_field_alias {
 363     my $pkg = shift;
 364     $pkg = ref($pkg) || $pkg;
 365     my $class = shift;
 366     my $field = shift;
 367     my $alias = shift;
 368
 369     return { $class => { $field => $alias } }  if (grep { $_ eq $alias } @{$pkg->search_field_aliases->{$class}{$field}});
 370
 371     push @{$pkg->search_field_aliases->{$class}{$field}}, $alias;
 372
 373     return { $class => { $field => $alias } };
 374 }
 375
 376 sub search_field_aliases {
 377     my $class = shift;
 378     $class = ref($class) || $class;
 379
 380     $parser_config{$class}{field_alias_map} ||= {};
 381     return $parser_config{$class}{field_alias_map};
 382 }
 383
 384 sub remove_facet_field {
 385     my $pkg = shift;
 386     $pkg = ref($pkg) || $pkg;
 387     my $class = shift;
 388     my $field = shift;
 389
 390     return { $class => $field }  if (!$pkg->facet_fields->{$class} || !grep { $_ eq $field } @{$pkg->facet_fields->{$class}});
 391
 392     $pkg->facet_fields->{$class} = [ grep { $_ ne $field } @{$pkg->facet_fields->{$class}} ];
 393
 394     return { $class => $field };
 395 }
 396
 397 sub remove_search_field {
 398     my $pkg = shift;
 399     $pkg = ref($pkg) || $pkg;
 400     my $class = shift;
 401     my $field = shift;
 402
 403     return { $class => $field }  if (!$pkg->search_fields->{$class} || !grep { $_ eq $field } @{$pkg->search_fields->{$class}});
 404
 405     $pkg->search_fields->{$class} = [ grep { $_ ne $field } @{$pkg->search_fields->{$class}} ];
 406
 407     return { $class => $field };
 408 }
 409
 410 sub remove_search_field_alias {
 411     my $pkg = shift;
 412     $pkg = ref($pkg) || $pkg;
 413     my $class = shift;
 414     my $field = shift;
 415     my $alias = shift;
 416
 417     return { $class => { $field => $alias } }  if (!$pkg->search_field_aliases->{$class}{$field} || !grep { $_ eq $alias } @{$pkg->search_field_aliases->{$class}{$field}});
 418
 419     $pkg->search_field_aliases->{$class}{$field} = [ grep { $_ ne $alias } @{$pkg->search_field_aliases->{$class}{$field}} ];
 420
 421     return { $class => { $field => $alias } };
 422 }
 423
 424 sub remove_search_class_alias {
 425     my $pkg = shift;
 426     $pkg = ref($pkg) || $pkg;
 427     my $class = shift;
 428     my $alias = shift;
 429
 430     return { $class => $alias }  if (!$pkg->search_class_aliases->{$class} || !grep { $_ eq $alias } @{$pkg->search_class_aliases->{$class}});
 431
 432     $pkg->search_class_aliases->{$class} = [ grep { $_ ne $alias } @{$pkg->search_class_aliases->{$class}} ];
 433
 434     return { $class => $alias };
 435 }
 436
 437 sub debug {
 438     my $self = shift;
 439     my $q = shift;
 440     $self->{_debug} = $q if (defined $q);
 441     return $self->{_debug};
 442 }
 443
 444 sub query {
 445     my $self = shift;
 446     my $q = shift;
 447     $self->{_query} = $q if (defined $q);
 448     return $self->{_query};
 449 }
 450
 451 sub parse_tree {
 452     my $self = shift;
 453     my $q = shift;
 454     $self->{_parse_tree} = $q if (defined $q);
 455     return $self->{_parse_tree};
 456 }
 457
 458 sub parse {
 459     my $self = shift;
 460     my $pkg = ref($self) || $self;
 461     warn " ** parse package is $pkg\n" if $self->debug;
 462     $self->parse_tree(
 463         $self->decompose(
 464             $self->query( shift() )
 465         )
 466     );
 467
 468     return $self;
 469 }
 470
 471 sub decompose {
 472     my $self = shift;
 473     my $pkg = ref($self) || $self;
 474
 475     warn " ** decompose package is $pkg\n" if $self->debug;
 476
 477     $_ = shift;
 478     my $current_class = shift || $self->default_search_class;
 479
 480     my $recursing = shift || 0;
 481     my $phrase_helper = shift || 0;
 482
 483     # Build the search class+field uber-regexp
 484     my $search_class_re = '^\s*(';
 485     my $first_class = 1;
 486
 487     my %seen_classes;
 488     for my $class ( keys %{$pkg->search_field_aliases} ) {
 489         warn " *** ... Looking for search fields in $class\n" if $self->debug;
 490
 491         for my $field ( keys %{$pkg->search_field_aliases->{$class}} ) {
 492             warn " *** ... Looking for aliases of $field\n" if $self->debug;
 493
 494             for my $alias ( @{$pkg->search_field_aliases->{$class}{$field}} ) {
 495                 my $aliasr = qr/$alias/;
 496                 s/(^|\s+)$aliasr\|/$1$class\|$field#$alias\|/g;
 497                 s/(^|\s+)$aliasr[:=]/$1$class\|$field#$alias:/g;
 498                 warn " *** Rewriting: $alias ($aliasr) as $class\|$field\n" if $self->debug;
 499             }
 500         }
 501
 502         $search_class_re .= '|' unless ($first_class);
 503         $first_class = 0;
 504         $search_class_re .= $class . '(?:[|#][^:|]+)*';
 505         $seen_classes{$class} = 1;
 506     }
 507
 508     for my $class ( keys %{$pkg->search_class_aliases} ) {
 509
 510         for my $alias ( @{$pkg->search_class_aliases->{$class}} ) {
 511             my $aliasr = qr/$alias/;
 512             s/(^|[^|])\b$aliasr\|/$1$class#$alias\|/g;
 513             s/(^|[^|])\b$aliasr[:=]/$1$class#$alias:/g;
 514             warn " *** Rewriting: $alias ($aliasr) as $class\n" if $self->debug;
 515         }
 516
 517         if (!$seen_classes{$class}) {
 518             $search_class_re .= '|' unless ($first_class);
 519             $first_class = 0;
 520
 521             $search_class_re .= $class . '(?:[|#][^:|]+)*';
 522             $seen_classes{$class} = 1;
 523         }
 524     }
 525     $search_class_re .= '):';
 526
 527     warn " ** Rewritten query: $_\n" if $self->debug;
 528     warn " ** Search class RE: $search_class_re\n" if $self->debug;
 529
 530     my $required_re = $pkg->operator('required');
 531     $required_re = qr/\Q$required_re\E/;
 532
 533     my $disallowed_re = $pkg->operator('disallowed');
 534     $disallowed_re = qr/\Q$disallowed_re\E/;
 535
 536     my $and_re = $pkg->operator('and');
 537     $and_re = qr/^\s*\Q$and_re\E/;
 538
 539     my $or_re = $pkg->operator('or');
 540     $or_re = qr/^\s*\Q$or_re\E/;
 541
 542     my $group_start_re = $pkg->operator('group_start');
 543     $group_start_re = qr/^\s*\Q$group_start_re\E/;
 544
 545     my $group_end = $pkg->operator('group_end');
 546     my $group_end_re = qr/^\s*\Q$group_end\E/;
 547
 548     my $modifier_tag_re = $pkg->operator('modifier');
 549     $modifier_tag_re = qr/^\s*\Q$modifier_tag_re\E/;
 550
 551
 552     # Build the filter and modifier uber-regexps
 553     my $facet_re = '^\s*(-?)((?:' . join( '|', @{$pkg->facet_classes}) . ')(?:\|\w+)*)\[(.+?)\]';
 554     warn " ** Facet RE: $facet_re\n" if $self->debug;
 555
 556     my $filter_re = '^\s*(-?)(' . join( '|', @{$pkg->filters}) . ')\(([^()]+)\)';
 557     my $filter_as_class_re = '^\s*(-?)(' . join( '|', @{$pkg->filters}) . '):\s*(\S+)';
 558
 559     my $modifier_re = '^\s*'.$modifier_tag_re.'(' . join( '|', @{$pkg->modifiers}) . ')\b';
 560     my $modifier_as_class_re = '^\s*(' . join( '|', @{$pkg->modifiers}) . '):\s*(\S+)';
 561
 562     my $struct = $self->new_plan( level => $recursing );
 563     my $remainder = '';
 564
 565     my $last_type = '';
 566     while (!$remainder) {
 567         if (/^\s*$/) { # end of an explicit group
 568             last;
 569         } elsif (/$group_end_re/) { # end of an explicit group
 570             warn "Encountered explicit group end\n" if $self->debug;
 571
 572             $_ = $';
 573             $remainder = $struct->top_plan ? '' : $';
 574
 575             $last_type = '';
 576         } elsif ($self->filter_count && /$filter_re/) { # found a filter
 577             warn "Encountered search filter: $1$2 set to $3\n" if $self->debug;
 578
 579             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 580             $_ = $';
 581
 582             my $filter = $2;
 583             my $params = [ split '[,]+', $3 ];
 584
 585             if ($pkg->filter_callbacks->{$filter}) {
 586                 my $replacement = $pkg->filter_callbacks->{$filter}->($self, $struct, $filter, $params, $negate);
 587                 $_ = "$replacement $_" if ($replacement);
 588             } else {
 589                 $struct->new_filter( $filter => $params, $negate );
 590             }
 591
 592
 593             $last_type = '';
 594         } elsif ($self->filter_count && /$filter_as_class_re/) { # found a filter
 595             warn "Encountered search filter: $1$2 set to $3\n" if $self->debug;
 596
 597             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 598             $_ = $';
 599
 600             my $filter = $2;
 601             my $params = [ split '[,]+', $3 ];
 602
 603             if ($pkg->filter_callbacks->{$filter}) {
 604                 my $replacement = $pkg->filter_callbacks->{$filter}->($self, $struct, $filter, $params, $negate);
 605                 $_ = "$replacement $_" if ($replacement);
 606             } else {
 607                 $struct->new_filter( $filter => $params, $negate );
 608             }
 609
 610             $last_type = '';
 611         } elsif ($self->modifier_count && /$modifier_re/) { # found a modifier
 612             warn "Encountered search modifier: $1\n" if $self->debug;
 613
 614             $_ = $';
 615             if (!$struct->top_plan) {
 616                 warn "  Search modifiers only allowed at the top level of the query\n" if $self->debug;
 617             } else {
 618                 $struct->new_modifier($1);
 619             }
 620
 621             $last_type = '';
 622         } elsif ($self->modifier_count && /$modifier_as_class_re/) { # found a modifier
 623             warn "Encountered search modifier: $1\n" if $self->debug;
 624
 625             my $mod = $1;
 626
 627             $_ = $';
 628             if (!$struct->top_plan) {
 629                 warn "  Search modifiers only allowed at the top level of the query\n" if $self->debug;
 630             } elsif ($2 =~ /^[ty1]/i) {
 631                 $struct->new_modifier($mod);
 632             }
 633
 634             $last_type = '';
 635         } elsif (/$group_start_re/) { # start of an explicit group
 636             warn "Encountered explicit group start\n" if $self->debug;
 637
 638             my ($substruct, $subremainder) = $self->decompose( $', $current_class, $recursing + 1 );
 639             $struct->add_node( $substruct ) if ($substruct);
 640             $_ = $subremainder;
 641
 642             $last_type = '';
 643         } elsif (/$and_re/) { # ANDed expression
 644             $_ = $';
 645             next if ($last_type eq 'AND');
 646             next if ($last_type eq 'OR');
 647             warn "Encountered AND\n" if $self->debug;
 648
 649             $struct->joiner( '&' );
 650
 651             $last_type = 'AND';
 652         } elsif (/$or_re/) { # ORed expression
 653             $_ = $';
 654             next if ($last_type eq 'AND');
 655             next if ($last_type eq 'OR');
 656             warn "Encountered OR\n" if $self->debug;
 657
 658             $struct->joiner( '|' );
 659
 660             $last_type = 'OR';
 661         } elsif ($self->facet_class_count && /$facet_re/) { # changing current class
 662             warn "Encountered facet: $1$2 => $3\n" if $self->debug;
 663
 664             my $negate = ($1 eq $pkg->operator('disallowed')) ? 1 : 0;
 665             my $facet = $2;
 666             my $facet_value = [ split '\s*#\s*', $3 ];
 667             $struct->new_facet( $facet => $facet_value, $negate );
 668             $_ = $';
 669
 670             $last_type = '';
 671         } elsif ($self->search_class_count && /$search_class_re/) { # changing current class
 672
 673             if ($last_type eq 'CLASS') {
 674                 $struct->remove_last_node( $current_class );
 675                 warn "Encountered class change with no searches!\n" if $self->debug;
 676             }
 677
 678             warn "Encountered class change: $1\n" if $self->debug;
 679
 680             $current_class = $struct->classed_node( $1 )->requested_class();
 681             $_ = $';
 682
 683             $last_type = 'CLASS';
 684         } elsif (/^\s*($required_re|$disallowed_re)?"([^"]+)"/) { # phrase, always anded
 685             warn 'Encountered' . ($1 ? " ['$1' modified]" : '') . " phrase: $2\n" if $self->debug;
 686
 687             my $req_ness = $1 || '';
 688             my $phrase = $2;
 689
 690             if (!$phrase_helper) {
 691                 warn "Recursing into decompose with the phrase as a subquery\n" if $self->debug;
 692                 my $after = $';
 693                 my ($substruct, $subremainder) = $self->decompose( qq/$req_ness"$phrase"/, $current_class, $recursing + 1, 1 );
 694                 $struct->add_node( $substruct ) if ($substruct);
 695                 $_ = $after;
 696             } else {
 697                 warn "Directly parsing the phrase subquery\n" if $self->debug;
 698                 $struct->joiner( '&' );
 699
 700                 my $class_node = $struct->classed_node($current_class);
 701
 702                 if ($req_ness eq $pkg->operator('disallowed')) {
 703                     $class_node->add_dummy_atom( node => $class_node );
 704                     $class_node->add_unphrase( $phrase );
 705                     $phrase = '';
 706                     #$phrase =~ s/(^|\s)\b/$1-/g;
 707                 } else {
 708                     $class_node->add_phrase( $phrase );
 709                 }
 710                 $_ = $phrase . $';
 711
 712             }
 713
 714             $last_type = '';
 715
 716 #        } elsif (/^\s*$required_re([^\s"]+)/) { # phrase, always anded
 717 #            warn "Encountered required atom (mini phrase): $1\n" if $self->debug;
 718 #
 719 #            my $phrase = $1;
 720 #
 721 #            my $class_node = $struct->classed_node($current_class);
 722 #            $class_node->add_phrase( $phrase );
 723 #            $_ = $phrase . $';
 724 #            $struct->joiner( '&' );
 725 #
 726 #            $last_type = '';
 727         } elsif (/^\s*([^$group_end\s]+)/o) { # atom
 728             warn "Encountered atom: $1\n" if $self->debug;
 729             warn "Remainder: $'\n" if $self->debug;
 730
 731             my $atom = $1;
 732             my $after = $';
 733
 734             $_ = $after;
 735             $last_type = '';
 736
 737             my $class_node = $struct->classed_node($current_class);
 738
 739             my $prefix = ($atom =~ s/^$disallowed_re//o) ? '!' : '';
 740             my $truncate = ($atom =~ s/\*$//o) ? '*' : '';
 741
 742             if ($atom ne '' and !grep { $atom =~ /^\Q$_\E+$/ } ('&','|','-','+')) { # throw away & and |, not allowed in tsquery, and not really useful anyway
 743 #                $class_node->add_phrase( $atom ) if ($atom =~ s/^$required_re//o);
 744 #                $class_node->add_unphrase( $atom ) if ($prefix eq '!');
 745
 746                 $class_node->add_fts_atom( $atom, suffix => $truncate, prefix => $prefix, node => $class_node );
 747                 $struct->joiner( '&' );
 748             }
 749         }
 750
 751         last unless ($_);
 752
 753     }
 754
 755     $struct = undef if
 756         scalar(@{$struct->query_nodes}) == 0 &&
 757         scalar(@{$struct->filters}) == 0 &&
 758         !$struct->top_plan;
 759
 760     return $struct if !wantarray;
 761     return ($struct, $remainder);
 762 }
 763
 764 sub find_class_index {
 765     my $class = shift;
 766     my $query = shift;
 767
 768     my ($class_part, @field_parts) = split '\|', $class;
 769     $class_part ||= $class;
 770
 771     for my $idx ( 0 .. scalar(@$query) - 1 ) {
 772         next unless ref($$query[$idx]);
 773         return $idx if ( $$query[$idx]{requested_class} && $class eq $$query[$idx]{requested_class} );
 774     }
 775
 776     push(@$query, { classname => $class_part, (@field_parts ? (fields => \@field_parts) : ()), requested_class => $class, ftsquery => [], phrases => [] });
 777     return -1;
 778 }
 779
 780 sub core_limit {
 781     my $self = shift;
 782     my $l = shift;
 783     $self->{core_limit} = $l if ($l);
 784     return $self->{core_limit};
 785 }
 786
 787 sub superpage {
 788     my $self = shift;
 789     my $l = shift;
 790     $self->{superpage} = $l if ($l);
 791     return $self->{superpage};
 792 }
 793
 794 sub superpage_size {
 795     my $self = shift;
 796     my $l = shift;
 797     $self->{superpage_size} = $l if ($l);
 798     return $self->{superpage_size};
 799 }
 800
 801
 802 #-------------------------------
 803 package QueryParser::_util;
 804
 805 # At this level, joiners are always & or |.  This is not
 806 # the external, configurable representation of joiners that
 807 # defaults to # && and ||.
 808 sub is_joiner {
 809     my $str = shift;
 810
 811     return (not ref $str and ($str eq '&' or $str eq '|'));
 812 }
 813
 814 sub default_joiner { '&' }
 815
 816 # 0 for different, 1 for the same.
 817 sub compare_abstract_atoms {
 818     my ($left, $right) = @_;
 819
 820     foreach (qw/prefix suffix content/) {
 821         no warnings;    # undef can stand in for '' here
 822         return 0 unless $left->{$_} eq $right->{$_};
 823     }
 824
 825     return 1;
 826 }
 827
 828 sub fake_abstract_atom_from_phrase {
 829     my ($phrase, $neg) = @_;
 830
 831     my $prefix = '"';
 832     if ($neg) {
 833         $prefix =
 834             $QueryParser::parser_config{QueryParser}{operators}{disallowed} .
 835             $prefix;
 836     }
 837
 838     return {
 839         "type" => "atom", "prefix" => $prefix, "suffix" => '"',
 840         "content" => $phrase
 841     }
 842 }
 843
 844 sub find_arrays_in_abstract {
 845     my ($hash) = @_;
 846
 847     my @arrays;
 848     foreach my $key (keys %$hash) {
 849         if (ref $hash->{$key} eq "ARRAY") {
 850             push @arrays, $hash->{$key};
 851             foreach (@{$hash->{$key}}) {
 852                 push @arrays, find_arrays_in_abstract($_);
 853             }
 854         }
 855     }
 856
 857     return @arrays;
 858 }
 859
 860 #-------------------------------
 861 package QueryParser::Canonicalize;  # not OO
 862
 863 sub _abstract_query2str_filter {
 864     my $f = shift;
 865     my $qpconfig = $parser_config{QueryParser};
 866
 867     return sprintf(
 868         "%s%s(%s)",
 869         $f->{negate} ? $qpconfig->{operators}{disallowed} : "",
 870         $f->{name},
 871         join(",", @{$f->{args}})
 872     );
 873 }
 874
 875 sub _abstract_query2str_modifier {
 876     my $f = shift;
 877     my $qpconfig = $parser_config{QueryParser};
 878
 879     return $qpconfig->{operators}{modifier} . $f;
 880 }
 881
 882 # This should produce an equivalent query to the original, given an
 883 # abstract_query.
 884 sub abstract_query2str_impl {
 885     my ($abstract_query, $depth) = @_;
 886
 887     my $qpconfig = $parser_config{QueryParser};
 888
 889     my $gs = $qpconfig->{operators}{group_start};
 890     my $ge = $qpconfig->{operators}{group_end};
 891     my $and = $qpconfig->{operators}{and};
 892     my $or = $qpconfig->{operators}{or};
 893
 894     my $q = "";
 895     $q .= $gs if $abstract_query->{type} and $abstract_query->{type} eq "query_plan" and $depth;
 896
 897     if (exists $abstract_query->{type}) {
 898         if ($abstract_query->{type} eq 'query_plan') {
 899             $q .= join(" ", map { _abstract_query2str_filter($_) } @{$abstract_query->{filters}}) if
 900                 exists $abstract_query->{filters};
 901             $q .= " ";
 902
 903             $q .= join(" ", map { _abstract_query2str_modifier($_) } @{$abstract_query->{modifiers}}) if
 904                 exists $abstract_query->{modifiers};
 905         } elsif ($abstract_query->{type} eq 'node') {
 906             if ($abstract_query->{alias}) {
 907                 $q .= " " . $abstract_query->{alias};
 908                 $q .= "|$_" foreach @{$abstract_query->{alias_fields}};
 909             } else {
 910                 $q .= " " . $abstract_query->{class};
 911                 $q .= "|$_" foreach @{$abstract_query->{fields}};
 912             }
 913             $q .= ":";
 914         } elsif ($abstract_query->{type} eq 'atom') {
 915             my $prefix = $abstract_query->{prefix} || '';
 916             $prefix = $qpconfig->{operators}{disallowed} if $prefix eq '!';
 917             $q .= $prefix .
 918                 ($abstract_query->{content} || '') .
 919                 ($abstract_query->{suffix} || '');
 920         } elsif ($abstract_query->{type} eq 'facet') {
 921             # facet syntax [ # ] is hardcoded I guess?
 922             my $prefix = $abstract_query->{negate} ? $qpconfig->{operators}{disallowed} : '';
 923             $q .= $prefix . $abstract_query->{name} . "[" .
 924                 join(" # ", @{$abstract_query->{values}}) . "]";
 925         }
 926     }
 927
 928     if (exists $abstract_query->{children}) {
 929         my $op = (keys(%{$abstract_query->{children}}))[0];
 930         $q .= join(
 931             " " . ($op eq '&' ? $and : $or) . " ",
 932             map {
 933                 abstract_query2str_impl($_, $depth + 1)
 934             } @{$abstract_query->{children}{$op}}
 935         );
 936     } elsif ($abstract_query->{'&'} or $abstract_query->{'|'}) {
 937         my $op = (keys(%{$abstract_query}))[0];
 938         $q .= join(
 939             " " . ($op eq '&' ? $and : $or) . " ",
 940             map {
 941                 abstract_query2str_impl($_, $depth + 1)
 942             } @{$abstract_query->{$op}}
 943         );
 944     }
 945     $q .= " ";
 946
 947     $q .= $ge if $abstract_query->{type} and $abstract_query->{type} eq "query_plan" and $depth;
 948
 949     return $q;
 950 }
 951
 952 #-------------------------------
 953 package QueryParser::query_plan;
 954
 955 sub QueryParser {
 956     my $self = shift;
 957     return undef unless ref($self);
 958     return $self->{QueryParser};
 959 }
 960
 961 sub new {
 962     my $pkg = shift;
 963     $pkg = ref($pkg) || $pkg;
 964     my %args = (query => [], joiner => '&', @_);
 965
 966     return bless \%args => $pkg;
 967 }
 968
 969 sub new_node {
 970     my $self = shift;
 971     my $pkg = ref($self) || $self;
 972     my $node = do{$pkg.'::node'}->new( plan => $self, @_ );
 973     $self->add_node( $node );
 974     return $node;
 975 }
 976
 977 sub new_facet {
 978     my $self = shift;
 979     my $pkg = ref($self) || $self;
 980     my $name = shift;
 981     my $args = shift;
 982     my $negate = shift;
 983
 984     my $node = do{$pkg.'::facet'}->new( plan => $self, name => $name, 'values' => $args, negate => $negate );
 985     $self->add_node( $node );
 986
 987     return $node;
 988 }
 989
 990 sub new_filter {
 991     my $self = shift;
 992     my $pkg = ref($self) || $self;
 993     my $name = shift;
 994     my $args = shift;
 995     my $negate = shift;
 996
 997     my $node = do{$pkg.'::filter'}->new( plan => $self, name => $name, args => $args, negate => $negate );
 998     $self->add_filter( $node );
 999
1000     return $node;
1001 }
1002
1003
1004 sub _merge_filters {
1005     my $left_filter = shift;
1006     my $right_filter = shift;
1007     my $join = shift;
1008
1009     return undef unless $left_filter or $right_filter;
1010     return $right_filter unless $left_filter;
1011     return $left_filter unless $right_filter;
1012
1013     my $args = $left_filter->{args} || [];
1014
1015     if ($join eq '|') {
1016         push(@$args, @{$right_filter->{args}});
1017
1018     } else {
1019         # find the intersect values
1020         my %new_vals;
1021         map { $new_vals{$_} = 1 } @{$right_filter->{args} || []};
1022         $args = [ grep { $new_vals{$_} } @$args ];
1023     }
1024
1025     $left_filter->{args} = $args;
1026     return $left_filter;
1027 }
1028
1029 sub collapse_filters {
1030     my $self = shift;
1031     my $name = shift;
1032
1033     # start by merging any filters at this level.
1034     # like-level filters are always ORed together
1035
1036     my $cur_filter;
1037     my @cur_filters = grep {$_->name eq $name } @{ $self->filters };
1038     if (@cur_filters) {
1039         $cur_filter = shift @cur_filters;
1040         my $args = $cur_filter->{args} || [];
1041         $cur_filter = _merge_filters($cur_filter, $_, '|') for @cur_filters;
1042     }
1043
1044     # next gather the collapsed filters from sub-plans and
1045     # merge them with our own
1046
1047     my @subquery = @{$self->{query}};
1048
1049     while (@subquery) {
1050         my $blob = shift @subquery;
1051         shift @subquery; # joiner
1052         next unless $blob->isa('QueryParser::query_plan');
1053         my $sub_filter = $blob->collapse_filters($name);
1054         $cur_filter = _merge_filters($cur_filter, $sub_filter, $self->joiner);
1055     }
1056
1057     if ($self->QueryParser->debug) {
1058         my @args = ($cur_filter and $cur_filter->{args}) ? @{$cur_filter->{args}} : ();
1059         warn "collapse_filters($name) => [@args]\n";
1060     }
1061
1062     return $cur_filter;
1063 }
1064
1065 sub find_filter {
1066     my $self = shift;
1067     my $needle = shift;;
1068     return undef unless ($needle);
1069
1070     my $filter = $self->collapse_filters($needle);
1071
1072     warn "find_filter($needle) => " .
1073         (($filter and $filter->{args}) ? "@{$filter->{args}}" : '[]') . "\n"
1074         if $self->QueryParser->debug;
1075
1076     return $filter ? ($filter) : ();
1077 }
1078
1079 sub find_modifier {
1080     my $self = shift;
1081     my $needle = shift;;
1082     return undef unless ($needle);
1083     return grep { $_->name eq $needle } @{ $self->modifiers };
1084 }
1085
1086 sub new_modifier {
1087     my $self = shift;
1088     my $pkg = ref($self) || $self;
1089     my $name = shift;
1090
1091     my $node = do{$pkg.'::modifier'}->new( $name );
1092     $self->add_modifier( $node );
1093
1094     return $node;
1095 }
1096
1097 sub classed_node {
1098     my $self = shift;
1099     my $requested_class = shift;
1100
1101     my $node;
1102     for my $n (@{$self->{query}}) {
1103         next unless (ref($n) && $n->isa( 'QueryParser::query_plan::node' ));
1104         if ($n->requested_class eq $requested_class) {
1105             $node = $n;
1106             last;
1107         }
1108     }
1109
1110     if (!$node) {
1111         $node = $self->new_node;
1112         $node->requested_class( $requested_class );
1113     }
1114
1115     return $node;
1116 }
1117
1118 sub remove_last_node {
1119     my $self = shift;
1120     my $requested_class = shift;
1121
1122     my $old = pop(@{$self->query_nodes});
1123     pop(@{$self->query_nodes}) if (@{$self->query_nodes});
1124
1125     return $old;
1126 }
1127
1128 sub query_nodes {
1129     my $self = shift;
1130     return $self->{query};
1131 }
1132
1133 sub add_node {
1134     my $self = shift;
1135     my $node = shift;
1136
1137     $self->{query} ||= [];
1138     push(@{$self->{query}}, $self->joiner) if (@{$self->{query}});
1139     push(@{$self->{query}}, $node);
1140
1141     return $self;
1142 }
1143
1144 sub top_plan {
1145     my $self = shift;
1146
1147     return $self->{level} ? 0 : 1;
1148 }
1149
1150 sub plan_level {
1151     my $self = shift;
1152     return $self->{level};
1153 }
1154
1155 sub joiner {
1156     my $self = shift;
1157     my $joiner = shift;
1158
1159     $self->{joiner} = $joiner if ($joiner);
1160     return $self->{joiner};
1161 }
1162
1163 sub modifiers {
1164     my $self = shift;
1165     $self->{modifiers} ||= [];
1166     return $self->{modifiers};
1167 }
1168
1169 sub add_modifier {
1170     my $self = shift;
1171     my $modifier = shift;
1172
1173     $self->{modifiers} ||= [];
1174     $self->{modifiers} = [ grep {$_->name ne $modifier->name} @{$self->{modifiers}} ];
1175
1176     push(@{$self->{modifiers}}, $modifier);
1177
1178     return $self;
1179 }
1180
1181 sub facets {
1182     my $self = shift;
1183     $self->{facets} ||= [];
1184     return $self->{facets};
1185 }
1186
1187 sub add_facet {
1188     my $self = shift;
1189     my $facet = shift;
1190
1191     $self->{facets} ||= [];
1192     $self->{facets} = [ grep {$_->name ne $facet->name} @{$self->{facets}} ];
1193
1194     push(@{$self->{facets}}, $facet);
1195
1196     return $self;
1197 }
1198
1199 sub filters {
1200     my $self = shift;
1201     $self->{filters} ||= [];
1202     return $self->{filters};
1203 }
1204
1205 sub add_filter {
1206     my $self = shift;
1207     my $filter = shift;
1208
1209     $self->{filters} ||= [];
1210
1211     push(@{$self->{filters}}, $filter);
1212
1213     return $self;
1214 }
1215
1216 # %opts supports two options at this time:
1217 #   no_phrases :
1218 #       If true, do not do anything to the phrases and unphrases
1219 #       fields on any discovered nodes.
1220 #   with_config :
1221 #       If true, also return the query parser config as part of the blob.
1222 #       This will get set back to 0 before recursion to avoid repetition.
1223 sub to_abstract_query {
1224     my $self = shift;
1225     my %opts = @_;
1226
1227     my $pkg = ref $self->QueryParser || $self->QueryParser;
1228
1229     my $abstract_query = {
1230         type => "query_plan",
1231         filters => [map { $_->to_abstract_query } @{$self->filters}],
1232         modifiers => [map { $_->to_abstract_query } @{$self->modifiers}]
1233     };
1234
1235     if ($opts{with_config}) {
1236         $opts{with_config} = 0;
1237         $abstract_query->{config} = $QueryParser::parser_config{$pkg};
1238     }
1239
1240     my $kids = [];
1241
1242     for my $qnode (@{$self->query_nodes}) {
1243         # Remember: qnode can be a joiner string, a node, or another query_plan
1244
1245         if (QueryParser::_util::is_joiner($qnode)) {
1246             if ($abstract_query->{children}) {
1247                 my $open_joiner = (keys(%{$abstract_query->{children}}))[0];
1248                 next if $open_joiner eq $qnode;
1249
1250                 my $oldroot = $abstract_query->{children};
1251                 $kids = [$oldroot];
1252                 $abstract_query->{children} = {$qnode => $kids};
1253             } else {
1254                 $abstract_query->{children} = {$qnode => $kids};
1255             }
1256         } else {
1257             push @$kids, $qnode->to_abstract_query(%opts);
1258         }
1259     }
1260
1261     $abstract_query->{children} ||= { QueryParser::_util::default_joiner() => $kids };
1262     return $abstract_query;
1263 }
1264
1265
1266 #-------------------------------
1267 package QueryParser::query_plan::node;
1268 use Data::Dumper;
1269 $Data::Dumper::Indent = 0;
1270
1271 sub new {
1272     my $pkg = shift;
1273     $pkg = ref($pkg) || $pkg;
1274     my %args = @_;
1275
1276     return bless \%args => $pkg;
1277 }
1278
1279 sub new_atom {
1280     my $self = shift;
1281     my $pkg = ref($self) || $self;
1282     return do{$pkg.'::atom'}->new( @_ );
1283 }
1284
1285 sub requested_class { # also split into classname, fields and alias
1286     my $self = shift;
1287     my $class = shift;
1288
1289     if ($class) {
1290         my @afields;
1291         my (undef, $alias) = split '#', $class;
1292         if ($alias) {
1293             $class =~ s/#[^|]+//;
1294             ($alias, @afields) = split '\|', $alias;
1295         }
1296
1297         my @fields = @afields;
1298         my ($class_part, @field_parts) = split '\|', $class;
1299         for my $f (@field_parts) {
1300              push(@fields, $f) unless (grep { $f eq $_ } @fields);
1301         }
1302
1303         $class_part ||= $class;
1304
1305         $self->{requested_class} = $class;
1306         $self->{alias} = $alias if $alias;
1307         $self->{alias_fields} = \@afields if $alias;
1308         $self->{classname} = $class_part;
1309         $self->{fields} = \@fields;
1310     }
1311
1312     return $self->{requested_class};
1313 }
1314
1315 sub plan {
1316     my $self = shift;
1317     my $plan = shift;
1318
1319     $self->{plan} = $plan if ($plan);
1320     return $self->{plan};
1321 }
1322
1323 sub alias {
1324     my $self = shift;
1325     my $alias = shift;
1326
1327     $self->{alias} = $alias if ($alias);
1328     return $self->{alias};
1329 }
1330
1331 sub alias_fields {
1332     my $self = shift;
1333     my $alias = shift;
1334
1335     $self->{alias_fields} = $alias if ($alias);
1336     return $self->{alias_fields};
1337 }
1338
1339 sub classname {
1340     my $self = shift;
1341     my $class = shift;
1342
1343     $self->{classname} = $class if ($class);
1344     return $self->{classname};
1345 }
1346
1347 sub fields {
1348     my $self = shift;
1349     my @fields = @_;
1350
1351     $self->{fields} ||= [];
1352     $self->{fields} = \@fields if (@fields);
1353     return $self->{fields};
1354 }
1355
1356 sub phrases {
1357     my $self = shift;
1358     my @phrases = @_;
1359
1360     $self->{phrases} ||= [];
1361     $self->{phrases} = \@phrases if (@phrases);
1362     return $self->{phrases};
1363 }
1364
1365 sub unphrases {
1366     my $self = shift;
1367     my @phrases = @_;
1368
1369     $self->{unphrases} ||= [];
1370     $self->{unphrases} = \@phrases if (@phrases);
1371     return $self->{unphrases};
1372 }
1373
1374 sub add_phrase {
1375     my $self = shift;
1376     my $phrase = shift;
1377
1378     push(@{$self->phrases}, $phrase);
1379
1380     return $self;
1381 }
1382
1383 sub add_unphrase {
1384     my $self = shift;
1385     my $phrase = shift;
1386
1387     push(@{$self->unphrases}, $phrase);
1388
1389     return $self;
1390 }
1391
1392 sub query_atoms {
1393     my $self = shift;
1394     my @query_atoms = @_;
1395
1396     $self->{query_atoms} ||= [];
1397     $self->{query_atoms} = \@query_atoms if (@query_atoms);
1398     return $self->{query_atoms};
1399 }
1400
1401 sub add_fts_atom {
1402     my $self = shift;
1403     my $atom = shift;
1404
1405     if (!ref($atom)) {
1406         my $content = $atom;
1407         my @parts = @_;
1408
1409         $atom = $self->new_atom( content => $content, @parts );
1410     }
1411
1412     push(@{$self->query_atoms}, $self->plan->joiner) if (@{$self->query_atoms});
1413     push(@{$self->query_atoms}, $atom);
1414
1415     return $self;
1416 }
1417
1418 sub add_dummy_atom {
1419     my $self = shift;
1420     my @parts = @_;
1421
1422     my $atom = $self->new_atom( @parts, dummy => 1 );
1423
1424     push(@{$self->query_atoms}, $self->plan->joiner) if (@{$self->query_atoms});
1425     push(@{$self->query_atoms}, $atom);
1426
1427     return $self;
1428 }
1429
1430 # This will find up to one occurence of @$short_list within @$long_list, and
1431 # replace it with the single atom $replacement.
1432 sub replace_phrase_in_abstract_query {
1433     my ($self, $short_list, $long_list, $replacement) = @_;
1434
1435     my $success = 0;
1436     my @already = ();
1437     my $goal = scalar @$short_list;
1438
1439     for (my $i = 0; $i < scalar (@$long_list); $i++) {
1440         my $right = $long_list->[$i];
1441
1442         if (QueryParser::_util::compare_abstract_atoms(
1443             $short_list->[scalar @already], $right
1444         )) {
1445             push @already, $i;
1446         } elsif (scalar @already) {
1447             @already = ();
1448             next;
1449         }
1450
1451         if (scalar @already == $goal) {
1452             splice @$long_list, $already[0], scalar(@already), $replacement;
1453             $success = 1;
1454             last;
1455         }
1456     }
1457
1458     return $success;
1459 }
1460
1461 sub to_abstract_query {
1462     my $self = shift;
1463     my %opts = @_;
1464
1465     my $pkg = ref $self->plan->QueryParser || $self->plan->QueryParser;
1466
1467     my $abstract_query = {
1468         "type" => "node",
1469         "alias" => $self->alias,
1470         "alias_fields" => $self->alias_fields,
1471         "class" => $self->classname,
1472         "fields" => $self->fields
1473     };
1474
1475     my $kids = [];
1476
1477     for my $qatom (@{$self->query_atoms}) {
1478         if (QueryParser::_util::is_joiner($qatom)) {
1479             if ($abstract_query->{children}) {
1480                 my $open_joiner = (keys(%{$abstract_query->{children}}))[0];
1481                 next if $open_joiner eq $qatom;
1482
1483                 my $oldroot = $abstract_query->{children};
1484                 $kids = [$oldroot];
1485                 $abstract_query->{children} = {$qatom => $kids};
1486             } else {
1487                 $abstract_query->{children} = {$qatom => $kids};
1488             }
1489         } else {
1490             push @$kids, $qatom->to_abstract_query;
1491         }
1492     }
1493
1494     if ($self->{phrases} and not $opts{no_phrases}) {
1495         for my $phrase (@{$self->{phrases}}) {
1496             # Phrases appear duplication in a real QP tree, and we don't want
1497             # that duplication in our abstract query.  So for all our phrases,
1498             # break them into atoms as QP would, and remove any matching
1499             # sequences of atoms from our abstract query.
1500
1501             my $tmptree = $self->{plan}->{QueryParser}->new(query => '"'.$phrase.'"')->parse->parse_tree;
1502             if ($tmptree) {
1503                 # For a well-behaved phrase, we should now have only one node
1504                 # in the $tmptree query plan, and that node should have an
1505                 # orderly list of atoms and joiners.
1506
1507                 if ($tmptree->{query} and scalar(@{$tmptree->{query}}) == 1) {
1508                     my $tmplist;
1509
1510                     eval {
1511                         $tmplist = $tmptree->{query}->[0]->to_abstract_query(
1512                             no_phrases => 1
1513                         )->{children}->{'&'}->[0]->{children}->{'&'};
1514                     };
1515                     next if $@;
1516
1517                     foreach (
1518                         QueryParser::_util::find_arrays_in_abstract($abstract_query->{children})
1519                     ) {
1520                         last if $self->replace_phrase_in_abstract_query(
1521                             $tmplist,
1522                             $_,
1523                             QueryParser::_util::fake_abstract_atom_from_phrase($phrase)
1524                         );
1525                     }
1526                 }
1527             }
1528         }
1529     }
1530
1531     # Do the same as the preceding block for unphrases (negated phrases).
1532     if ($self->{unphrases} and not $opts{no_phrases}) {
1533         for my $phrase (@{$self->{unphrases}}) {
1534             my $tmptree = $self->{plan}->{QueryParser}->new(
1535                 query => $QueryParser::parser_config{$pkg}{operators}{disallowed}.
1536                     '"' . $phrase . '"'
1537             )->parse->parse_tree;
1538
1539             if ($tmptree) {
1540                 if ($tmptree->{query} and scalar(@{$tmptree->{query}}) == 1) {
1541                     my $tmplist;
1542
1543                     eval {
1544                         $tmplist = $tmptree->{query}->[0]->to_abstract_query(
1545                             no_phrases => 1
1546                         )->{children}->{'&'}->[0]->{children}->{'&'};
1547                     };
1548                     next if $@;
1549
1550                     foreach (
1551                         QueryParser::_util::find_arrays_in_abstract($abstract_query->{children})
1552                     ) {
1553                         last if $self->replace_phrase_in_abstract_query(
1554                             $tmplist,
1555                             $_,
1556                             QueryParser::_util::fake_abstract_atom_from_phrase($phrase, 1)
1557                         );
1558                     }
1559                 }
1560             }
1561         }
1562     }
1563
1564     $abstract_query->{children} ||= { QueryParser::_util::default_joiner() => $kids };
1565     return $abstract_query;
1566 }
1567
1568 #-------------------------------
1569 package QueryParser::query_plan::node::atom;
1570
1571 sub new {
1572     my $pkg = shift;
1573     $pkg = ref($pkg) || $pkg;
1574     my %args = @_;
1575
1576     return bless \%args => $pkg;
1577 }
1578
1579 sub node {
1580     my $self = shift;
1581     return undef unless (ref $self);
1582     return $self->{node};
1583 }
1584
1585 sub content {
1586     my $self = shift;
1587     return undef unless (ref $self);
1588     return $self->{content};
1589 }
1590
1591 sub prefix {
1592     my $self = shift;
1593     return undef unless (ref $self);
1594     return $self->{prefix};
1595 }
1596
1597 sub suffix {
1598     my $self = shift;
1599     return undef unless (ref $self);
1600     return $self->{suffix};
1601 }
1602
1603 sub to_abstract_query {
1604     my ($self) = @_;
1605
1606     return {
1607         (map { $_ => $self->$_ } qw/prefix suffix content/),
1608         "type" => "atom"
1609     };
1610 }
1611 #-------------------------------
1612 package QueryParser::query_plan::filter;
1613
1614 sub new {
1615     my $pkg = shift;
1616     $pkg = ref($pkg) || $pkg;
1617     my %args = @_;
1618
1619     return bless \%args => $pkg;
1620 }
1621
1622 sub plan {
1623     my $self = shift;
1624     return $self->{plan};
1625 }
1626
1627 sub name {
1628     my $self = shift;
1629     return $self->{name};
1630 }
1631
1632 sub negate {
1633     my $self = shift;
1634     return $self->{negate};
1635 }
1636
1637 sub args {
1638     my $self = shift;
1639     return $self->{args};
1640 }
1641
1642 sub to_abstract_query {
1643     my ($self) = @_;
1644
1645     return {
1646         map { $_ => $self->$_ } qw/name negate args/
1647     };
1648 }
1649
1650 #-------------------------------
1651 package QueryParser::query_plan::facet;
1652
1653 sub new {
1654     my $pkg = shift;
1655     $pkg = ref($pkg) || $pkg;
1656     my %args = @_;
1657
1658     return bless \%args => $pkg;
1659 }
1660
1661 sub plan {
1662     my $self = shift;
1663     return $self->{plan};
1664 }
1665
1666 sub name {
1667     my $self = shift;
1668     return $self->{name};
1669 }
1670
1671 sub negate {
1672     my $self = shift;
1673     return $self->{negate};
1674 }
1675
1676 sub values {
1677     my $self = shift;
1678     return $self->{'values'};
1679 }
1680
1681 sub to_abstract_query {
1682     my ($self) = @_;
1683
1684     return {
1685         (map { $_ => $self->$_ } qw/name negate values/),
1686         "type" => "facet"
1687     };
1688 }
1689
1690 #-------------------------------
1691 package QueryParser::query_plan::modifier;
1692
1693 sub new {
1694     my $pkg = shift;
1695     $pkg = ref($pkg) || $pkg;
1696     my $modifier = shift;
1697     my $negate = shift;
1698
1699     return bless { name => $modifier, negate => $negate } => $pkg;
1700 }
1701
1702 sub name {
1703     my $self = shift;
1704     return $self->{name};
1705 }
1706
1707 sub negate {
1708     my $self = shift;
1709     return $self->{negate};
1710 }
1711
1712 sub to_abstract_query {
1713     my ($self) = @_;
1714
1715     return $self->name;
1716 }
1717 1;
1718