/[Z3950-HTML-Scraper]/server.pl
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 /server.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 14 - (show annotations)
Fri Oct 22 21:31:08 2010 UTC (8 years, 5 months ago) by dpavlin
File MIME type: text/plain
File size: 5548 byte(s)
make usemap configurable

1 #!/usr/bin/perl
2
3 use warnings;
4 use strict;
5
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 diag "SETNAME $setname REPL_SET $repl_set";
50 my $result;
51 unless ( $result = COBISS->search( $query ) ) {
52 $this->{ERR_CODE} = 108;
53 return;
54 }
55 my $hits = $COBISS::hits || diag "no results for $query";
56 diag "got $hits hits";
57 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 $this->{RECORD} = COBISS->fetch_rec('unimarc');
110 }
111 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 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 use Data::Dump qw(dump);
164 use COBISS;
165
166 sub render {
167 my $this = shift;
168
169 print "render ", dump($this);
170
171 my $from = 'COBISS';
172
173 my $usemap = eval "${from}::usemap;";
174 warn "# $from usermap ",dump($usemap);
175
176 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 if ( defined( my $field = $usemap->{$use} ) ) {
185 $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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26