]> dxcluster.org Git - spider.git/commitdiff
added callbot
authordjk <djk>
Wed, 1 Dec 1999 18:41:13 +0000 (18:41 +0000)
committerdjk <djk>
Wed, 1 Dec 1999 18:41:13 +0000 (18:41 +0000)
perl/Buck.pm [new file with mode: 0644]
perl/DB0SDX.pm [new file with mode: 0644]
perl/ForkingServer.pm [new file with mode: 0755]
perl/K4UTE.pm [new file with mode: 0644]
perl/QRZ.pm [new file with mode: 0644]
perl/callbot.pl [new file with mode: 0755]

diff --git a/perl/Buck.pm b/perl/Buck.pm
new file mode 100644 (file)
index 0000000..abcb083
--- /dev/null
@@ -0,0 +1,146 @@
+#!/usr/bin/perl -w
+
+package Buck;
+
+use HTML::Parser;
+use Data::Dumper;
+use DXUtil;
+
+@ISA = qw( HTML::Parser );
+
+use strict;
+
+sub new
+{
+    my $pkg = shift;
+       my $self = SUPER::new $pkg;
+       $self->{list} = [];
+       $self->{state} = 'pre';
+    $self->{sort} = undef;
+       $self->{debug} = 0;
+    $self->{call} = uc shift;
+       return $self;
+}
+
+sub start
+{
+       my ($self, $tag, $attr, $attrseq, $origtext) = @_;
+       if ($self->{debug}) {
+               print "$self->{state} $tag";
+        if ($attr) {
+                       my $dd = new Data::Dumper([$attr], [qw(attr)]);
+                       $dd->Terse(1);
+                       $dd->Indent(0);
+                       $dd->Quotekeys(0);
+                       print " ", $dd->Dumpxs;
+               }
+               print "\n";
+       }
+       if ($self->{state} eq 'pre' && $tag eq 'table') {
+               $self->state('t1');
+       } elsif ($self->{state} eq 't1' && $tag eq 'table') {
+               $self->state('t2');
+       } elsif ($self->{state} eq 't2' && $tag =~ /^h/) {
+               $self->{addr} = "";
+               $self->{laddr} = 0;
+               $self->state('addr');
+       } elsif ($self->{state} eq 'addr') {
+               if ($tag eq 'br') {
+                       $self->{addr} .= ", " if length $self->{addr} > $self->{laddr};
+                       $self->{laddr} = length $self->{addr};
+               } elsif ($tag eq 'p') {
+            push @{$self->{list}}, $self->{addr} ? "$self->{call}|addr|$self->{addr}" : "$self->{call}|addr|unknown";
+                       $self->state('semail');
+               }
+       } elsif ($self->{state} eq 'email') {
+               if ($tag eq 'a') {
+                       my $email = $attr->{href};
+                       if ($email && $email =~ /mailto/i) {
+                               $email =~ s/mailto://i;
+                               push @{$self->{list}}, "$self->{call}|email|$email";
+                       }
+               } elsif ($tag eq 'br' || $tag eq 'p') {
+                       $self->state('post');
+               }
+       } elsif ($self->{state} eq 'post' && $tag eq 'form') {
+               if (exists $self->{pos} && length $self->{pos}) {
+                       push @{$self->{list}}, "$self->{call}|location|$self->{pos}";
+                       $self->state('last');
+               }
+       }
+}
+
+sub text
+{
+       my ($self, $text) = @_;
+       $text =~ s/^[\s\r\n]+//g;
+       $text =~ s/[\s\r\n]+$//g;
+    print "$self->{state} text $text\n" if $self->{debug};     
+       if (length $text) {
+               if ($self->{state} eq 'addr') {
+                       $text =~ s/\&nbsp;//gi;
+                       $self->{addr} .= $text;
+               } elsif ($self->{state} eq 'semail' && $text =~ /Email/i ) {
+                       $self->state('email');
+               } elsif ($self->{state} eq 'post') {
+                       if ($text =~ /Latitude/i) {
+                               $self->state('lat');
+                               $self->{pos} = "" unless $self->{pos};
+                       } elsif ($text =~ /Longitude/i) {
+                               $self->state('long');
+                               $self->{pos} = "" unless $self->{pos};
+                       } elsif ($text =~ /Grid/i) {
+                               $self->state('grid');
+                               $self->{pos} = "" unless $self->{pos};
+                       }
+               } elsif ($self->{state} eq 'lat') {
+                       my ($n, $l) = $text =~ /(\b[\d\.]+\b)\s+([NSns])/;
+                       $n = -$n if $l eq 'S' || $l eq 's';
+                       $self->{pos} = slat($n);
+                       $self->state('post');
+               } elsif ($self->{state} eq 'long') {
+                       my ($n, $l) = $text =~ /(\b[\d\.]+\b)\s+([EWew])/;
+                       $n = -$n if $l eq 'W' || $l eq 'w';
+                       $self->{pos} .= "|" . slong($n);
+                       $self->state('post');
+               } elsif ($self->{state} eq 'grid') {
+                       my ($qra) = $text =~ /(\b\w\w\d\d\w\w\b)/;
+                       $self->{pos} .= "|" . uc $qra;
+                       push @{$self->{list}}, "$self->{call}|location|$self->{pos}";
+                       $self->state('last');
+               } elsif (($self->{state} eq 'pre' || $self->{state} =~ /^t/) && $text =~ /not\s+found/) {
+            push @{$self->{list}}, "$self->{call}|addr|unknown";
+                       $self->state('last');
+               } elsif ($self->{state} eq 'email' && $text =~ /unknown/i) {
+                       $self->state('post');
+               }
+       }
+}
+
+sub state
+{
+       my $self = shift;
+       $self->{state} = shift if @_;
+       return $self->{state};
+}
+
+sub end
+{
+       my ($self, $tag, $origtext) = @_;
+    print "$self->{state} /$tag\n" if $self->{debug};
+}
+
+sub debug
+{
+       my ($self, $val) = @_;
+       $self->{debug} = $val;
+}
+
+sub answer
+{
+       my $self = shift;
+       return @{$self->{list}};
+}
+
+1;
+
diff --git a/perl/DB0SDX.pm b/perl/DB0SDX.pm
new file mode 100644 (file)
index 0000000..eef5ed6
--- /dev/null
@@ -0,0 +1,132 @@
+#!/usr/bin/perl -w
+
+package K4UTE;
+
+use HTML::Parser;
+use Data::Dumper;
+
+@ISA = qw( HTML::Parser );
+
+use strict;
+
+sub new
+{
+    my $pkg = shift;
+       my $self = SUPER::new $pkg;
+       $self->{list} = [];
+       $self->{state} = 'pre';
+    $self->{sort} = undef;
+       $self->{debug} = 0;
+    $self->{call} = uc shift;
+       return $self;
+}
+
+sub start
+{
+       my ($self, $tag, $attr, $attrseq, $origtext) = @_;
+       if ($self->{debug}) {
+               print "$self->{state} $tag";
+        if ($attr) {
+                       my $dd = new Data::Dumper([$attr], [qw(attr)]);
+                       $dd->Terse(1);
+                       $dd->Indent(0);
+                       $dd->Quotekeys(0);
+                       print " ", $dd->Dumpxs;
+               }
+               print "\n";
+       }
+       if ($tag eq 'tr' ) {
+               if ($self->{state} eq 't1') {
+                       $self->state('t1r');
+               } elsif ($self->{state} eq 't1r') {
+                       $self->state('t1d1');
+               } elsif ($self->{state} eq 't2') {
+                       $self->state('t2r');
+               } elsif ($self->{state} eq 't2r') {
+                       $self->state('t2d1');
+               }
+       } 
+}
+
+sub text
+{
+       my ($self, $text) = @_;
+       $text =~ s/^[\s\r\n]+//g;
+       $text =~ s/[\s\r\n]+$//g;
+    print "$self->{state} text $text\n" if $self->{debug};     
+       if (length $text) {
+               if ($self->{state} eq 'pre' && $text =~ /$self->{call}/i ) {
+                       $self->state('t1');
+                       $self->{addr} = "";
+                       $self->{laddr} = 0;
+               } elsif ($self->{state} eq 't1d1') {
+                       $self->{dxcall} = $text;
+                       $self->state('t1d2');
+               } elsif ($self->{state} eq 't1d2') {
+                       $self->{dxmgr} = $text;
+                       $self->state('t1d3');
+               } elsif ($self->{state} eq 't1d3') {
+                       $self->{dxdate} = amdate($text);
+                       $self->state('t1d4');
+               } elsif ($self->{state} eq 't1d4') {
+                       push @{$self->{list}}, "$self->{dxcall}|mgr|$self->{dxmgr}|$self->{dxdate}|$text";
+                       $self->state('t1e');
+               } elsif ($self->{state} eq 't2d1') {
+                       $self->{dxcall} = $text;
+                       $self->state('t2d2');
+               } elsif ($self->{state} eq 't2d2') {
+                       $self->{dxaddr} = $text;
+                       $self->state('t2d3');
+               } elsif ($self->{state} eq 't2d3') {
+                       $self->{dxdate} = amdate($text);
+                       $self->state('t2d4');
+               } elsif ($self->{state} eq 't2d4') {
+                       push @{$self->{list}}, "$self->{dxcall}|addr|$self->{dxaddr}|$self->{dxdate}|$text";
+                       $self->state('t2e');
+               } elsif ($self->{state} eq 't2' && $text =~ /did\s+not\s+return/i) {
+                       $self->state('last');
+               }
+       }
+}
+
+sub end
+{
+       my ($self, $tag, $origtext) = @_;
+    print "$self->{state} /$tag\n" if $self->{debug};
+       if ($self->{state} =~ /^t1/ && $tag eq 'table') {
+               $self->state('t2');
+       } elsif ($self->{state} =~ /^t2/ && $tag eq 'table') {
+               $self->state('last');
+       }
+}
+
+sub amdate
+{
+       my $text = shift;
+       my ($m, $d, $y) = split m{/}, $text;
+       $y += 1900;
+       $y += 100 if $y < 1990;
+       return sprintf "%02d-%s-%d", $d, (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$m-1], $y;
+}
+
+sub state
+{
+       my $self = shift;
+       $self->{state} = shift if @_;
+       return $self->{state};
+}
+
+sub debug
+{
+       my ($self, $val) = @_;
+       $self->{debug} = $val;
+}
+
+sub answer
+{
+       my $self = shift;
+       return @{$self->{list}};
+}
+
+1;
+
diff --git a/perl/ForkingServer.pm b/perl/ForkingServer.pm
new file mode 100755 (executable)
index 0000000..31e0116
--- /dev/null
@@ -0,0 +1,169 @@
+#!/usr/bin/perl -w
+#
+# This is a forking server class (ofcourse it is :-)
+#
+# You can only have one of these running at a time, so there!
+#
+# I am not using AUTOLOAD at the moment in a general spirit
+# of 'inat' (a wonderfully succinct serbo-croat word and state
+# of being) - So there! Yah boo sucks! Won't! Nurps! 
+#
+# Can I just say (as a policy statement) that I hope I never have
+# to write any more C code (other than to extend or interface to perl).
+#
+# Copyright (c) 1999 - Dirk Koopman, Tobit Computer Co Ltd
+#
+# $Id$
+#
+
+package ForkingServer;
+
+use strict;
+
+use IO::File;
+use IO::Socket;
+use Net::hostent;
+
+use Carp;
+
+sub new
+{
+       my $type = shift;
+       my $self = {};
+       my $s = shift;
+       if ($s) {
+               if (ref $s) {
+                       $self->{child} = $s;
+               } else {
+                       $self->{child} = eval $s;
+                       confess $@ if $@;
+               }
+       }
+       $self->{port} = shift || 9000;
+       $self->{sort} = 'tcp';
+       $self->{sorry} = "Bog OFF!\n";
+       $self->{allow} = [ '^localhost\$', '^127.0.0' ];
+       return bless $self, $type;
+}
+
+sub port
+{
+       my $self = shift;
+       my $port = shift;
+       $self->{port} = $port;
+}
+
+sub sort
+{
+       my $self = shift;
+       my $sort = shift;
+       confess "sort must be tcp or udp" unless $sort eq 'tcp' || $sort eq 'udp'; 
+       $self->{sort} = $sort;
+}
+
+sub allow
+{
+       my $self = shift;
+       $self->{allow} = ref $_[0] ? shift : [ @_ ];
+}
+
+sub deny
+{
+       my $self = shift;
+       $self->{deny} = ref $_[0] ? shift : [ @_ ];
+}
+
+sub sorry
+{
+       my $self = shift;
+       $self->{sorry} = shift;
+}
+
+sub quiet
+{
+       my $self = shift;
+       $self->{quiet} = shift;
+}
+
+sub is_parent
+{
+       my $self = shift;
+       return $self->{parent};
+}
+
+sub run {
+       my $self = shift;
+       
+       my $server = IO::Socket::INET->new( Proto     => $self->{sort},
+                                                                               LocalPort => $self->{port},
+                                                                               Listen    => SOMAXCONN,
+                                                                               Reuse     => 1);
+
+       my $client;
+       
+       confess "bot: can't setup server $!" unless $server;
+       print "[Server $0 accepting clients on port $self->{port}]\n" unless $self->{quiet};
+       
+       $SIG{CHLD} = \&reaper;
+       $self->{parent} = 1;
+       
+       while ($client = $server->accept()) {
+               $client->autoflush(1);
+               my $hostinfo = gethostbyaddr($client->peeraddr);
+               my $hostname = $hostinfo->name;
+               my $ipaddr = $client->peerhost;
+               unless ($self->{quiet}) {
+                       printf ("[Connect from %s %s]\n", $hostname, $ipaddr);
+               }
+               if ($self->{allow} && @{$self->{allow}}) {
+                       unless ((grep { $hostname =~ /$_/ } @{$self->{allow}}) || (grep { $ipaddr =~ /$_/ } @{$self->{allow}})) {
+                               print "{failed on allow}\n" unless $self->{quiet};
+                               $client->print($self->{sorry});
+                               $client->close;
+                               next;
+                       }
+               }
+               if ($self->{deny} && @{$self->{deny}}) {
+                       if ((grep { $hostname =~ /$_/ } @{$self->{deny}}) || (grep { $ipaddr =~ /$_/ } @{$self->{deny}})) {
+                               print "{failed on deny}\n" unless $self->{quiet};
+                               $client->print($self->{sorry});
+                               $client->close;
+                               next;
+                       }
+               }
+               
+               # fork off a copy of myself, we don't exec, merely carry on regardless
+               # in the forked program, that should mean that we use the minimum of extra
+               # resources 'cos we are sharing everything already.
+               my $pid = fork();
+               die "bot: can't fork" unless defined $pid;
+               if ($pid) {
+                       
+                       # in parent
+                       print "{child $pid created}\n" unless $self->{quiet};
+                       close $client;
+               } else {
+                       
+                       # in child
+                       $SIG{'INT'} = $SIG{'TERM'} = $SIG{CHLD} = 'DEFAULT';
+                       $server->close;
+                       delete $self->{parent};
+                       die "No Child function defined" unless $self->{child} && ref $self->{child};
+                       &{$self->{child}}($client);
+                       $client->close;
+                       return;                 
+               }
+       }
+}
+
+sub reaper {
+       my $child;
+       $child = wait;
+       $SIG{CHLD} = \&reaper;  # still loathe sysV
+}
+
+1;
+
+
+
+
diff --git a/perl/K4UTE.pm b/perl/K4UTE.pm
new file mode 100644 (file)
index 0000000..eef5ed6
--- /dev/null
@@ -0,0 +1,132 @@
+#!/usr/bin/perl -w
+
+package K4UTE;
+
+use HTML::Parser;
+use Data::Dumper;
+
+@ISA = qw( HTML::Parser );
+
+use strict;
+
+sub new
+{
+    my $pkg = shift;
+       my $self = SUPER::new $pkg;
+       $self->{list} = [];
+       $self->{state} = 'pre';
+    $self->{sort} = undef;
+       $self->{debug} = 0;
+    $self->{call} = uc shift;
+       return $self;
+}
+
+sub start
+{
+       my ($self, $tag, $attr, $attrseq, $origtext) = @_;
+       if ($self->{debug}) {
+               print "$self->{state} $tag";
+        if ($attr) {
+                       my $dd = new Data::Dumper([$attr], [qw(attr)]);
+                       $dd->Terse(1);
+                       $dd->Indent(0);
+                       $dd->Quotekeys(0);
+                       print " ", $dd->Dumpxs;
+               }
+               print "\n";
+       }
+       if ($tag eq 'tr' ) {
+               if ($self->{state} eq 't1') {
+                       $self->state('t1r');
+               } elsif ($self->{state} eq 't1r') {
+                       $self->state('t1d1');
+               } elsif ($self->{state} eq 't2') {
+                       $self->state('t2r');
+               } elsif ($self->{state} eq 't2r') {
+                       $self->state('t2d1');
+               }
+       } 
+}
+
+sub text
+{
+       my ($self, $text) = @_;
+       $text =~ s/^[\s\r\n]+//g;
+       $text =~ s/[\s\r\n]+$//g;
+    print "$self->{state} text $text\n" if $self->{debug};     
+       if (length $text) {
+               if ($self->{state} eq 'pre' && $text =~ /$self->{call}/i ) {
+                       $self->state('t1');
+                       $self->{addr} = "";
+                       $self->{laddr} = 0;
+               } elsif ($self->{state} eq 't1d1') {
+                       $self->{dxcall} = $text;
+                       $self->state('t1d2');
+               } elsif ($self->{state} eq 't1d2') {
+                       $self->{dxmgr} = $text;
+                       $self->state('t1d3');
+               } elsif ($self->{state} eq 't1d3') {
+                       $self->{dxdate} = amdate($text);
+                       $self->state('t1d4');
+               } elsif ($self->{state} eq 't1d4') {
+                       push @{$self->{list}}, "$self->{dxcall}|mgr|$self->{dxmgr}|$self->{dxdate}|$text";
+                       $self->state('t1e');
+               } elsif ($self->{state} eq 't2d1') {
+                       $self->{dxcall} = $text;
+                       $self->state('t2d2');
+               } elsif ($self->{state} eq 't2d2') {
+                       $self->{dxaddr} = $text;
+                       $self->state('t2d3');
+               } elsif ($self->{state} eq 't2d3') {
+                       $self->{dxdate} = amdate($text);
+                       $self->state('t2d4');
+               } elsif ($self->{state} eq 't2d4') {
+                       push @{$self->{list}}, "$self->{dxcall}|addr|$self->{dxaddr}|$self->{dxdate}|$text";
+                       $self->state('t2e');
+               } elsif ($self->{state} eq 't2' && $text =~ /did\s+not\s+return/i) {
+                       $self->state('last');
+               }
+       }
+}
+
+sub end
+{
+       my ($self, $tag, $origtext) = @_;
+    print "$self->{state} /$tag\n" if $self->{debug};
+       if ($self->{state} =~ /^t1/ && $tag eq 'table') {
+               $self->state('t2');
+       } elsif ($self->{state} =~ /^t2/ && $tag eq 'table') {
+               $self->state('last');
+       }
+}
+
+sub amdate
+{
+       my $text = shift;
+       my ($m, $d, $y) = split m{/}, $text;
+       $y += 1900;
+       $y += 100 if $y < 1990;
+       return sprintf "%02d-%s-%d", $d, (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$m-1], $y;
+}
+
+sub state
+{
+       my $self = shift;
+       $self->{state} = shift if @_;
+       return $self->{state};
+}
+
+sub debug
+{
+       my ($self, $val) = @_;
+       $self->{debug} = $val;
+}
+
+sub answer
+{
+       my $self = shift;
+       return @{$self->{list}};
+}
+
+1;
+
diff --git a/perl/QRZ.pm b/perl/QRZ.pm
new file mode 100644 (file)
index 0000000..9723229
--- /dev/null
@@ -0,0 +1,106 @@
+#!/usr/bin/perl -w
+
+package QRZ;
+
+use HTML::Parser;
+use Data::Dumper;
+
+@ISA = qw( HTML::Parser );
+
+use strict;
+
+sub new
+{
+    my $pkg = shift;
+       my $self = SUPER::new $pkg;
+       $self->{list} = [];
+       $self->{state} = 'pre';
+    $self->{sort} = undef;
+       $self->{debug} = 0;
+    $self->{call} = uc shift;
+       return $self;
+}
+
+sub start
+{
+       my ($self, $tag, $attr, $attrseq, $origtext) = @_;
+       if ($self->{debug}) {
+               print "$self->{state} $tag";
+        if ($attr) {
+                       my $dd = new Data::Dumper([$attr], [qw(attr)]);
+                       $dd->Terse(1);
+                       $dd->Indent(0);
+                       $dd->Quotekeys(0);
+                       print " ", $dd->Dumpxs;
+               }
+               print "\n";
+       }
+       if ($self->{state} eq 'addr') {
+               if ($tag eq 'br') {
+                       $self->{addr} .= ", " if length $self->{addr} > $self->{laddr};
+                       $self->{laddr} = length $self->{addr};
+               } elsif ($tag eq 'p') {
+            push @{$self->{list}}, $self->{addr} ? "$self->{call}|addr|$self->{addr}" : "$self->{call}|addr|unknown";
+                       $self->state('semail');
+               }
+       } elsif ($self->{state} eq 'email') {
+               if ($tag eq 'a') {
+                       my $email = $attr->{href};
+                       if ($email) {
+                               return if $email =~ m{/uedit.html};
+                               $email =~ s/mailto://i;
+                               push @{$self->{list}}, "$self->{call}|email|$email";
+                       }
+               } elsif ($tag eq 'br' || $tag eq 'p') {
+                       $self->state('post');
+               }
+       }
+}
+
+sub text
+{
+       my ($self, $text) = @_;
+       $text =~ s/^[\s\r\n]+//g;
+       $text =~ s/[\s\r\n]+$//g;
+    print "$self->{state} text $text\n" if $self->{debug};     
+       if (length $text) {
+               if ($self->{state} eq 'pre' && $text =~ /$self->{call}/i ) {
+                       $self->state('addr');
+                       $self->{addr} = "";
+                       $self->{laddr} = 0;
+               } elsif ($self->{state} eq 'addr') {
+                       $text =~ s/\&nbsp;//gi;
+                       $self->{addr} .= $text;
+               } elsif ($self->{state} eq 'semail' && $text =~ /Email/i ) {
+                       $self->state('email');
+               }
+       }
+}
+
+sub state
+{
+       my $self = shift;
+       $self->{state} = shift if @_;
+       return $self->{state};
+}
+
+sub end
+{
+       my ($self, $tag, $origtext) = @_;
+    print "$self->{state} /$tag\n" if $self->{debug};
+}
+
+sub debug
+{
+       my ($self, $val) = @_;
+       $self->{debug} = $val;
+}
+
+sub answer
+{
+       my $self = shift;
+       return @{$self->{list}};
+}
+
+1;
+
diff --git a/perl/callbot.pl b/perl/callbot.pl
new file mode 100755 (executable)
index 0000000..6d845a2
--- /dev/null
@@ -0,0 +1,295 @@
+#!/usr/bin/perl -w
+#
+# an attempt at producing a general purpose 'bot' for going and getting
+# things orf the web and presenting them to user in a form they want
+#
+# This program uses LWP::Parallel::UserAgent to do its business
+#
+# each sub bot has the same structure and calling interface, but the actual
+# input and output data formats are completely arbitrary
+#
+# Copyright (c) 1999 - Dirk Koopman, Tobit Computer Co Ltd
+#
+# $Id$
+#
+
+package main;
+
+BEGIN {
+       unshift @INC, '.';
+}
+
+use strict;
+use ForkingServer;
+require LWP::Parallel::UserAgent;
+use HTTP::Request;
+use URI::Escape;
+use IO::File;
+use Carp;
+use Text::ParseWords;
+use QRZ;
+use Buck;
+use K4UTE;
+
+use vars qw($version);
+
+$version = "1.1";
+
+sub cease
+{
+       $SIG{INT} = $SIG{TERM} = 'IGNORE';
+       exit(0);
+}
+
+sub trancode
+{
+       $_ = shift;
+
+       return 'Continue' if /100/;
+       return 'Switching protocols' if /101/;
+       
+       return 'Ok' if /200/;
+       return 'Created' if /201/;
+       return 'Accepted' if /202/;
+       return 'Non Authoritive' if /203/;
+       return 'No Content' if /204/;
+       return 'Reset Content' if /205/;
+       return 'Partial Content' if /206/;
+
+       return 'Multiple Choices' if /300/;
+       return 'Moved Permanently' if /301/;
+       return 'Found, redirect' if /302/;
+       return 'See Other' if /303/;
+       return 'Not modified' if /304/;
+       return 'Use proxy' if /305/;
+
+       return 'Bad request' if /400/;
+       return 'Unauthorized' if /401/;
+       return 'Payment required' if /402/;
+       return 'Forbidden' if /403/;
+       return 'Not Found' if /404/;
+       return 'Method not allowed' if /405/;
+       return 'Not acceptable' if /406/;
+       return 'Proxy authentication required' if /407/;
+       return 'Request timeout' if /408/;
+       return 'Conflict' if /409/;
+       return 'Gone' if /410/;
+       return 'Length required' if /411/;
+       return 'Precondition failed' if /412/;
+       return 'Request entity too large' if /413/;
+       return 'Request-URI too long' if /414/;
+       return 'Unsupported media type' if /415/;
+       return 'Requested range not satifiable' if /416/;
+       return 'Expectation failed' if /417/;
+       
+    return 'Internal server error' if /500/;
+       return 'Not implemented' if /501/;
+       return 'Bad gateway' if /502/;
+       return 'Service unavailable' if /503/;
+       return 'Gateway timeout' if /504/;
+       return 'HTTP version not supported' if /505/;
+       
+       return 'Unknown';
+}
+
+sub genpat
+{
+       my $s = shift;
+       $s =~ s/\*/\\S+/g;
+       $s =~ s/\b(?:THE|\&|A|AND|OR|NOT)\b//gi;
+       $s =~ s/(?:\(|\))//g;
+       return join('|', split(/\s+/, $s));
+}
+
+# qrz specific routines
+sub req_qrz
+{
+       my ($ua, $call, $title) = @_;
+       my $sreq = "http://www.qrz.com/callsign.html?callsign=$call"; 
+#      print "$sreq\n";
+       my $req = HTTP::Request->new('GET', $sreq);
+    return $ua->register($req);
+}
+
+sub parse_qrz
+{
+       my ($fh, $call, $title, $code, $content) = @_;
+       if ($code != 200) {
+               print $fh "QRZ|$code|", trancode($code), "\n";
+               return;
+       }
+
+       # parse the HTML
+       my $r = new QRZ $call;
+       $r->debug(0);
+       my $i;
+    my $chunk;
+       my $l = length $content;
+       for ($i = 0; $i < $l && ($chunk = substr($content, $i, 512)); $i += 512) {
+               $r->parse($chunk);
+       }
+       $r->eof;
+       
+       my @lines = $r->answer;
+       for (@lines) {
+               print $fh "QRZ|$code|$_\n" if $_;
+       }
+       print "lines: ", scalar @lines, "\n";
+}
+
+# k4ute specific routines
+sub req_ute
+{
+       my ($ua, $call, $title) = @_;
+       my $sreq = "http://no4j.com/nfdxa/qsl/index.asp?dx=$call"; 
+#      print "$sreq\n";
+       my $req = HTTP::Request->new('GET', $sreq);
+    return $ua->register($req);
+}
+
+sub parse_ute
+{
+       my ($fh, $call, $title, $code, $content) = @_;
+       if ($code != 200) {
+               print $fh "UTE|$code|", trancode($code), "\n";
+               return;
+       }
+
+       # parse the HTML
+       my $r = new K4UTE $call;
+       $r->debug(0);
+       my $i;
+    my $chunk;
+       my $l = length $content;
+       for ($i = 0; $i < $l && ($chunk = substr($content, $i, 512)); $i += 512) {
+               $r->parse($chunk);
+       }
+       $r->eof;
+       
+       my @lines = $r->answer;
+       for (@lines) {
+               print $fh "UTE|$code|$_\n" if $_;
+       }
+       print "lines: ", scalar @lines, "\n";
+}
+
+# buckmaster specific routines
+sub req_buck
+{
+       my ($ua, $call, $title) = @_;
+       my $sreq = "http://www.buck.com/cgi-bin/do_hamcallexe"; 
+#      print "$sreq\n";
+       my $req = HTTP::Request->new('POST', $sreq);
+       $req->add_content("entry=$call");
+    return $ua->register($req);
+}
+
+sub parse_buck
+{
+       my ($fh, $call, $title, $code, $content) = @_;
+       if ($code != 200) {
+               print $fh "BCK|$code|", trancode($code), "\n";
+               return;
+       }
+
+       # parse the HTML
+       my $r = new Buck $call;
+       $r->debug(0);
+       my $i;
+    my $chunk;
+       my $l = length $content;
+       for ($i = 0; $i < $l && ($chunk = substr($content, $i, 512)); $i += 512) {
+               $r->parse($chunk);
+       }
+       $r->eof;
+       
+       my @lines = $r->answer;
+       for (@lines) {
+               print $fh "BCK|$code|$_\n" if $_;
+       }
+       print "lines: ", scalar @lines, "\n";
+}
+
+
+# this is what is called when an incoming request is taken
+sub child
+{
+       my $fh = shift;
+       
+       my $line;
+
+       if (defined ($line = <$fh>)) {
+               $line =~ s/[\r\n]+$//g;
+               print "{$line}\n";
+       } else {
+               return;
+       }
+
+       $line =~ s/^[^[A-Za-z0-9\|]]+//g;
+       
+       my ($call, $title) = split /\|/, $line;
+       return if $call eq 'quit' || $call eq 'QUIT';
+
+       print "{A = '$call'";
+       print $title ?  ", T = '$title'}\n" : "}\n";
+
+       my $ua = LWP::Parallel::UserAgent->new;
+
+       # set up various UA things
+       $ua->duplicates(0);      # ignore duplicates
+       $ua->timeout(30);        
+       $ua->redirect(1);        # follow 302 redirects 
+       $ua->agent("DXSpider callbot $version");
+
+       my $res;
+       my $art = uri_escape($call);
+       my $tit = uri_escape($title);
+
+       # qrz
+       if ($res = req_qrz($ua, $art, $tit)) {
+               print $fh "QRZ|500\n";
+       }
+       # buckmaster
+       if ($res = req_buck($ua, $art, $tit)) {
+               print $fh "BCK|500\n";
+       }
+       # ute
+       if ($res = req_ute($ua, $art, $tit)) {
+               print $fh "UTE|500\n";
+       }
+
+       # wait for all the results to come back
+       my $entries = $ua->wait();
+       
+       for (keys %$entries) {
+               $res = $entries->{$_}->response;
+               my $uri = $res->request->url;
+               my $code = $res->code;
+               print "url: ", $uri, " code: ", $code, "\n";
+
+               # now parse each result
+               for ($uri) {
+                       parse_qrz($fh, $call, $title, $code, $res->content), last if /www.qrz.com/i;
+                       parse_buck($fh, $call, $title, $code, $res->content), last if /www.buck.com/i;
+                       parse_ute($fh, $call, $title, $code, $res->content), last if /no4j.com/i;
+               }
+       }
+       cease(0);
+}
+
+$SIG{INT} = \&cease;
+$SIG{QUIT} = \&cease;
+$SIG{HUP} = 'IGNORE';
+STDOUT->autoflush(1);
+
+my $server = new ForkingServer \&child;
+
+$server->allow('.*');
+$server->run;
+
+cease(0);
+
+
+
+
+