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