| 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; |
Parent Directory
| 
Revision Log