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; |