1 |
%{ |
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 |
warn "yyerror: @_ $.\n"; |
99 |
} |
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 |
warn "yylex($token=$verbose$val)\n"; |
123 |
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; |