viewvc.cgi/Z3950-HTML-Scraper/server.pl

#!/usr/bin/perl

use warnings;
use strict;

use Net::Z3950::SimpleServer;
use Net::Z3950::OID;
use COBISS;

my $max_records = 3; # XXX configure this
my $max_result_sets = 10;

sub diag {
        print "# ", @_, $/;
}

sub InitHandle {
    my $this    = shift;
    my $session = {};

    $this->{HANDLE}   = $session;
    $this->{IMP_NAME} = "Z39.50 HTML scraping bot";
    $this->{IMP_VER}  = "0.1";
    $session->{SETS}  = {};
}

use Data::Dumper;

sub SearchHandle {
    my $this    = shift;

diag "SearchHandle ",Dumper($this);

    my $session = $this->{HANDLE};
    my $rpn     = $this->{RPN};
    my $query;

    eval { $query = $rpn->{query}->render(); };
    if ( $@ && ref($@) ) {    ## Did someone/something report any errors?
        $this->{ERR_CODE} = $@->{errcode};
        $this->{ERR_STR}  = $@->{errstr};
        return;
    }

diag "search for $query";

    my $setname  = $this->{SETNAME};
    my $repl_set = $this->{REPL_SET};
diag "SETNAME $setname REPL_SET $repl_set";
    my $result;
    unless ( $result = COBISS->search( $query ) ) {
        $this->{ERR_CODE} = 108;
        return;
    }
    my $hits = $COBISS::hits || diag "no results for $query";
diag "got $hits hits";
    my $rs   = {
        lower => 1,
        upper => $hits < $max_records ? $max_records : $hits,
        data  => $result->{'resultElements'},   # FIXME
    };
    my $sets = $session->{SETS};

    if ( defined( $sets->{$setname} ) && !$repl_set ) {
        $this->{ERR_CODE} = 21;
        return;
    }
    if ( scalar keys %$sets >= $max_result_sets ) {
        $this->{ERR_CODE} = 112;
        $this->{ERR_STR}  = "Max number is $max_result_sets";
        return;
    }
    $sets->{$setname} = $rs;
    $this->{HITS} = $session->{HITS} = $hits;
    $session->{QUERY} = $query;
}

sub FetchHandle {
    my $this     = shift;
    my $session  = $this->{HANDLE};
    my $setname  = $this->{SETNAME};
    my $req_form = $this->{REQ_FORM};
    my $offset   = $this->{OFFSET};
    my $sets     = $session->{SETS};
    my $hits     = $session->{HITS};
    my $rs;
    my $record;

diag Dumper( $this );

    if ( !defined( $rs = $sets->{$setname} ) ) {
        $this->{ERR_CODE} = 30;
        return;
    }
    if ( $offset > $hits ) {
        $this->{ERR_CODE} = 13;
        return;
    }
    $this->{BASENAME} = "HtmlZ3950";

#    if ( !defined($req_form) || ( $req_form eq &Net::Z3950::OID::xml ) )
    if (0)
    {    ## XML records
        $this->{REP_FORM} = &Net::Z3950::OID::xml;
        $this->{RECORD}   = '<xml>FIXME: not implementd</xml>';
    }
    elsif ( $req_form eq &Net::Z3950::OID::unimarc ) {  # FIXME convert to usmarc
        $this->{REP_FORM} = &Net::Z3950::OID::unimarc;
        $this->{RECORD} = COBISS->fetch_rec('unimarc');
    }
    elsif ( $req_form eq &Net::Z3950::OID::usmarc ) {   # FIXME convert to usmarc
        $this->{REP_FORM} = &Net::Z3950::OID::usmarc;
        $this->{RECORD} = COBISS->fetch_rec('usmarc');
    }
    else {    ## Unsupported record format
        $this->{ERR_CODE} = 239;
        $this->{ERR_STR}  = $req_form;
        return;
    }
    if ( $offset == $hits ) {
        $this->{LAST} = 1;
    }
    else {
        $this->{LAST} = 0;
    }
}

sub CloseHandle {
    my $this = shift;
}

my $z = new Net::Z3950::SimpleServer(
    INIT   => \&InitHandle,
    SEARCH => \&SearchHandle,
    FETCH  => \&FetchHandle,
    CLOSE  => \&CloseHandle
);
$z->launch_server( $0, @ARGV );

package Net::Z3950::RPN::And;

sub render {
    my $this = shift;
    return $this->[0]->render() . ' AND ' . $this->[1]->render();
}

package Net::Z3950::RPN::Or;

sub render {
    my $this = shift;
    return $this->[0]->render() . ' OR ' . $this->[1]->render();
}

package Net::Z3950::RPN::AndNot;

sub render {
    my $this = shift;
    return $this->[0]->render() . ' AND NOT ' . $this->[1]->render();
}

package Net::Z3950::RPN::Term;

use Data::Dump qw(dump);
use COBISS;

sub render {
    my $this       = shift;

print "render ", dump($this);

my $from = 'COBISS';

my $usemap = eval "${from}::usemap;";
warn "# $from usermap ",dump($usemap);

    my $attributes = {};
    my $prefix     = "";
    foreach my $attr ( @{ $this->{attributes} } ) {
        my $type  = $attr->{attributeType};
        my $value = $attr->{attributeValue};
        $attributes->{$type} = $value;
    }
    if ( defined( my $use = $attributes->{1} ) ) {
        if ( defined( my $field = $usemap->{$use} ) ) {
            $prefix = $field;
        }
        else {
            die { errcode => 114, errstr => $use }; ## Unsupported use attribute
        }
    }
    if ( defined( my $rel = $attributes->{2} ) )
    {    ## No relation attributes supported
        if ( $rel != 3 ) {
            die { errcode => 117, errstr => $rel };
        }
    }
    if ( defined( my $pos = $attributes->{3} ) )
    {    ## No position attributes either
        if ( $pos != 3 ) {
            die { errcode => 119, errstr => $pos };
        }
    }
    if ( defined( my $struc = $attributes->{4} ) ) {    ## No structure
        if ( ( $struc != 1 ) && ( $struc != 2 ) ) {
            die { errcode => 118, errstr => $struc };
        }
    }
    if ( defined( $attributes->{5} ) ) {                ## No truncation
        die { errcode => 113, errstr => 5 };
    }
    my $comp = $attributes->{6};
    if ($prefix) {
        if ( defined($comp) && ( $comp >= 2 ) ) {
            $prefix = "all$prefix= ";
        }
        else {
            $prefix = "$prefix=";
        }
    }

    my $q = $prefix . $this->{term};
        print "# q: $q\n";
        return $q;
}

1	dpavlin	13	#!/usr/bin/perl
2	dpavlin	6
3	dpavlin	13	use warnings;
4			use strict;
5
6	dpavlin	6	use Net::Z3950::SimpleServer;
7			use Net::Z3950::OID;
8			use COBISS;
9
10			my $max_records = 3; # XXX configure this
11			my $max_result_sets = 10;
12
13			sub diag {
14			print "# ", @_, $/;
15			}
16
17			sub InitHandle {
18			my $this = shift;
19			my $session = {};
20
21			$this->{HANDLE} = $session;
22			$this->{IMP_NAME} = "Z39.50 HTML scraping bot";
23			$this->{IMP_VER} = "0.1";
24			$session->{SETS} = {};
25			}
26
27			use Data::Dumper;
28
29			sub SearchHandle {
30			my $this = shift;
31
32			diag "SearchHandle ",Dumper($this);
33
34			my $session = $this->{HANDLE};
35			my $rpn = $this->{RPN};
36			my $query;
37
38			eval { $query = $rpn->{query}->render(); };
39			if ( $@ && ref($@) ) { ## Did someone/something report any errors?
40			$this->{ERR_CODE} = $@->{errcode};
41			$this->{ERR_STR} = $@->{errstr};
42			return;
43			}
44
45			diag "search for $query";
46
47			my $setname = $this->{SETNAME};
48			my $repl_set = $this->{REPL_SET};
49	dpavlin	13	diag "SETNAME $setname REPL_SET $repl_set";
50	dpavlin	6	my $result;
51			unless ( $result = COBISS->search( $query ) ) {
52			$this->{ERR_CODE} = 108;
53			return;
54			}
55	dpavlin	8	my $hits = $COBISS::hits \|\| diag "no results for $query";
56			diag "got $hits hits";
57	dpavlin	6	my $rs = {
58			lower => 1,
59			upper => $hits < $max_records ? $max_records : $hits,
60			data => $result->{'resultElements'}, # FIXME
61			};
62			my $sets = $session->{SETS};
63
64			if ( defined( $sets->{$setname} ) && !$repl_set ) {
65			$this->{ERR_CODE} = 21;
66			return;
67			}
68			if ( scalar keys %$sets >= $max_result_sets ) {
69			$this->{ERR_CODE} = 112;
70			$this->{ERR_STR} = "Max number is $max_result_sets";
71			return;
72			}
73			$sets->{$setname} = $rs;
74			$this->{HITS} = $session->{HITS} = $hits;
75			$session->{QUERY} = $query;
76			}
77
78			sub FetchHandle {
79			my $this = shift;
80			my $session = $this->{HANDLE};
81			my $setname = $this->{SETNAME};
82			my $req_form = $this->{REQ_FORM};
83			my $offset = $this->{OFFSET};
84			my $sets = $session->{SETS};
85			my $hits = $session->{HITS};
86			my $rs;
87			my $record;
88
89			diag Dumper( $this );
90
91			if ( !defined( $rs = $sets->{$setname} ) ) {
92			$this->{ERR_CODE} = 30;
93			return;
94			}
95			if ( $offset > $hits ) {
96			$this->{ERR_CODE} = 13;
97			return;
98			}
99			$this->{BASENAME} = "HtmlZ3950";
100
101			# if ( !defined($req_form) \|\| ( $req_form eq &Net::Z3950::OID::xml ) )
102			if (0)
103			{ ## XML records
104			$this->{REP_FORM} = &Net::Z3950::OID::xml;
105			$this->{RECORD} = '<xml>FIXME: not implementd</xml>';
106			}
107			elsif ( $req_form eq &Net::Z3950::OID::unimarc ) { # FIXME convert to usmarc
108			$this->{REP_FORM} = &Net::Z3950::OID::unimarc;
109	dpavlin	9	$this->{RECORD} = COBISS->fetch_rec('unimarc');
110	dpavlin	6	}
111	dpavlin	9	elsif ( $req_form eq &Net::Z3950::OID::usmarc ) { # FIXME convert to usmarc
112			$this->{REP_FORM} = &Net::Z3950::OID::usmarc;
113			$this->{RECORD} = COBISS->fetch_rec('usmarc');
114			}
115	dpavlin	6	else { ## Unsupported record format
116			$this->{ERR_CODE} = 239;
117			$this->{ERR_STR} = $req_form;
118			return;
119			}
120			if ( $offset == $hits ) {
121			$this->{LAST} = 1;
122			}
123			else {
124			$this->{LAST} = 0;
125			}
126			}
127
128			sub CloseHandle {
129			my $this = shift;
130			}
131
132			my $z = new Net::Z3950::SimpleServer(
133			INIT => \&InitHandle,
134			SEARCH => \&SearchHandle,
135			FETCH => \&FetchHandle,
136			CLOSE => \&CloseHandle
137			);
138			$z->launch_server( $0, @ARGV );
139
140			package Net::Z3950::RPN::And;
141
142			sub render {
143			my $this = shift;
144			return $this->[0]->render() . ' AND ' . $this->[1]->render();
145			}
146
147			package Net::Z3950::RPN::Or;
148
149			sub render {
150			my $this = shift;
151			return $this->[0]->render() . ' OR ' . $this->[1]->render();
152			}
153
154			package Net::Z3950::RPN::AndNot;
155
156			sub render {
157			my $this = shift;
158			return $this->[0]->render() . ' AND NOT ' . $this->[1]->render();
159			}
160
161			package Net::Z3950::RPN::Term;
162
163	dpavlin	13	use Data::Dump qw(dump);
164	dpavlin	6	use COBISS;
165
166			sub render {
167			my $this = shift;
168
169	dpavlin	13	print "render ", dump($this);
170	dpavlin	6
171	dpavlin	14	my $from = 'COBISS';
172
173			my $usemap = eval "${from}::usemap;";
174			warn "# $from usermap ",dump($usemap);
175
176	dpavlin	6	my $attributes = {};
177			my $prefix = "";
178			foreach my $attr ( @{ $this->{attributes} } ) {
179			my $type = $attr->{attributeType};
180			my $value = $attr->{attributeValue};
181			$attributes->{$type} = $value;
182			}
183			if ( defined( my $use = $attributes->{1} ) ) {
184	dpavlin	14	if ( defined( my $field = $usemap->{$use} ) ) {
185	dpavlin	6	$prefix = $field;
186			}
187			else {
188			die { errcode => 114, errstr => $use }; ## Unsupported use attribute
189			}
190			}
191			if ( defined( my $rel = $attributes->{2} ) )
192			{ ## No relation attributes supported
193			if ( $rel != 3 ) {
194			die { errcode => 117, errstr => $rel };
195			}
196			}
197			if ( defined( my $pos = $attributes->{3} ) )
198			{ ## No position attributes either
199			if ( $pos != 3 ) {
200			die { errcode => 119, errstr => $pos };
201			}
202			}
203			if ( defined( my $struc = $attributes->{4} ) ) { ## No structure
204			if ( ( $struc != 1 ) && ( $struc != 2 ) ) {
205			die { errcode => 118, errstr => $struc };
206			}
207			}
208			if ( defined( $attributes->{5} ) ) { ## No truncation
209			die { errcode => 113, errstr => 5 };
210			}
211			my $comp = $attributes->{6};
212			if ($prefix) {
213			if ( defined($comp) && ( $comp >= 2 ) ) {
214			$prefix = "all$prefix= ";
215			}
216			else {
217			$prefix = "$prefix=";
218			}
219			}
220
221			my $q = $prefix . $this->{term};
222			print "# q: $q\n";
223			return $q;
224			}
225