This is a start of making all the Net::Telnet things redundant.
HTTPMsg.pm is likely to be substantially modified or replaced.
W.I.P
#
#
-my ($self, $line) = @_;
+sub handle
+{
+ my ($self, $line) = @_;
-#return (1, "usage: sh/contest [<month>] [<year>], e g sh/contest sep 2012") unless $line;
+ return (1, $self->msg('e24')) unless $Internet::allow;
-my @out;
+ my @out;
-my $mon;;
+ #$DB::single = 1;
-#$DB::single = 1;
+ # trying to make the syntax abit more user friendly...
+ # and yes, I have been here and it *is* all my fault (dirk)
+ $line = lc $line;
+ my ($m,$y);
+ ($y) = $line =~ /(\d+)/;
+ ($m) = $line =~ /([a-z]{3})/;
-# trying to make the syntax abit more user friendly...
-# and yes, I have been here and it *is* all my fault (dirk)
-$line = lc $line;
-my ($m,$y);
-($y) = $line =~ /(\d+)/;
-($m) = $line =~ /([a-z]{3})/;
-
-unless ($y) {
- ($y) = (gmtime)[5];
- $y += 1900;
-}
-unless ($m) {
- ($m) = (gmtime)[4];
- $m = lc $DXUtil::month[$m];
-}
-$y += 2000 if $y <= 50;
-$y += 1900 if $y > 50 && $y <= 99;
-$m = substr $m, 0, 3 if length $m > 3;
-$m = 'oct' if $m eq 'okt';
-$m = 'may' if $m eq 'mai' || $m eq 'maj';
-$mon = "$y$m";
-
-dbg("sh/contest: month=$mon") if isdbg('contest');
-
-my $filename = "c" . $mon . ".txt";
-my $host = $Internet::contest_host || 'www.sk3bg.se';
-my $port = 80;
+ unless ($y) {
+ ($y) = (gmtime)[5];
+ $y += 1900;
+ }
+ unless ($m) {
+ ($m) = (gmtime)[4];
+ $m = lc $DXUtil::month[$m];
+ }
+ $y += 2000 if $y <= 50;
+ $y += 1900 if $y > 50 && $y <= 99;
+ $m = substr $m, 0, 3 if length $m > 3;
+ $m = 'oct' if $m eq 'okt';
+ $m = 'may' if $m eq 'mai' || $m eq 'maj';
+ my $mon = "$y$m";
-dbg("sh/contest: host=$host:$port") if isdbg('contest');
+ dbg("sh/contest: month=$mon") if isdbg('contest');
-my $url = $Internet::contest_url || "/contest/text";
-$url .= "/$filename";
+ my $filename = "c" . $mon . ".txt";
+ my $host = $Internet::contest_host || 'www.sk3bg.se';
+ my $port = 80;
-dbg("sh/contest: url=$url") if isdbg("contest");
+ dbg("sh/contest: host=$host:$port") if isdbg('contest');
-my $t = new Net::Telnet (Telnetmode => 0);
-eval { $t->open(Host => $host, Port => $port, Timeout => 15); };
+ my $url = $Internet::contest_url || "/contest/text";
+ $url .= "/$filename";
-if (!$t || $@) {
- push @out, $self->msg('e18','sk3bg.se');
-} else {
- my $s = "GET $url HTTP/1.0";
- dbg("sh/contest: get='$s'") if isdbg('contest');
-
- $t->print($s);
- $t->print("Host: $host\n");
- $t->print("\n\n");
+ dbg("sh/contest: url=$url") if isdbg("contest");
- my $notfound = $t->getline(Timeout => 10);
- if (!$notfound || $notfound =~ /404 Object Not Found/) {
- push @out, "there is no contest info for $mon at $host/$url";
- return (1, @out);
- } else {
- push @out, $notfound;
+ my $r = HTTPMsg->get($self->call, $host, $port, $url);
+ if ($r) {
+ push @out, $self->msg('m21', "show/contest");
+ }
+ else {
+ push @out, $self->msg('e18','sk3bg.se');
}
- while (!$t->eof) {
- eval { push @out, $t->getline(Timeout => 10); };
- if ($@) {
- push @out, $self->msg('e18', 'sk3bg.se');
- last;
- }
- }
-}
-$t->close;
-return (1, @out);
+ return (1, @out);
+}
#
# $Id$
#
-my ($self, $line) = @_;
-my @list = map {uc} split /\s+/, $line; # generate a list of callsigns
-my $op;
-my $call = $self->call;
-my @out;
-return (1, $self->msg('e24')) unless $Internet::allow;
-return (1, "SHOW/IK3QAR <callsign>\n e.g. SH/IK3QAR II5I, SH/IK3QAR V51AS\n") unless @list;
+sub handle
+{
+ my ($self, $line) = @_;
+ my $op;
+ my $call = $self->call;
+ my @out;
-my $target = $Internet::ik3qar_url;
-my $port = 80;
-my $url = "http://".$target;
+ return (1, $self->msg('e24')) unless $Internet::allow;
+ return (1, "SHOW/IK3QAR <callsign>\n e.g. SH/IK3QAR II5I, SH/IK3QAR V51AS\n") unless $line;
-use Net::Telnet;
-my $t = new Net::Telnet;
-eval {$t->open( Host => $target,
- Port => $port,
- Timeout => 30);
-};
+ my $target = $Internet::ik3qar_url;
+ my $port = 80;
+ my $url = "http://".$target;
-if (!$t || $@) {
- push @out, $self->msg('e18', 'Open(IK3QAR.it)');
-} else {
- dbg($list[0]."|".$list[1]) if isdbg('IK3QAR');
- $op="call=".$list[0]."&node=".$main::mycall."&passwd=".$Internet::ik3qar_pw."&user=".$call;
- my $s = "GET $url/manager/dxc/dxcluster.php?$op HTTP/1.0\n"
- ."User-Agent:DxSpider;$main::version;$main::build;$^O;$main::mycall;$call\n\n";
- dbg($s) if isdbg('IK3QAR');
- $t->print($s);
- Log('call', "$call: SH/IK3QAR $list[0]");
- my $state = "blank";
- my $count = 1;
- while (my $result = eval { $t->getline(Timeout => 30) } || $@) {
- dbg($result) if isdbg('IK3QAR') && $result;
- ++$count;
- if ($count > 9) {
- push @out, $result;
- }
- }
- $t->close;
- push @out, $self->msg('e3', 'Search(IK3QAR.it)', uc $list[0]) unless @out;
+ $line = uc $line;
+ dbg("IK3QAR: call = $line") if isdbg('ik3qar');
+ $op="call=$line\&node=$main::mycall\&passwd=$Internet::ik3qar_pw\&user=$call";
+ my $path = "/manager/dxc/dxcluster.php?$op";
+ dbg("IK3QAR: url=$path") if isdbg('ik3qar');
+ Log('call', "$call: SH/IK3QAR $line");
+
+ my $r = HTTPMsg->get($self->call, $target, $port, $path);
+ if ($r) {
+ push @out, $self->msg('m21', "show/ik3qar");
+ } else {
+ push @out, $self->msg('e18', 'Open(IK3QAR.it)');
+ }
+
+ return (1, @out);
}
-
-return (1, @out);
#
# wm7d accepts only single callsign
-my ($self, $line) = @_;
-my $call = $self->call;
-my @out;
+sub handle
+{
-# send 'e24' if allow in Internet.pm is not set to 1
-return (1, $self->msg('e24')) unless $Internet::allow;
-return (1, "SHOW/WM7D <callsign>, e.g. SH/WM7D k1xx") unless $line;
-my $target = $Internet::wm7d_url || 'www.wm7d.net';
-my $port = 5000;
-my $cmdprompt = '/query->.*$/';
+ my ($self, $line) = @_;
+ my $call = $self->call;
+ my @out;
-my($info, $t);
+ # send 'e24' if allow in Internet.pm is not set to 1
+ return (1, $self->msg('e24')) unless $Internet::allow;
+ return (1, "SHOW/WM7D <callsign>, e.g. SH/WM7D k1xx") unless $line;
+ my $target = $Internet::wm7d_url || 'www.wm7d.net';
+ my $port = 5000;
+ my $cmdprompt = '/query->.*$/';
+
+ my($info, $t);
-$t = new Net::Telnet;
-$info = $t->open(Host => $target,
- Port => $port,
- Timeout => 20);
+ $t = new Net::Telnet;
+ $info = $t->open(Host => $target,
+ Port => $port,
+ Timeout => 20);
-if (!$info) {
- push @out, $self->msg('e18', 'WM7D.net');
-} else {
+ if (!$info) {
+ push @out, $self->msg('e18', 'WM7D.net');
+ }
+ else {
## Wait for prompt and respond with callsign.
$t->waitfor($cmdprompt);
- $t->print($line);
+ $t->print($line);
($info) = $t->waitfor($cmdprompt);
- # Log the lookup
- Log('call', "$call: show/wm7d \U$line");
- $t->close;
- push @out, split /[\r\n]+/, $info;
+ # Log the lookup
+ Log('call', "$call: show/wm7d \U$line");
+ $t->close;
+ push @out, split /[\r\n]+/, $info;
+ }
+ return (1, @out);
}
-return (1, @out);
+
use Sun;
use Internet;
use Script;
-use Net::Telnet;
use QSL;
use DB_File;
use VE7CC;
use DXXml;
+use HTTPMsg;
use strict;
use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase %nothereslug
};
#wrap the code into a subroutine inside our unique package
- my $eval = qq(package DXCommandmode::$package; use POSIX qw{:math_h}; use DXLog; use DXDebug; use DXUser; use DXUtil; use Minimuf; use Sun; our \@ISA = qw{DXCommandmode}; );
+ my $eval = qq(package DXCommandmode::$package; use POSIX qw{:math_h}; use DXLog; use DXDebug; use DXUser; use DXUtil; use Minimuf; use Sun; use HTTPMsg; our \@ISA = qw{DXCommandmode}; );
if ($sub =~ m|\s*sub\s+handle\n|) {
--- /dev/null
+#
+# This class is the internal subclass that does the equivalent of a
+# GET http://<some site>/<some path> and passes the result back to the caller.
+#
+# This merely starts up a Msg handler (and no DXChannel) ($conn in other words)
+# does the GET, parses out the result and the data and then (assuming a positive
+# result and that the originating callsign is still online) punts out the data
+# to the caller.
+#
+# It isn't designed to be very clever.
+#
+# Copyright (c) 2013 - Dirk Koopman G1TLH
+#
+
+package HTTPMsg;
+
+use Msg;
+use DXDebug;
+use DXUtil;
+use DXChannel;
+
+use vars qw(@ISA $deftimeout);
+
+@ISA = qw(Msg);
+$deftimeout = 15;
+
+my %outstanding;
+
+sub handle
+{
+ my $conn = shift;
+ my $msg = shift;
+
+ my $state = $conn->{state};
+
+ dbg("httpmsg: $msg") if isdbg('http');
+
+ # no point in going on if there is no-one wanting the output anymore
+ my $dxchan = DXChannel::get($conn->{caller});
+ return unless $dxchan;
+
+ if ($state eq 'waitreply') {
+ # look at the reply code and decide whether it is a success
+ my ($http, $code, $ascii) = $msg =~ m|(HTTP/\d\.\d)\s+(\d+)\s+(.*)|;
+ if ($code == 200) {
+ # success
+ $conn->{state} = 'waitblank';
+ } else {
+ $dxchan->send("$code $ascii");
+ $conn->disconnect;
+ }
+ } elsif ($state eq 'waitblank') {
+ unless ($msg) {
+ $conn->{state} = 'indata';
+ }
+ } else {
+ if (my $filter = $conn->{filter}) {
+ no strict 'refs';
+ # this will crash if the command has been redefined and the filter is a
+ # function defined there whilst the request is in flight,
+ # but this isn't exactly likely in a production environment.
+ $filter->($conn, $msg, $dxchan);
+ } else {
+ $dxchan->send($msg);
+ }
+ }
+}
+
+sub get
+{
+ my $pkg = shift;
+ my $call = shift;
+ my $host = shift;
+ my $port = shift;
+ my $path = shift;
+ my $filter = shift;
+
+ my $conn = $pkg->new(\&handle);
+ $conn->{caller} = $call;
+ $conn->{state} = 'waitreply';
+ $conn->{host} = $host;
+ $conn->{port} = $port;
+ $conn->{filter} = $filter if $filter;
+
+ # make it persistent
+ $outstanding{$conn} = $conn;
+
+ $r = $conn->connect($host, $port);
+ if ($r) {
+ dbg("Sending 'GET $path HTTP/1.0'") if isdbg('http');
+ $conn->send_later("GET $path HTTP/1.0\nHost: $host\nUser-Agent: DxSpider;$main::version;$main::build;$^O;$main::mycall;$call\n\n");
+ }
+
+ return $r;
+}
+
+sub connect
+{
+ my $conn = shift;
+ my $host = shift;
+ my $port = shift;
+
+ # start a connection
+ my $r = $conn->SUPER::connect($host, $port);
+ if ($r) {
+ dbg("HTTPMsg: Connected $conn->{cnum} to $host $port") if isdbg('http');
+ } else {
+ dbg("HTTPMsg: ***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('http');
+ }
+
+ return $r;
+}
+
+sub disconnect
+{
+ my $conn = shift;
+ delete $outstanding{$conn};
+ $conn->SUPER::disconnect;
+}
+
+sub DESTROY
+{
+ my $conn = shift;
+ delete $outstanding{$conn};
+ $conn->SUPER::DESTROY;
+}
+
+1;
+
m18 => 'Sorry, message $_[0] is currently set to KEEP',
m19 => 'Startup Script for $_[0] saved, $_[1] lines',
m20 => 'Empty Startup Script for $_[0] deleted',
+ m21 => '$_[0] Working...',
maxconnect => 'Max connections on $_[0] set to $_[1]',
msg1 => 'Bulletin Messages Queued',
msg2 => 'Private Messages Queued',
$noconns++;
- dbg("Connection created ($noconns)") if isdbg('connll');
+ dbg("$class Connection $conn->{cnum} created (total $noconns)") if isdbg('connll');
return bless $conn, $class;
}
if (ref $pkg) {
$call = $pkg->{call} unless $call;
return undef unless $call;
- dbg("changing $pkg->{call} to $call") if isdbg('connll') && exists $pkg->{call} && $call ne $pkg->{call};
+ dbg((ref $pkg) . " changing $pkg->{call} to $call") if isdbg('connll') && exists $pkg->{call} && $call ne $pkg->{call};
delete $conns{$pkg->{call}} if exists $pkg->{call} && exists $conns{$pkg->{call}} && $pkg->{call} ne $call;
$pkg->{call} = $call;
$ref = $conns{$call} = $pkg;
- dbg("Connection $pkg->{cnum} $call stored") if isdbg('connll');
+ dbg((ref $pkg) . " Connection $pkg->{cnum} $call stored") if isdbg('connll');
} else {
$ref = $conns{$call};
}
$conn->{peerhost} = $to_host;
$conn->{peerport} = $to_port;
$conn->{sort} = 'Outgoing';
+
+ dbg((ref $conn) . " connecting $conn->{cnum} to $to_host:$to_port") if isdbg('connll');
my $sock;
if ($blocking_supported) {
}
$conn->{sock} = $sock;
- $conn->{peerhost} = $sock->peerhost; # for consistency
+# $conn->{peerhost} = $sock->peerhost; # for consistency
+
+ dbg((ref $conn) . " connected $conn->{cnum} to $to_host:$to_port") if isdbg('connll');
if ($conn->{rproc}) {
my $callback = sub {$conn->_rcv};
delete $conns{$call} if $ref && $ref == $conn;
}
$call ||= 'unallocated';
- dbg("Connection $conn->{cnum} $call disconnected") if isdbg('connll');
+ dbg((ref $conn) . " Connection $conn->{cnum} $call disconnected") if isdbg('connll');
# get rid of any references
for (keys %$conn) {
sub dequeue
{
my $conn = shift;
-
+ return if $conn->{disconnecting};
+
if ($conn->{msg} =~ /\n/) {
my @lines = split /\r?\n/, $conn->{msg};
if ($conn->{msg} =~ /\n$/) {
$conn->{msg} = pop @lines;
}
for (@lines) {
+ last if $conn->{disconnecting};
&{$conn->{rproc}}($conn, defined $_ ? $_ : '');
}
}
my $call = $conn->{call} || 'unallocated';
my $host = $conn->{peerhost} || '';
my $port = $conn->{peerport} || '';
- dbg("Connection $conn->{cnum} $call [$host $port] being destroyed") if isdbg('connll');
$noconns--;
+ dbg((ref $conn) . " Connection $conn->{cnum} $call [$host $port] being destroyed (total $noconns)") if isdbg('connll');
}
1;
$version = '1.55';
$subversion = '0';
-$build = '124';
-$gitversion = 'c675748';
+$build = '125';
+$gitversion = 'a554922';
1;
projects / spider.git / commitdiff