From 8bb293d5a1ca7a53f2ce50bd8e9e728865069b7f Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Mon, 9 Sep 2013 15:20:32 +0100 Subject: [PATCH] AsyncMsgise sh/db0sdx Add POST and on_disconnect handlers in AsyncMsg.pm --- Changes | 4 ++ cmd/show/db0sdx.pl | 123 ++++++++++++++++++++++----------------------- perl/AsyncMsg.pm | 32 ++++++++++-- perl/Version.pm | 4 +- 4 files changed, 95 insertions(+), 68 deletions(-) diff --git a/Changes b/Changes index ad657755..a73205f7 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,7 @@ +09Sep13======================================================================= +1. Make all the Net::Telnet based commands (sh/425, sh/contest, sh/db0sdx, + sh/wm7d, sh/ik3qar) asynchronous, so that they no longer pause the node + while they go off and query the internet for results. 06Sep13======================================================================= 1. Fixed sh/contest so that it works again. How it ever worked at all is a bit of a mystery. Now possible to type sh/cont dec or sh/cont dec 2013 diff --git a/cmd/show/db0sdx.pl b/cmd/show/db0sdx.pl index c99fd693..5132b2f9 100644 --- a/cmd/show/db0sdx.pl +++ b/cmd/show/db0sdx.pl @@ -8,35 +8,56 @@ # # -use Net::Telnet; +sub on_disc +{ + my $conn = shift; + my $dxchan = shift; + my @out; + + $conn->{sdxin} .= $conn->{msg}; # because there will be stuff left in the rx buffer because it isn't \n terminated + dbg("db0sdx in: $conn->{sdxin}") if isdbg('db0sdx'); -my ($self, $line) = @_; -my $call = $self->call; -my @out; + my ($info) = $conn->{sdxin} =~ m|([^<]*)|; + dbg("info: $info"); + + my @in = split /[\r\n]/, $info if $info; + if (@in && $in[0]) { + dbg("in qsl"); + push @out, @in; + } else { + dbg("in fault"); + ($info) = $conn->{sdxin} =~ m|([^<]*)|; + push @out, $info if $info; + push @out, $dxchan->msg('e3', 'DB0SDX', $conn->{sdxline}) unless @out; + } + $dxchan->send(@out); +} -$line = uc $line; -return (1, $self->msg('e24')) unless $Internet::allow; -return (1, "SHOW/DB0SDX , e.g. SH/DB0SDX ea7wa") unless $line && is_callsign($line); -my $target = $Internet::db0sdx_url || 'www.qslinfo.de'; -my $path = $Internet::db0sdx_path || '/qslinfo'; -my $suffix = $Internet::db0sdx_suffix || '.asmx'; -my $port = 80; -my $cmdprompt = '/query->.*$/'; +sub process +{ + my $conn = shift; + my $msg = shift; -my($info, $t); - -$t = new Net::Telnet; + $conn->{sdxin} .= "$msg\n"; + + dbg("db0sdx in: $conn->{sdxin}") if isdbg('db0sdx'); +} -dbg("db0sdx: contacting $target:$port") if isdbg('db0sdx'); -$info = $t->open(Host => $target, - Port => $port, - Timeout => 15); +sub handle +{ + my ($self, $line) = @_; + my $call = $self->call; + my @out; -if (!$info) { - push @out, $self->msg('e18', 'DB0SDX Database server'); -} else { + $line = uc $line; + return (1, $self->msg('e24')) unless $Internet::allow; + return (1, "SHOW/DB0SDX , e.g. SH/DB0SDX ea7wa") unless $line && is_callsign($line); + my $target = $Internet::db0sdx_url || 'www.qslinfo.de'; + my $path = $Internet::db0sdx_path || '/qslinfo'; + my $suffix = $Internet::db0sdx_suffix || '.asmx'; + my $port = 80; - dbg("db0sdx: connected to $target:$port") if isdbg('db0sdx'); + dbg("db0sdx: contacting $target:$port") if isdbg('db0sdx'); my $s = qq( @@ -46,48 +67,24 @@ if (!$info) { DXSpider V$main::version B$main::build ($call\@$main::mycall) - -); - - - my $lth = length($s)+7; +); + my $lth = length($s)+1; - dbg("db0sdx out: $s") if isdbg('db0sdx'); - - $t->print("POST $path$suffix HTTP/1.0"); - $t->print("Host: $target"); - $t->print("Content-Type: text/xml; charset=utf-8"); - $t->print("Content-Length: $lth"); - $t->print("Connection: Close"); - $t->print(qq{SOAPAction: "http://$target$path"}); - $t->print(""); - $t->put($s); - - my $in; - - while (my $result = eval { $t->getline(Timeout => 30) } || $@) { - if ($@) { - push @out, $self->msg('e18', 'DB0SDX Server'); - last; - } else { - $in .= $result; - } - } - - dbg("db0sdx in: $in") if isdbg('db0sdx'); - - # Log the lookup Log('call', "$call: show/db0sdx $line"); - $t->close; - - my ($info) = $in =~ m|([^<]*)|; - my @in = split /[\r\n]/, $info if $info; - if (@in && $in[0]) { - push @out, @in; + my $conn = AsyncMsg->post($self, $target, $port, "$path$suffix", prefix => 'sdx> ', filter => \&process, + 'Content-Type' => 'text/xml; charset=utf-8', + 'Content-Length' => $lth, + Connection => 'Close', + SOAPAction => qq{"http://$target$path"}, + data => $s, + on_disc => \&on_disc); + + if ($conn) { + $conn->{sdxcall} = $line; + push @out, $self->msg('m21', "show/db0sdx"); } else { - ($info) = $in =~ m|([^<]*)|; - push @out, $info if $info; - push @out, $self->msg('e3', 'DB0SDX', $line) unless @out; + push @out, $self->msg('e18', 'DB0SDX Database server'); } + + return (1, @out); } -return (1, @out); diff --git a/perl/AsyncMsg.pm b/perl/AsyncMsg.pm index 618fee15..0456efc9 100644 --- a/perl/AsyncMsg.pm +++ b/perl/AsyncMsg.pm @@ -132,9 +132,10 @@ sub new # Host: is always set to the name of the host (unless overridden) # User-Agent: is set to default above (unless overridden) # -sub get +sub _getpost { my $pkg = shift; + my $sort = shift; my $call = shift; my $host = shift; my $port = shift; @@ -147,25 +148,42 @@ sub get $conn->{state} = 'waitreply'; $conn->{filter} = delete $args{filter} if exists $args{filter}; $conn->{prefix} = delete $args{prefix} if exists $args{prefix}; + $conn->{on_disconnect} = delete $args{on_disc} || delete $args{on_disconnect}; $conn->{path} = $path; $r = $conn->connect($host, $port); if ($r) { - dbg("Sending 'GET $path HTTP/1.0'") if isdbg('async'); - $conn->send_later("GET $path HTTP/1.0\n"); + dbg("Sending '$sort $path HTTP/1.0'") if isdbg('async'); + $conn->send_later("$sort $path HTTP/1.0\n"); + my $h = delete $args{Host} || $host; my $u = delete $args{'User-Agent'} || "DxSpider;$main::version;$main::build;$^O;$main::mycall"; + my $d = delete $args{data}; + $conn->send_later("Host: $h\n"); $conn->send_later("User-Agent: $u\n"); while (my ($k,$v) = each %args) { $conn->send_later("$k: $v\n"); } + $conn->send_later("\n$d") if defined $d; $conn->send_later("\n"); } return $r ? $conn : undef; } +sub get +{ + my $pkg = shift; + _getpost($pkg, "GET", @_); +} + +sub post +{ + my $pkg = shift; + _getpost($pkg, "POST", @_); +} + # do a raw connection # # Async->raw($self, , , [handler => CODE ref], [prefix => ]); @@ -212,6 +230,14 @@ sub connect sub disconnect { my $conn = shift; + + if (my $ondisc = $conn->{on_disconnect}) { + my $dxchan = DXChannel::get($conn->{caller}); + if ($dxchan) { + no strict 'refs'; + $ondisc->($conn, $dxchan) + } + } delete $outstanding{$conn}; $conn->SUPER::disconnect; } diff --git a/perl/Version.pm b/perl/Version.pm index acd6cd8d..9e3f1dfc 100644 --- a/perl/Version.pm +++ b/perl/Version.pm @@ -11,7 +11,7 @@ use vars qw($version $subversion $build $gitversion); $version = '1.55'; $subversion = '0'; -$build = '130'; -$gitversion = 'cc83de0'; +$build = '131'; +$gitversion = '89eaa67'; 1; -- 2.34.1