]> dxcluster.net Git - spider.git/blob - perl/callbot.pl
fixed rounding errors on two digit decimal places entries for frequency
[spider.git] / perl / callbot.pl
1 #!/usr/bin/perl -w
2 #
3 # an attempt at producing a general purpose 'bot' for going and getting
4 # things orf the web and presenting them to user in a form they want
5 #
6 # This program uses LWP::Parallel::UserAgent to do its business
7 #
8 # each sub bot has the same structure and calling interface, but the actual
9 # input and output data formats are completely arbitrary
10 #
11 # Copyright (c) 1999 - Dirk Koopman, Tobit Computer Co Ltd
12 #
13 # $Id$
14 #
15
16 package main;
17
18 BEGIN {
19         umask 002;
20         
21         # root of directory tree for this system
22         $root = "/spider"; 
23         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
24         
25         unshift @INC, "$root/perl";     # this IS the right way round!
26         unshift @INC, "$root/local";
27 }
28
29 use strict;
30 use ForkingServer;
31 require LWP::Parallel::UserAgent;
32 use HTTP::Request;
33 use URI::Escape;
34 use IO::File;
35 use Carp;
36 use Text::ParseWords;
37 use QRZ;
38 use Buck;
39 use K4UTE;
40
41 use vars qw($version);
42
43 $version = "1.1";
44
45 sub cease
46 {
47         $SIG{INT} = $SIG{TERM} = 'IGNORE';
48         exit(0);
49 }
50
51 sub trancode
52 {
53         $_ = shift;
54
55         return 'Continue' if /100/;
56         return 'Switching protocols' if /101/;
57         
58         return 'Ok' if /200/;
59         return 'Created' if /201/;
60         return 'Accepted' if /202/;
61         return 'Non Authoritive' if /203/;
62         return 'No Content' if /204/;
63         return 'Reset Content' if /205/;
64         return 'Partial Content' if /206/;
65
66         return 'Multiple Choices' if /300/;
67         return 'Moved Permanently' if /301/;
68         return 'Found, redirect' if /302/;
69         return 'See Other' if /303/;
70         return 'Not modified' if /304/;
71         return 'Use proxy' if /305/;
72
73         return 'Bad request' if /400/;
74         return 'Unauthorized' if /401/;
75         return 'Payment required' if /402/;
76         return 'Forbidden' if /403/;
77         return 'Not Found' if /404/;
78         return 'Method not allowed' if /405/;
79         return 'Not acceptable' if /406/;
80         return 'Proxy authentication required' if /407/;
81         return 'Request timeout' if /408/;
82         return 'Conflict' if /409/;
83         return 'Gone' if /410/;
84         return 'Length required' if /411/;
85         return 'Precondition failed' if /412/;
86         return 'Request entity too large' if /413/;
87         return 'Request-URI too long' if /414/;
88         return 'Unsupported media type' if /415/;
89         return 'Requested range not satifiable' if /416/;
90         return 'Expectation failed' if /417/;
91         
92     return 'Internal server error' if /500/;
93         return 'Not implemented' if /501/;
94         return 'Bad gateway' if /502/;
95         return 'Service unavailable' if /503/;
96         return 'Gateway timeout' if /504/;
97         return 'HTTP version not supported' if /505/;
98         
99         return 'Unknown';
100 }
101
102 sub genpat
103 {
104         my $s = shift;
105         $s =~ s/\*/\\S+/g;
106         $s =~ s/\b(?:THE|\&|A|AND|OR|NOT)\b//gi;
107         $s =~ s/(?:\(|\))//g;
108         return join('|', split(/\s+/, $s));
109 }
110
111 # qrz specific routines
112 sub req_qrz
113 {
114         my ($ua, $call, $title) = @_;
115         my $sreq = "http://www.qrz.com/callsign.html?callsign=$call"; 
116 #       print "$sreq\n";
117         my $req = HTTP::Request->new('GET', $sreq);
118     return $ua->register($req);
119 }
120
121 sub parse_qrz
122 {
123         my ($fh, $call, $title, $code, $content) = @_;
124         if ($code != 200) {
125                 print $fh "QRZ|$code|", trancode($code), "\n";
126                 return;
127         }
128
129         # parse the HTML
130         my $r = new QRZ $call;
131         $r->debug(0);
132         my $i;
133     my $chunk;
134         my $l = length $content;
135         for ($i = 0; $i < $l && ($chunk = substr($content, $i, 512)); $i += 512) {
136                 $r->parse($chunk);
137         }
138         $r->eof;
139         
140         my @lines = $r->answer;
141         for (@lines) {
142                 print $fh "QRZ|$code|$_\n" if $_;
143         }
144         print "lines: ", scalar @lines, "\n";
145 }
146
147 # k4ute specific routines
148 sub req_ute
149 {
150         my ($ua, $call, $title) = @_;
151         my $sreq = "http://no4j.com/nfdxa/qsl/index.asp?dx=$call"; 
152 #       print "$sreq\n";
153         my $req = HTTP::Request->new('GET', $sreq);
154     return $ua->register($req);
155 }
156
157 sub parse_ute
158 {
159         my ($fh, $call, $title, $code, $content) = @_;
160         if ($code != 200) {
161                 print $fh "UTE|$code|", trancode($code), "\n";
162                 return;
163         }
164
165         # parse the HTML
166         my $r = new K4UTE $call;
167         $r->debug(0);
168         my $i;
169     my $chunk;
170         my $l = length $content;
171         for ($i = 0; $i < $l && ($chunk = substr($content, $i, 512)); $i += 512) {
172                 $r->parse($chunk);
173         }
174         $r->eof;
175         
176         my @lines = $r->answer;
177         for (@lines) {
178                 print $fh "UTE|$code|$_\n" if $_;
179         }
180         print "lines: ", scalar @lines, "\n";
181 }
182
183 # buckmaster specific routines
184 sub req_buck
185 {
186         my ($ua, $call, $title) = @_;
187         my $sreq = "http://www.buck.com/cgi-bin/do_hamcallexe"; 
188 #       print "$sreq\n";
189         my $req = HTTP::Request->new('POST', $sreq);
190         $req->add_content("entry=$call");
191     return $ua->register($req);
192 }
193
194 sub parse_buck
195 {
196         my ($fh, $call, $title, $code, $content) = @_;
197         if ($code != 200) {
198                 print $fh "BCK|$code|", trancode($code), "\n";
199                 return;
200         }
201
202         # parse the HTML
203         my $r = new Buck $call;
204         $r->debug(0);
205         my $i;
206     my $chunk;
207         my $l = length $content;
208         for ($i = 0; $i < $l && ($chunk = substr($content, $i, 512)); $i += 512) {
209                 $r->parse($chunk);
210         }
211         $r->eof;
212         
213         my @lines = $r->answer;
214         for (@lines) {
215                 print $fh "BCK|$code|$_\n" if $_;
216         }
217         print "lines: ", scalar @lines, "\n";
218 }
219
220
221 # this is what is called when an incoming request is taken
222 sub child
223 {
224         my $fh = shift;
225         
226         my $line;
227
228         if (defined ($line = <$fh>)) {
229                 $line =~ s/[\r\n]+$//g;
230                 print "{$line}\n";
231         } else {
232                 return;
233         }
234
235         $line =~ s/^[^[A-Za-z0-9\|]]+//g;
236         
237         my ($call, $title) = split /\|/, $line;
238         return if $call eq 'quit' || $call eq 'QUIT';
239
240         print "{A = '$call'";
241         print $title ?  ", T = '$title'}\n" : "}\n";
242
243         my $ua = LWP::Parallel::UserAgent->new;
244
245         # set up various UA things
246         $ua->duplicates(0);      # ignore duplicates
247         $ua->timeout(30);        
248         $ua->redirect(1);        # follow 302 redirects 
249         $ua->agent("DXSpider callbot $version");
250
251         my $res;
252         my $art = uri_escape($call);
253         my $tit = uri_escape($title);
254
255         # qrz
256         if ($res = req_qrz($ua, $art, $tit)) {
257                 print $fh "QRZ|500\n";
258         }
259         # buckmaster
260         if ($res = req_buck($ua, $art, $tit)) {
261                 print $fh "BCK|500\n";
262         }
263         # ute
264         if ($res = req_ute($ua, $art, $tit)) {
265                 print $fh "UTE|500\n";
266         }
267
268         # wait for all the results to come back
269         my $entries = $ua->wait();
270         
271         for (keys %$entries) {
272                 $res = $entries->{$_}->response;
273                 my $uri = $res->request->url;
274                 my $code = $res->code;
275                 print "url: ", $uri, " code: ", $code, "\n";
276
277                 # now parse each result
278                 for ($uri) {
279                         parse_qrz($fh, $call, $title, $code, $res->content), last if /www.qrz.com/i;
280                         parse_buck($fh, $call, $title, $code, $res->content), last if /www.buck.com/i;
281                         parse_ute($fh, $call, $title, $code, $res->content), last if /no4j.com/i;
282                 }
283         }
284         cease(0);
285 }
286
287 $SIG{INT} = \&cease;
288 $SIG{QUIT} = \&cease;
289 $SIG{HUP} = 'IGNORE';
290 STDOUT->autoflush(1);
291
292 my $server = new ForkingServer \&child;
293
294 $server->allow('.*');
295 $server->run;
296
297 cease(0);
298
299
300
301
302