/[wait]/branches/CPAN/lib/WAIT/Query/Wais.pm
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 /branches/CPAN/lib/WAIT/Query/Wais.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 11 - (show annotations)
Fri Apr 28 15:41:10 2000 UTC (24 years, 1 month ago) by unknown
File size: 14209 byte(s)
This commit was manufactured by cvs2svn to create branch 'CPAN'.
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:39 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 $WORD=257;
27 $PHONIX=258;
28 $SOUNDEX=259;
29 $ASSIGN=260;
30 $FLOAT=261;
31 $OR=262;
32 $AND=263;
33 $NOT=264;
34 $PROX_ORDERED=265;
35 $PROX_UNORDERED=266;
36 $PROX_ATLEAST=267;
37 $YYERRCODE=256;
38 @yylhs = ( -1,
39 0, 2, 2, 1, 1, 3, 3, 3, 4, 4,
40 4, 4, 5, 5, 7, 5, 9, 5, 10, 5,
41 11, 5, 12, 5, 13, 13, 8, 8, 14, 14,
42 14, 15, 15, 15, 15, 16, 16, 17, 17, 6,
43 6,
44 );
45 @yylen = ( 2,
46 1, 0, 1, 1, 3, 1, 3, 3, 1, 3,
47 3, 2, 1, 3, 0, 6, 0, 4, 0, 4,
48 0, 4, 0, 7, 1, 1, 1, 3, 1, 3,
49 3, 1, 3, 3, 2, 1, 3, 1, 2, 1,
50 3,
51 );
52 @yydefred = ( 0,
53 0, 25, 26, 0, 0, 0, 0, 0, 6, 0,
54 13, 0, 0, 0, 0, 0, 0, 12, 0, 3,
55 0, 0, 0, 0, 0, 39, 0, 0, 0, 0,
56 0, 0, 14, 0, 7, 8, 10, 11, 41, 0,
57 38, 18, 20, 22, 0, 0, 0, 36, 0, 0,
58 29, 0, 0, 35, 0, 16, 0, 0, 0, 0,
59 0, 0, 37, 0, 30, 31, 33, 34, 24,
60 );
61 @yydgoto = ( 6,
62 7, 21, 8, 9, 10, 11, 28, 49, 29, 15,
63 16, 17, 12, 50, 51, 52, 13,
64 );
65 @yysindex = ( -15,
66 -61, 0, 0, -4, -15, 0, -257, -248, 0, -239,
67 0, -246, -251, 0, -9, -25, -46, 0, -35, 0,
68 -15, -15, -15, -4, -4, 0, -211, 14, -236, -199,
69 -198, -197, 0, -248, 0, 0, 0, 0, 0, -10,
70 0, 0, 0, 0, 18, 53, -10, 0, -34, -230,
71 0, -226, -186, 0, -23, 0, -10, -10, -10, 53,
72 53, -20, 0, -230, 0, 0, 0, 0, 0,
73 );
74 @yyrindex = ( 0,
75 1, 0, 0, 0, 0, 0, 57, 35, 0, 24,
76 0, 0, 12, 60, 0, 0, 0, 0, 42, 0,
77 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
78 0, 0, 0, 46, 0, 0, 0, 0, 0, 0,
79 0, 0, 0, 0, 0, 0, 0, 0, 42, -27,
80 0, -38, 0, 0, 42, 0, 0, 0, 0, 0,
81 0, 0, 0, -21, 0, 0, 0, 0, 0,
82 );
83 @yygindex = ( 0,
84 67, -45, 56, 21, 4, 9, 0, 27, 0, 0,
85 0, 0, 0, 22, -11, -29, 0,
86 );
87 $YYTABLESIZE=324;
88 @yytable = ( 14,
89 38, 32, 32, 57, 20, 33, 56, 18, 27, 57,
90 26, 40, 27, 27, 22, 23, 54, 63, 28, 28,
91 41, 2, 3, 9, 5, 24, 25, 37, 38, 47,
92 67, 68, 58, 59, 4, 5, 31, 42, 60, 61,
93 38, 38, 35, 36, 32, 5, 65, 66, 48, 39,
94 30, 40, 40, 40, 48, 48, 1, 43, 44, 45,
95 19, 53, 21, 9, 9, 48, 48, 48, 48, 48,
96 62, 19, 69, 55, 4, 4, 34, 0, 64, 0,
97 0, 2, 0, 0, 0, 5, 5, 0, 0, 0,
98 0, 23, 47, 0, 0, 0, 2, 0, 0, 15,
99 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
100 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
101 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
102 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
103 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
104 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
105 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
106 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
107 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
108 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
109 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
110 0, 0, 0, 0, 0, 0, 0, 0, 32, 32,
111 32, 0, 0, 32, 32, 32, 20, 20, 32, 27,
112 27, 27, 0, 0, 27, 28, 28, 28, 20, 27,
113 28, 1, 2, 3, 0, 28, 41, 2, 3, 0,
114 0, 4, 1, 2, 3, 0, 46, 38, 38, 38,
115 38, 0, 38, 38, 38, 38, 38, 38, 40, 40,
116 40, 0, 0, 40, 40, 40, 40, 40, 40, 0,
117 9, 9, 9, 0, 0, 9, 9, 9, 0, 0,
118 9, 4, 4, 4, 0, 0, 4, 0, 2, 2,
119 2, 4, 5, 5, 5, 0, 0, 5, 2, 41,
120 2, 3, 5, 2, 2, 2, 17, 17, 17, 0,
121 0, 0, 0, 2,
122 );
123 @yycheck = ( 61,
124 0, 40, 41, 49, 262, 41, 41, 4, 260, 55,
125 257, 0, 40, 41, 263, 264, 46, 41, 40, 41,
126 257, 258, 259, 0, 40, 265, 266, 24, 25, 40,
127 60, 61, 263, 264, 0, 40, 62, 29, 265, 266,
128 40, 41, 22, 23, 91, 0, 58, 59, 40, 261,
129 60, 40, 41, 40, 46, 47, 0, 257, 257, 257,
130 60, 44, 62, 40, 41, 57, 58, 59, 60, 61,
131 257, 5, 93, 47, 40, 41, 21, -1, 57, -1,
132 -1, 40, -1, -1, -1, 40, 41, -1, -1, -1,
133 -1, 91, 40, -1, -1, -1, 40, -1, -1, 40,
134 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
135 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
136 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
137 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
138 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
139 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
140 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
141 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
142 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
143 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
144 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
145 -1, -1, -1, -1, -1, -1, -1, -1, 257, 258,
146 259, -1, -1, 262, 263, 264, 262, 262, 267, 257,
147 258, 259, -1, -1, 262, 257, 258, 259, 262, 267,
148 262, 257, 258, 259, -1, 267, 257, 258, 259, -1,
149 -1, 267, 257, 258, 259, -1, 267, 257, 258, 259,
150 260, -1, 262, 263, 264, 265, 266, 267, 257, 258,
151 259, -1, -1, 262, 263, 264, 265, 266, 267, -1,
152 257, 258, 259, -1, -1, 262, 263, 264, -1, -1,
153 267, 257, 258, 259, -1, -1, 262, -1, 257, 258,
154 259, 267, 257, 258, 259, -1, -1, 262, 267, 257,
155 258, 259, 267, 257, 258, 259, 257, 258, 259, -1,
156 -1, -1, -1, 267,
157 );
158 $YYFINAL=6;
159
160
161
162 $YYMAXTOKEN=267;
163
164 sub yyclearin { $yychar = -1; }
165 sub yyerrok { $yyerrflag = 0; }
166 $YYSTACKSIZE = $YYSTACKSIZE || $YYMAXDEPTH || 500;
167 $YYMAXDEPTH = $YYMAXDEPTH || $YYSTACKSIZE || 500;
168 $yyss[$YYSTACKSIZE] = 0;
169 $yyvs[$YYSTACKSIZE] = 0;
170 sub YYERROR { ++$yynerrs; &yy_err_recover; }
171 sub yy_err_recover
172 {
173 if ($yyerrflag < 3)
174 {
175 $yyerrflag = 3;
176 while (1)
177 {
178 if (($yyn = $yysindex[$yyss[$yyssp]]) &&
179 ($yyn += $YYERRCODE) >= 0 &&
180 $yycheck[$yyn] == $YYERRCODE)
181 {
182
183
184
185
186 $yyss[++$yyssp] = $yystate = $yytable[$yyn];
187 $yyvs[++$yyvsp] = $yylval;
188 next yyloop;
189 }
190 else
191 {
192
193
194
195
196 return(1) if $yyssp <= 0;
197 --$yyssp;
198 --$yyvsp;
199 }
200 }
201 }
202 else
203 {
204 return (1) if $yychar == 0;
205
206 $yychar = -1;
207 next yyloop;
208 }
209 0;
210 } # yy_err_recover
211
212 sub yyparse
213 {
214
215 if ($yys = $ENV{'YYDEBUG'})
216 {
217 $yydebug = int($1) if $yys =~ /^(\d)/;
218 }
219
220
221 $yynerrs = 0;
222 $yyerrflag = 0;
223 $yychar = (-1);
224
225 $yyssp = 0;
226 $yyvsp = 0;
227 $yyss[$yyssp] = $yystate = 0;
228
229 yyloop: while(1)
230 {
231 yyreduce: {
232 last yyreduce if ($yyn = $yydefred[$yystate]);
233 if ($yychar < 0)
234 {
235 if (($yychar = &yylex) < 0) { $yychar = 0; }
236
237 }
238 if (($yyn = $yysindex[$yystate]) && ($yyn += $yychar) >= 0 &&
239 $yycheck[$yyn] == $yychar)
240 {
241
242
243
244
245 $yyss[++$yyssp] = $yystate = $yytable[$yyn];
246 $yyvs[++$yyvsp] = $yylval;
247 $yychar = (-1);
248 --$yyerrflag if $yyerrflag > 0;
249 next yyloop;
250 }
251 if (($yyn = $yyrindex[$yystate]) && ($yyn += $yychar) >= 0 &&
252 $yycheck[$yyn] == $yychar)
253 {
254 $yyn = $yytable[$yyn];
255 last yyreduce;
256 }
257 if (! $yyerrflag) {
258 &yyerror('syntax error');
259 ++$yynerrs;
260 }
261 return(1) if &yy_err_recover;
262 } # yyreduce
263
264
265
266
267 $yym = $yylen[$yyn];
268 $yyval = $yyvs[$yyvsp+1-$yym];
269 switch:
270 {
271 1; # make perl happy if switch empty (Ulrich Pfeifer)
272 if ($yyn == 5) {
273 { $yyval = $yyval->merge($yyvs[$yyvsp-0]);
274 last switch;
275 } }
276 if ($yyn == 7) {
277 {$yyval = new WAIT::Query::and $yyvs[$yyvsp-2], $yyvs[$yyvsp-0];
278 last switch;
279 } }
280 if ($yyn == 8) {
281 {$yyval = new WAIT::Query::not $yyvs[$yyvsp-2], $yyvs[$yyvsp-0];
282 last switch;
283 } }
284 if ($yyn == 14) {
285 { $yyval = $yyvs[$yyvsp-1];
286 last switch;
287 } }
288 if ($yyn == 15) {
289 {enter($yyvs[$yyvsp-1]);
290 last switch;
291 } }
292 if ($yyn == 16) {
293 {leave($yyvs[$yyvsp-5]); $yyval = $yyvs[$yyvsp-1];
294 last switch;
295 } }
296 if ($yyn == 17) {
297 {enter($yyvs[$yyvsp-1]);
298 last switch;
299 } }
300 if ($yyn == 18) {
301 {leave($yyvs[$yyvsp-3]); $yyval = $yyvs[$yyvsp-0];
302 last switch;
303 } }
304 if ($yyn == 19) {
305 {enter($yyvs[$yyvsp-0]);
306 last switch;
307 } }
308 if ($yyn == 20) {
309 {$yyval = intervall(undef, $yyvs[$yyvsp-0]); leave($yyvs[$yyvsp-3]);
310 last switch;
311 } }
312 if ($yyn == 21) {
313 {enter($yyvs[$yyvsp-0]);
314 last switch;
315 } }
316 if ($yyn == 22) {
317 {$yyval = intervall($yyvs[$yyvsp-0], undef); leave($yyvs[$yyvsp-3]);
318 last switch;
319 } }
320 if ($yyn == 23) {
321 {enter($yyvs[$yyvsp-0]);
322 last switch;
323 } }
324 if ($yyn == 24) {
325 {$yyval = intervall($yyvs[$yyvsp-3], $yyvs[$yyvsp-1]); leave($yyvs[$yyvsp-6]);
326 last switch;
327 } }
328 if ($yyn == 28) {
329 { $yyval = $yyval->merge($yyvs[$yyvsp-0]);
330 last switch;
331 } }
332 if ($yyn == 30) {
333 {$yyval = new WAIT::Query::and $yyvs[$yyvsp-2], $yyvs[$yyvsp-0];
334 last switch;
335 } }
336 if ($yyn == 31) {
337 {$yyval = new WAIT::Query::not $yyvs[$yyvsp-2], $yyvs[$yyvsp-0];
338 last switch;
339 } }
340 if ($yyn == 37) {
341 { $yyval = $yyvs[$yyvsp-1];
342 last switch;
343 } }
344 if ($yyn == 38) {
345 { $yyval = plain($yyvs[$yyvsp-0]);
346 last switch;
347 } }
348 if ($yyn == 39) {
349 { $yyval = plain($yyvs[$yyvsp-0]);
350 last switch;
351 } }
352 } # switch
353 $yyssp -= $yym;
354 $yystate = $yyss[$yyssp];
355 $yyvsp -= $yym;
356 $yym = $yylhs[$yyn];
357 if ($yystate == 0 && $yym == 0)
358 {
359
360
361
362
363 $yystate = $YYFINAL;
364 $yyss[++$yyssp] = $YYFINAL;
365 $yyvs[++$yyvsp] = $yyval;
366 if ($yychar < 0)
367 {
368 if (($yychar = &yylex) < 0) { $yychar = 0; }
369
370 }
371 return(0) if $yychar == 0;
372 next yyloop;
373 }
374 if (($yyn = $yygindex[$yym]) && ($yyn += $yystate) >= 0 &&
375 $yyn <= $#yycheck && $yycheck[$yyn] == $yystate)
376 {
377 $yystate = $yytable[$yyn];
378 } else {
379 $yystate = $yydgoto[$yym];
380 }
381
382
383
384
385 $yyss[++$yyssp] = $yystate;
386 $yyvs[++$yyvsp] = $yyval;
387 } # yyloop
388 } # yyparse
389 use strict;
390 sub yyerror {
391 print "yyeror: @_ $.\n";
392 }
393
394 for (qw(and or not phonix soundex)) {
395 my $e = sprintf '$WAIT::Query::Wais::TOKEN{$_} = $%s', uc($_);
396 eval $e;
397 die $@ if $@ ne '';
398 $VERBOSE{$TOKEN{$_}} = $_;
399 }
400 $VERBOSE{$WORD} = 'WORD';
401 my $KEY = join('|', keys %TOKEN);
402
403 my $line;
404
405 sub yylex1 {
406 print "=>$line\n";
407 my $token = yylex1();
408 my $verbose;
409 my $val = (defined $yylval)?",$yylval":'';
410 if ($token < 256) {
411 $verbose = "'".chr($token)."'";
412 } else {
413 $verbose = $VERBOSE{$token};
414 }
415 print "yylex($token=$verbose$val)\n";
416 return $token;
417 }
418
419 my $Intervall = 0;
420 sub yylex {
421 $yylval = undef;
422 $line =~ s:^\s+::;
423 if ($line =~ s:^($KEY)\b::io) {
424 return $TOKEN{$1}
425 } elsif ($line =~ s/^(\w+)\s*==?/=/io) {
426 $yylval = $1;
427 return $WORD;
428 } elsif ($line =~ s:^([=()<>])::) {
429 return ord($1);
430 } elsif ($Intervall and $line =~ s:^,::) {
431 return ord(',');
432 } elsif ($line =~ s:^\[::) {
433 $Intervall = 1;
434 return ord('[');
435 } elsif ($line =~ s:^\]::) {
436 $Intervall = 0;
437 return ord(']');
438 } elsif ($Intervall and $line =~ s:^([^,\]]+)::) {
439 $yylval = $1;
440 return $WORD;
441 } elsif ($line =~ s:^([^=\[<>()\n\r\t ]+)::) {
442 $yylval = $1;
443 return $WORD;
444 }
445 return 0;
446 }
447
448 my @FLD;
449
450 use vars qw(%FLD);
451
452 sub fields {
453 if (ref $FLD[-1]) {
454 @{$FLD[-1]}
455 } else {
456 $FLD[-1];
457 }
458 }
459
460
461 sub enter {
462 my $field = shift;
463
464 if ($FLD{$field}) {
465 push @FLD, $FLD{$field};
466 } else {
467 croak "Unknown field name: $field";
468 }
469 }
470
471 sub leave {
472 pop @FLD;
473 }
474
475 sub plain {
476 my $word = shift;
477
478 if ($word =~ s:\*$::) {
479 prefix($word);
480 } else {
481 new WAIT::Query::Base $Table, $FLD[-1], Plain => $word;
482 }
483 }
484
485 sub prefix {
486 my $word = shift;
487 my ($ff, @fld) = fields();
488 my $raw = $Table->prefix($ff, $word);
489 for $ff (@fld) {
490 my $new = $Table->prefix($ff, $word);
491 $raw->merge($new);
492 }
493 new WAIT::Query::Base ($Table, $FLD[-1], Raw => $raw);
494 }
495
496 sub intervall {
497 my ($left, $right) = @_;
498 my ($ff, @fld) = fields();
499 my $raw = $Table->intervall($ff, $left, $right);
500 for $ff (@fld) {
501 my $new = $Table->intervall($ff, $left, $right);
502 $raw->merge($new);
503 }
504 new WAIT::Query::Base ($Table, $FLD[-1], Raw => $raw);
505 }
506
507 use Text::Abbrev;
508 sub query {
509 local($Table) = shift;
510 $line = shift;
511
512 my @fields = $Table->fields;
513
514 @FLD = (\@fields); # %FLD = abbrev(@fields); # patched Text::Abbrev
515 abbrev(*FLD,@fields);
516 yyparse();
517 $yyval;
518 }
519
520 1;

Properties

Name Value
cvs2svn:cvs-rev 1.1

  ViewVC Help
Powered by ViewVC 1.1.26