perl/callbot.pl

   1 #!/usr/bin/env perl
   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 #
  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