/[wait]/trunk/waisquery.y
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/waisquery.y

Parent Directory Parent Directory | Revision Log Revision Log


Revision 88 - (show annotations)
Mon May 24 13:44:01 2004 UTC (17 years, 4 months ago) by dpavlin
File size: 5333 byte(s)
move cvs-head to trunk

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;

Properties

Name Value
cvs2svn:cvs-rev 1.1.1.2

  ViewVC Help
Powered by ViewVC 1.1.26