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