From 9b16ab623efe48723ba472624cf4020b155f683c Mon Sep 17 00:00:00 2001 From: djk Date: Wed, 1 Dec 1999 18:41:13 +0000 Subject: [PATCH] added callbot --- perl/Buck.pm | 146 +++++++++++++++++++++ perl/DB0SDX.pm | 132 +++++++++++++++++++ perl/ForkingServer.pm | 169 ++++++++++++++++++++++++ perl/K4UTE.pm | 132 +++++++++++++++++++ perl/QRZ.pm | 106 +++++++++++++++ perl/callbot.pl | 295 ++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 980 insertions(+) create mode 100644 perl/Buck.pm create mode 100644 perl/DB0SDX.pm create mode 100755 perl/ForkingServer.pm create mode 100644 perl/K4UTE.pm create mode 100644 perl/QRZ.pm create mode 100755 perl/callbot.pl diff --git a/perl/Buck.pm b/perl/Buck.pm new file mode 100644 index 00000000..abcb083a --- /dev/null +++ b/perl/Buck.pm @@ -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/\ //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 index 00000000..eef5ed66 --- /dev/null +++ b/perl/DB0SDX.pm @@ -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 index 00000000..31e01166 --- /dev/null +++ b/perl/ForkingServer.pm @@ -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 index 00000000..eef5ed66 --- /dev/null +++ b/perl/K4UTE.pm @@ -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 index 00000000..9723229a --- /dev/null +++ b/perl/QRZ.pm @@ -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/\ //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 index 00000000..6d845a21 --- /dev/null +++ b/perl/callbot.pl @@ -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); + + + + + -- 2.34.1