wait/trunk/waisquery.y

%{
#                              -*- Mode: Perl -*- 
# waisquery.y -- 
# ITIID           : $ITI$ $Header $__Header$
# Author          : Ulrich Pfeifer
# Created On      : Fri Sep 13 15:54:19 1996
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Sun Nov 22 18:44:28 1998
# Language        : CPerl
# Update Count    : 129
# Status          : Unknown, Use with caution!
# 
# Copyright (c) 1996-1997, Ulrich Pfeifer
# 

package WAIT::Query::Wais;
use WAIT::Query::Base;
use Carp;
use strict;
use vars qw($WORD $PHONIX $SOUNDEX $ASSIGN $FLOAT $OR $AND $NOT $PROX_ORDERED
            $PROX_UNORDERED $PROX_ATLEAST
            $yylval $yyval $YYTABLESIZE $Table
            %TOKEN);
my %VERBOSE ;
no strict 'vars';
%}
%token    WORD
%token    PHONIX SOUNDEX ASSIGN FLOAT
%left     OR
%left     AND
%left     NOT
%nonassoc PROX_ORDERED PROX_UNORDERED PROX_ATLEAST
%%
query           : expression
                ;

or              : %prec OR 
                | OR 
                ;

expression      : term
                | expression or term { $$ = $$->merge($3); }
                ;

term            : factor
                | term AND factor {$$ = new WAIT::Query::and $1, $3;}
                | term NOT factor {$$ = new WAIT::Query::not $1, $3;}
                ;

factor          : unit
                | unit PROX_ORDERED unit
                | unit PROX_UNORDERED unit
                | PROX_ATLEAST unit
                ;

unit            : w_unit 
                | '(' expression ')' { $$ = $2; }
                | WORD '=' {enter($1);} '(' s_expression ')'
                  {leave($1); $$ = $5; }
                | WORD '=' {enter($1);}  w_unit {leave($1); $$ = $4; }
                | WORD {enter($1);} '<' WORD
                       {$$ = intervall(undef, $4); leave($1);}
                | WORD {enter($1);} '>' WORD
                       {$$ = intervall($4, undef); leave($1);}
                | WORD {enter($1);} '[' WORD ',' WORD ']'
                       {$$ = intervall($4, $6); leave($1);}
                ;
                ;
phonsound       : PHONIX  
                | SOUNDEX 
                ;
s_expression    : s_term 
                | s_expression or s_term { $$ = $$->merge($3); }
                ;

s_term          : s_factor 
                | s_term AND s_factor {$$ = new WAIT::Query::and $1, $3;}
                | s_term NOT s_factor {$$ = new WAIT::Query::not $1, $3;}
                ;

s_factor        : s_unit
                | s_unit PROX_ORDERED s_unit
                | s_unit PROX_UNORDERED s_unit
                | PROX_ATLEAST s_unit
                ;

s_unit          : w_unit
                | '(' s_expression ')' { $$ = $2; }
                ;
a_unit          : WORD { $$ = plain($1); }
                | phonsound WORD { $$ = plain($2); }
                ;
w_unit          : a_unit 
                | a_unit ASSIGN FLOAT
%%
use strict;
sub yyerror {
  warn "yyerror: @_ $.\n";
}

for (qw(and or not phonix soundex)) {
  my $e = sprintf '$WAIT::Query::Wais::TOKEN{$_} = $%s', uc($_);
  eval $e;
  die $@ if $@ ne '';
  $VERBOSE{$TOKEN{$_}} = $_;
}
$VERBOSE{$WORD} = 'WORD';
my $KEY = join('|', keys %TOKEN);

my $line;

sub yylex1 {
  print "=>$line\n";
  my $token = yylex1();
  my $verbose;
  my $val = (defined $yylval)?",$yylval":'';
  if ($token < 256) {
    $verbose = "'".chr($token)."'";
  } else {
    $verbose = $VERBOSE{$token};
  }
  warn "yylex($token=$verbose$val)\n";
  return $token;
}

my $Intervall = 0;
sub yylex {
  $yylval = undef;
  $line =~ s:^\s+::;
  if ($line =~ s:^($KEY)\b::io) {
    return $TOKEN{$1}
  } elsif ($line =~ s/^(\w+)\s*==?/=/io) {
    $yylval = $1;
    return $WORD;
  } elsif ($line =~ s:^([=()<>])::) {
    return ord($1);
  } elsif ($Intervall and $line =~ s:^,::) {
    return ord(',');
  } elsif ($line =~ s:^\[::) {
    $Intervall = 1;
    return ord('[');
  } elsif ($line =~ s:^\]::) {
    $Intervall = 0;
    return ord(']');
  } elsif ($Intervall and $line =~ s:^([^,\]]+)::) {
    $yylval = $1;
    return $WORD;
  } elsif ($line =~ s:^([^=\[<>()\n\r\t ]+)::) {
    $yylval = $1;
    return $WORD;
  }
  return 0;
}

my @FLD;

use vars qw(%FLD);

sub fields {
  if (ref $FLD[-1]) {
    @{$FLD[-1]}
  } else {
    $FLD[-1];
  }
}


sub enter {
  my $field = shift;

  if ($FLD{$field}) {
    push @FLD, $FLD{$field};
  } else {
    croak "Unknown field name: $field";
  }
}

sub leave {
  pop @FLD;
}

sub plain {
  my $word = shift;

  if ($word =~ s:\*$::) {
    prefix($word);
  } else {
    new WAIT::Query::Base $Table, $FLD[-1], Plain => $word;
  }
}

sub prefix {
  my $word = shift;
  my ($ff, @fld) = fields();
  my $raw = $Table->prefix($ff, $word);
  for $ff (@fld) {
    my $new = $Table->prefix($ff, $word);
    $raw->merge($new);
  }
  new WAIT::Query::Base ($Table, $FLD[-1], Raw => $raw);
}

sub intervall {
  my ($left, $right) = @_;
  my ($ff, @fld) = fields();
  my $raw = $Table->intervall($ff, $left, $right);
  for $ff (@fld) {
    my $new = $Table->intervall($ff, $left, $right);
    $raw->merge($new);
  }
  new WAIT::Query::Base ($Table, $FLD[-1], Raw => $raw);
}

use Text::Abbrev;
sub query {
  local($Table) = shift;
  $line = shift;

  my @fields = $Table->fields;

  @FLD = (\@fields); #  %FLD = abbrev(@fields);          # patched Text::Abbrev
  abbrev(*FLD,@fields);
  yyparse();
  $yyval;
}

1;
1	ulpfr	10	%{
2			# -- Mode: Perl --
3			# waisquery.y --
4			# ITIID : $ITI$ $Header $__Header$
5			# Author : Ulrich Pfeifer
6			# Created On : Fri Sep 13 15:54:19 1996
7			# Last Modified By: Ulrich Pfeifer
8			# Last Modified On: Sun Nov 22 18:44:28 1998
9			# Language : CPerl
10			# Update Count : 129
11			# Status : Unknown, Use with caution!
12			#
13			# Copyright (c) 1996-1997, Ulrich Pfeifer
14			#
15
16			package WAIT::Query::Wais;
17			use WAIT::Query::Base;
18			use Carp;
19			use strict;
20			use vars qw($WORD $PHONIX $SOUNDEX $ASSIGN $FLOAT $OR $AND $NOT $PROX_ORDERED
21			$PROX_UNORDERED $PROX_ATLEAST
22			$yylval $yyval $YYTABLESIZE $Table
23			%TOKEN);
24			my %VERBOSE ;
25			no strict 'vars';
26			%}
27			%token WORD
28			%token PHONIX SOUNDEX ASSIGN FLOAT
29			%left OR
30			%left AND
31			%left NOT
32			%nonassoc PROX_ORDERED PROX_UNORDERED PROX_ATLEAST
33			%%
34			query : expression
35			;
36
37			or : %prec OR
38			\| OR
39			;
40
41			expression : term
42			\| expression or term { $$ = $$->merge($3); }
43			;
44
45			term : factor
46			\| term AND factor {$$ = new WAIT::Query::and $1, $3;}
47			\| term NOT factor {$$ = new WAIT::Query::not $1, $3;}
48			;
49
50			factor : unit
51			\| unit PROX_ORDERED unit
52			\| unit PROX_UNORDERED unit
53			\| PROX_ATLEAST unit
54			;
55
56			unit : w_unit
57			\| '(' expression ')' { $$ = $2; }
58			\| WORD '=' {enter($1);} '(' s_expression ')'
59			{leave($1); $$ = $5; }
60			\| WORD '=' {enter($1);} w_unit {leave($1); $$ = $4; }
61			\| WORD {enter($1);} '<' WORD
62			{$$ = intervall(undef, $4); leave($1);}
63			\| WORD {enter($1);} '>' WORD
64			{$$ = intervall($4, undef); leave($1);}
65			\| WORD {enter($1);} '[' WORD ',' WORD ']'
66			{$$ = intervall($4, $6); leave($1);}
67			;
68			;
69			phonsound : PHONIX
70			\| SOUNDEX
71			;
72			s_expression : s_term
73			\| s_expression or s_term { $$ = $$->merge($3); }
74			;
75
76			s_term : s_factor
77			\| s_term AND s_factor {$$ = new WAIT::Query::and $1, $3;}
78			\| s_term NOT s_factor {$$ = new WAIT::Query::not $1, $3;}
79			;
80
81			s_factor : s_unit
82			\| s_unit PROX_ORDERED s_unit
83			\| s_unit PROX_UNORDERED s_unit
84			\| PROX_ATLEAST s_unit
85			;
86
87			s_unit : w_unit
88			\| '(' s_expression ')' { $$ = $2; }
89			;
90			a_unit : WORD { $$ = plain($1); }
91			\| phonsound WORD { $$ = plain($2); }
92			;
93			w_unit : a_unit
94			\| a_unit ASSIGN FLOAT
95			%%
96			use strict;
97			sub yyerror {
98	ulpfr	19	warn "yyerror: @_ $.\n";
99	ulpfr	10	}
100
101			for (qw(and or not phonix soundex)) {
102			my $e = sprintf '$WAIT::Query::Wais::TOKEN{$_} = $%s', uc($_);
103			eval $e;
104			die $@ if $@ ne '';
105			$VERBOSE{$TOKEN{$_}} = $_;
106			}
107			$VERBOSE{$WORD} = 'WORD';
108			my $KEY = join('\|', keys %TOKEN);
109
110			my $line;
111
112			sub yylex1 {
113			print "=>$line\n";
114			my $token = yylex1();
115			my $verbose;
116			my $val = (defined $yylval)?",$yylval":'';
117			if ($token < 256) {
118			$verbose = "'".chr($token)."'";
119			} else {
120			$verbose = $VERBOSE{$token};
121			}
122	ulpfr	19	warn "yylex($token=$verbose$val)\n";
123	ulpfr	10	return $token;
124			}
125
126			my $Intervall = 0;
127			sub yylex {
128			$yylval = undef;
129			$line =~ s:^\s+::;
130			if ($line =~ s:^($KEY)\b::io) {
131			return $TOKEN{$1}
132			} elsif ($line =~ s/^(\w+)\s*==?/=/io) {
133			$yylval = $1;
134			return $WORD;
135			} elsif ($line =~ s:^([=()<>])::) {
136			return ord($1);
137			} elsif ($Intervall and $line =~ s:^,::) {
138			return ord(',');
139			} elsif ($line =~ s:^\[::) {
140			$Intervall = 1;
141			return ord('[');
142			} elsif ($line =~ s:^\]::) {
143			$Intervall = 0;
144			return ord(']');
145			} elsif ($Intervall and $line =~ s:^([^,\]]+)::) {
146			$yylval = $1;
147			return $WORD;
148			} elsif ($line =~ s:^([^=\[<>()\n\r\t ]+)::) {
149			$yylval = $1;
150			return $WORD;
151			}
152			return 0;
153			}
154
155			my @FLD;
156
157			use vars qw(%FLD);
158
159			sub fields {
160			if (ref $FLD[-1]) {
161			@{$FLD[-1]}
162			} else {
163			$FLD[-1];
164			}
165			}
166
167
168			sub enter {
169			my $field = shift;
170
171			if ($FLD{$field}) {
172			push @FLD, $FLD{$field};
173			} else {
174			croak "Unknown field name: $field";
175			}
176			}
177
178			sub leave {
179			pop @FLD;
180			}
181
182			sub plain {
183			my $word = shift;
184
185			if ($word =~ s:\*$::) {
186			prefix($word);
187			} else {
188			new WAIT::Query::Base $Table, $FLD[-1], Plain => $word;
189			}
190			}
191
192			sub prefix {
193			my $word = shift;
194			my ($ff, @fld) = fields();
195			my $raw = $Table->prefix($ff, $word);
196			for $ff (@fld) {
197			my $new = $Table->prefix($ff, $word);
198			$raw->merge($new);
199			}
200			new WAIT::Query::Base ($Table, $FLD[-1], Raw => $raw);
201			}
202
203			sub intervall {
204			my ($left, $right) = @_;
205			my ($ff, @fld) = fields();
206			my $raw = $Table->intervall($ff, $left, $right);
207			for $ff (@fld) {
208			my $new = $Table->intervall($ff, $left, $right);
209			$raw->merge($new);
210			}
211			new WAIT::Query::Base ($Table, $FLD[-1], Raw => $raw);
212			}
213
214			use Text::Abbrev;
215			sub query {
216			local($Table) = shift;
217			$line = shift;
218
219			my @fields = $Table->fields;
220
221			@FLD = (\@fields); # %FLD = abbrev(@fields); # patched Text::Abbrev
222			abbrev(*FLD,@fields);
223			yyparse();
224			$yyval;
225			}
226
227			1;