trunk/html/swish.cgi

#!/usr/bin/perl -w

use strict;
use CGI qw/:standard -no_xhtml/;
use CGI::Carp qw(fatalsToBrowser);
use SWISH;
use XML::Simple;
use Lingua::Spelling::Alternative;
use Text::Iconv;

# output charset
my $CHARSET='ISO-8859-2';

Text::Iconv->raise_error(0);     # Conversion errors raise exceptions
my $from_utf8 = Text::Iconv->new('UTF8', $CHARSET);

my $config=XMLin(undef,
#               keyattr => { label => "value" },
                forcecontent => 0,
        );

use Data::Dumper;
#print Dumper($config);

my $spelling_alt;
# FIX: doesn't work very well
if ($config->{affix}) {
        $spelling_alt = new Lingua::Spelling::Alternative;
        $spelling_alt->load_findaffix($config->{affix});
}

my $hits=0;
my $max_hits=$config->{max_hits};

my %labels;
foreach (@{$config->{labels}->{label}}) {
        $labels{$_->{value}} = $from_utf8->convert($_->{content});
}

print header(-charset=>$CHARSET),start_html(-title=>'Pretrazivanje',-lang=>'hr'),start_form;
print "Potra¾i ",popup_menu(-name=>'max_hits',-values=>[ sort keys %labels ],-labels=>\%labels,-default=>$max_hits)," dokumenata sa rijeèima: ",textfield('search');
print submit(-value=>'prika¾i');
print checkbox(-name=>'no_affix', -checked=>0, -label=>'ne koristi variranje oblika rijeèi');
print end_form,hr;

if (param('search')) {

        my $s;
        # re-write query from +/- to and/and not

        my $search = param('search');
        my $s_phrase = "";
        while ($search =~ s/\s*("[^"]+")\s*/ /) {
                $s .= "$1 ";
        }
        $search =~ s/^\s+//;
        $search =~ s/\s+$//;

        foreach (split(/\s+/,$search)) {
                if (m/^([+-])(\S+)/) {
                        $s.= ($s) ? "and " : "";
                        $s.="not " if ($1 eq "-");
                        if ($spelling_alt && !param('no_affix')) {
                                my $w = $2; $w =~ s/[\*\s]+//g;
                                $w =~ s/^(['"]*)([^'"]+)(['"]*)/$2/;
                                $s.="$1(".join("* or ",$spelling_alt->alternatives($w))."*)$3 ";
                        } else {
                                $s.="$2* ";
                        }
                } else {
                        if ($spelling_alt && !param('no_affix')) {
                                my $w = $_; $w =~ s/[\*\s]+//g;
                                #$s.="(".join("* or ",$spelling_alt->alternatives($w))."*) ";
                                $s.="(".join("* or ",$spelling_alt->alternatives($w))."*) ";
                        } else {
                                $s.="$_* ";
                        }
                }
        }

        # fixup search string
        $s=~tr/ðèæÐÈÆ/¹ð¾èæ©Ð®ÈÆ/;  # 1250 -> iso8859-2
        $s=~tr/¹©ðÐèÈæÆ¾®/sSdDcCcCzZ/;
        $s=~s/\*\*+/*/g;

        my $sh = SWISH->connect('Fork',
                prog     => $config->{prog},
                indexes  => $config->{index},
#               properties  => [qw/god br nr/],
                results  => sub {
                        my ($sh,$hit) = @_;

                        print "<a href=\"",$hit->swishdocpath,"\">",$hit->swishtitle,"</a> [",$hit->swishrank,"]<br>\n";

#                       print $_[1]->as_string,"<br>\n";
#                       my @fields = $hit->field_names;
#                       print "Field '$_' = '", $hit->$_, "'<br>\n" for sort @fields;
                },
                maxhits => param('max_hits') || $max_hits,
        );

        die $SWISH::errstr unless $sh;


        $hits = $sh->query($s);

        if ($hits > 0) {
                print p,hr,"Prikazujem $hits dokumenata (maks. ",param('max_hits') || $max_hits,")... <small>($s)</small>";
        } else {
                print p,"Nije naðen niti jedan dokument... <small>($s, ",$sh->errstr,")</small>";
        }
} else {
        print p('Kod pretra¾ivanja pretra¾ivaè pronalazi sve dokumente u kojima se pojavljuju <b>sve upisanje rijeèi</b>.',br,'Ako ispred rijeèi upi¹ete minus (-) neæe se prikazivati dokumenti koji imaju takvu rijeè. Npr. <tt>+mreza -novak</tt>');
}
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	# output charset
12	my $CHARSET='ISO-8859-2';
13
14	Text::Iconv->raise_error(0); # Conversion errors raise exceptions
15	my $from_utf8 = Text::Iconv->new('UTF8', $CHARSET);
16
17	my $config=XMLin(undef,
18	# keyattr => { label => "value" },
19	forcecontent => 0,
20	);
21
22	use Data::Dumper;
23	#print Dumper($config);
24
25	my $spelling_alt;
26	# FIX: doesn't work very well
27	if ($config->{affix}) {
28	$spelling_alt = new Lingua::Spelling::Alternative;
29	$spelling_alt->load_findaffix($config->{affix});
30	}
31
32	my $hits=0;
33	my $max_hits=$config->{max_hits};
34
35	my %labels;
36	foreach (@{$config->{labels}->{label}}) {
37	$labels{$_->{value}} = $from_utf8->convert($_->{content});
38	}
39
40	print header(-charset=>$CHARSET),start_html(-title=>'Pretrazivanje',-lang=>'hr'),start_form;
41	print "Potra¾i ",popup_menu(-name=>'max_hits',-values=>[ sort keys %labels ],-labels=>\%labels,-default=>$max_hits)," dokumenata sa rijeèima: ",textfield('search');
42	print submit(-value=>'prika¾i');
43	print checkbox(-name=>'no_affix', -checked=>0, -label=>'ne koristi variranje oblika rijeèi');
44	print end_form,hr;
45
46	if (param('search')) {
47
48	my $s;
49	# re-write query from +/- to and/and not
50
51	my $search = param('search');
52	my $s_phrase = "";
53	while ($search =~ s/\s("[^"]+")\s/ /) {
54	$s .= "$1 ";
55	}
56	$search =~ s/^\s+//;
57	$search =~ s/\s+$//;
58
59	foreach (split(/\s+/,$search)) {
60	if (m/^([+-])(\S+)/) {
61	$s.= ($s) ? "and " : "";
62	$s.="not " if ($1 eq "-");
63	if ($spelling_alt && !param('no_affix')) {
64	my $w = $2; $w =~ s/[\*\s]+//g;
65	$w =~ s/^(['"])([^'"]+)(['"])/$2/;
66	$s.="$1(".join("* or ",$spelling_alt->alternatives($w))."*)$3 ";
67	} else {
68	$s.="$2* ";
69	}
70	} else {
71	if ($spelling_alt && !param('no_affix')) {
72	my $w = $_; $w =~ s/[\*\s]+//g;
73	#$s.="(".join("* or ",$spelling_alt->alternatives($w))."*) ";
74	$s.="(".join("* or ",$spelling_alt->alternatives($w))."*) ";
75	} else {
76	$s.="$_* ";
77	}
78	}
79	}
80
81	# fixup search string
82	$s=~tr/ðèæÐÈÆ/¹ð¾èæ©Ð®ÈÆ/; # 1250 -> iso8859-2
83	$s=~tr/¹©ðÐèÈæÆ¾®/sSdDcCcCzZ/;
84	$s=~s/\\+/*/g;
85
86	my $sh = SWISH->connect('Fork',
87	prog => $config->{prog},
88	indexes => $config->{index},
89	# properties => [qw/god br nr/],
90	results => sub {
91	my ($sh,$hit) = @_;
92
93	print "<a href=\"",$hit->swishdocpath,"\">",$hit->swishtitle,"</a> [",$hit->swishrank,"]<br>\n";
94
95	# print $_[1]->as_string,"<br>\n";
96	# my @fields = $hit->field_names;
97	# print "Field '$_' = '", $hit->$_, "'<br>\n" for sort @fields;
98	},
99	maxhits => param('max_hits') \|\| $max_hits,
100	);
101
102	die $SWISH::errstr unless $sh;
103
104
105	$hits = $sh->query($s);
106
107	if ($hits > 0) {
108	print p,hr,"Prikazujem $hits dokumenata (maks. ",param('max_hits') \|\| $max_hits,")... <small>($s)</small>";
109	} else {
110	print p,"Nije naðen niti jedan dokument... <small>($s, ",$sh->errstr,")</small>";
111	}
112	} else {
113	print p('Kod pretra¾ivanja pretra¾ivaè pronalazi sve dokumente u kojima se pojavljuju <b>sve upisanje rijeèi</b>.',br,'Ako ispred rijeèi upi¹ete minus (-) neæe se prikazivati dokumenti koji imaju takvu rijeè. Npr. <tt>+mreza -novak</tt>');
114	}