/[swish]/trunk/html/swish.cgi
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/html/swish.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 39 - (show annotations)
Sun Jun 1 11:41:39 2003 UTC (20 years, 10 months ago) by dpavlin
File size: 4897 byte(s)
support for affix and findaffix in same configuration file

1 #!/usr/bin/perl -w
2
3 use strict;
4 use CGI qw/:standard -no_xhtml/;
5 use CGI::Carp qw(fatalsToBrowser);
6 use SWISH;
7 use XML::Simple;
8 use Lingua::Spelling::Alternative;
9 use Text::Iconv;
10
11 Text::Iconv->raise_error(0); # Conversion errors raise exceptions
12 my $config=XMLin(undef,
13 # keyattr => { label => "value" },
14 forcecontent => 0,
15 );
16
17 my $from_utf8 = Text::Iconv->new('UTF8', $config->{charset});
18 sub x {
19 return $from_utf8->convert($_[0]);
20 }
21
22 # Escape <, >, & and ", and to produce valid XML
23 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
24 my $escape_re = join '|' => keys %escape;
25 sub e {
26 my $out;
27 foreach my $v (@_) {
28 $v =~ s/($escape_re)/$escape{$1}/g;
29 $out .= $v;
30 }
31 return $out;
32 }
33
34 my @spellings;
35 # FIX: doesn't work very well
36 if ($config->{findaffix}) {
37 my $spelling_alt = new Lingua::Spelling::Alternative;
38 $spelling_alt->load_findaffix(x($config->{findaffix}));
39 push @spellings,$spelling_alt;
40 }
41 if ($config->{affix}) {
42 my $spelling_alt = new Lingua::Spelling::Alternative;
43 $spelling_alt->load_affix(x($config->{affix}));
44 push @spellings,$spelling_alt;
45 }
46
47 my $hits=0;
48 my $max_hits=x($config->{max_hits});
49
50 my %labels;
51 foreach (@{$config->{labels}->{label}}) {
52 $labels{$_->{value}} = x($_->{content});
53 }
54
55 my $path = param('path'); # limit to this path
56 my %path_label;
57 my @path_name;
58 foreach (@{$config->{paths}->{path}}) {
59
60 print STDERR "##: $_->{limit}",x($_->{content}),"\n";
61 push @path_name,x($_->{limit});
62 $path_label{$_->{limit}} = x($_->{content});
63 }
64
65 my @properties = split(/\s+/,x($config->{properties}));
66
67 if ($config->{charset}) {
68 print header(-charset=>x($config->{charset}));
69 } else {
70 print header;
71 }
72 print start_html(-title=>x($config->{title})),start_form;
73 print x($config->{text}->{search});
74 print popup_menu(-name=>'max_hits',-values=>[ sort keys %labels ],-labels=>\%labels,-default=>$max_hits);
75 print x($config->{text}->{documents});
76 print textfield('search');
77 print submit(-value=> x($config->{text}->{submit}));
78 print br,checkbox(-name=>'no_affix', -checked=>0, -label=>x($config->{text}->{no_spell})) if (@spellings);
79 print checkbox(-name=>'no_properties', -checked=>0, -label=>($config->{text}->{no_properties})) if (@properties);
80 if (@path_name) {
81 print br,x($config->{text}->{limit});
82 print popup_menu(-name=>'path',-values=>\@path_name,-labels=>\%path_label,-default=>$path);
83 }
84 print end_form,hr;
85
86 if (param('search')) {
87
88 my $s;
89 # re-write query from +/- to and/and not
90
91 my $search = param('search');
92 my $s_phrase = "";
93 while ($search =~ s/\s*("[^"]+")\s*/ /) {
94 $s .= "$1 ";
95 }
96 $search =~ s/^\s+//;
97 $search =~ s/\s+$//;
98
99 foreach (split(/\s+/,$search)) {
100 if (m/^([+-])(\S+)/) {
101 $s.= ($s) ? "and " : "";
102 $s.="not " if ($1 eq "-");
103 if (@spellings && !param('no_affix')) {
104 my $w = $2; $w =~ s/[\*\s]+//g;
105 $w =~ s/^(['"]*)([^'"]+)(['"]*)/$2/;
106 my $or="";
107 foreach my $spelling_alt (@spellings) {
108 $s.="$or$1(".join("* or ",$spelling_alt->alternatives($w))."*)$3 ";
109 $or = "or ";
110 }
111 } else {
112 $s.="$2* ";
113 }
114 } else {
115 if (@spellings && !param('no_affix')) {
116 my $w = $_; $w =~ s/[\*\s]+//g;
117 #$s.="(".join("* or ",$spelling_alt->alternatives($w))."*) ";
118 my $or="";
119 foreach my $spelling_alt (@spellings) {
120 $s.="$or(".join("* or ",$spelling_alt->alternatives($w))."*) ";
121 $or = "or ";
122 }
123 } else {
124 $s.="$_* ";
125 }
126 }
127 }
128
129 # fixup search string
130 $s=~tr/šðžèæŠÐŽÈÆ/¹ð¾èæ©Ð®ÈÆ/; # 1250 -> iso8859-2
131 $s=~tr/¹©ðÐèÈæƾ®/sSdDcCcCzZ/;
132 $s=~s/\*\*+/*/g;
133
134 # limit to some path
135 $s = "swishdocpath=(\"*$path*\") and $s" if ($path);
136
137 my %params; # optional parametars for swish
138
139 # default format for output
140 my $hit_fmt = "<a href=\"%s\">%s</a> [%s]<br>\n";
141
142 if (@properties) {
143 $hit_fmt = x($config->{hit}) if (! param('no_properties'));
144 $params{properties} = \@properties;
145 } else {
146 $hit_fmt = x($config->{hit}) if (x($config->{hit}));
147 }
148
149 my $sh = SWISH->connect('Fork',
150 prog => x($config->{prog}),
151 indexes => x($config->{index}),
152 results => sub {
153 my ($sh,$hit) = @_;
154
155 if ($config->{url}) {
156 printf ($hit_fmt ,"http://".virtual_host().x($config->{url}).$hit->swishdocpath,e($hit->swishtitle) || 'untitled',$hit->swishrank, map($hit->$_, @properties));
157 } else {
158 printf ($hit_fmt ,$hit->swishdocpath,e($hit->swishtitle) || 'untitled',$hit->swishrank, map($hit->$_, @properties) );
159
160 }
161
162 # print $_[1]->as_string,"<br>\n";
163 # my @fields = $hit->field_names;
164 # print "Field '$_' = '", $hit->$_, "'<br>\n" for sort @fields;
165 },
166 maxhits => param('max_hits') || $max_hits,
167 \%params,
168 );
169
170 die $SWISH::errstr unless $sh;
171
172
173 $hits = $sh->query($s);
174
175 if ($hits && $hits > 0) {
176 print p,hr;
177 printf (x($config->{text}->{hits}),$hits,param('max_hits') || $max_hits,$s);
178 } else {
179 print p;
180 printf (x($config->{text}->{no_hits}),$s,$sh->errstr);
181 }
182 } else {
183 print p(x($config->{text}->{footer}));
184 }

Properties

Name Value
cvs2svn:cvs-rev 1.11
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26