From 9fc2ec17088fbff22e825133a4b9b3efe5384df3 Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Sat, 7 Sep 2013 18:47:48 +0100 Subject: [PATCH] mv HTTPMsg to AsyncMsg, add 'raw' method Convert sh/wm7d command to AsyncMsg. Modify all the HTTPMsg converted cmds to use AsyncMsg. Add a 'raw' 'telnet' handler. This allows one to query things with command prompts or stuff that isn't a HTTP server. But it ain't always easy. See the messing around in sh/wm7d I had to do, to get something that is stable given that the thing that I am looking doesn't have a \n at the end. It's just a prompt. --- cmd/show/contest.pl | 2 +- cmd/show/ik3qar.pl | 3 +- cmd/show/muf.pl | 2 + cmd/show/wm7d.pl | 67 +++++++++---- perl/AsyncMsg.pm | 227 ++++++++++++++++++++++++++++++++++++++++++ perl/DXCommandmode.pm | 4 +- perl/HTTPMsg.pm | 129 ------------------------ perl/Msg.pm | 6 +- perl/Version.pm | 4 +- 9 files changed, 284 insertions(+), 160 deletions(-) create mode 100644 perl/AsyncMsg.pm delete mode 100644 perl/HTTPMsg.pm diff --git a/cmd/show/contest.pl b/cmd/show/contest.pl index 94d8402a..a43e0ea7 100644 --- a/cmd/show/contest.pl +++ b/cmd/show/contest.pl @@ -53,7 +53,7 @@ sub handle dbg("sh/contest: url=$url") if isdbg("contest"); - my $r = HTTPMsg->get($self->call, $host, $port, $url); + my $r = AsyncMsg->get($self->call, $host, $port, $url, prefix=>'ctst> '); if ($r) { push @out, $self->msg('m21', "show/contest"); } diff --git a/cmd/show/ik3qar.pl b/cmd/show/ik3qar.pl index d18906ae..eed4ecf0 100644 --- a/cmd/show/ik3qar.pl +++ b/cmd/show/ik3qar.pl @@ -27,7 +27,8 @@ sub handle dbg("IK3QAR: url=$path") if isdbg('ik3qar'); Log('call', "$call: SH/IK3QAR $line"); - my $r = HTTPMsg->get($self->call, $target, $port, $path); + my $r = AsyncMsg->get($self, $target, $port, $path, prefix=>'qar> ', + 'User-Agent' => "DxSpider;$main::version;$main::build;$^O;$main::mycall;$call"); if ($r) { push @out, $self->msg('m21', "show/ik3qar"); } else { diff --git a/cmd/show/muf.pl b/cmd/show/muf.pl index 729b6584..3c01944b 100644 --- a/cmd/show/muf.pl +++ b/cmd/show/muf.pl @@ -9,6 +9,8 @@ # # +use Minimuf; + my ($self, $line) = @_; my @f = split /\s+/, $line; diff --git a/cmd/show/wm7d.pl b/cmd/show/wm7d.pl index 949d47af..068097ca 100644 --- a/cmd/show/wm7d.pl +++ b/cmd/show/wm7d.pl @@ -1,13 +1,41 @@ # # Query the WM7D Database server for a callsign # -# Largely based on "sh/qrz" and info in the Net::Telnet documentation +# Was Largely based on "sh/qrz" and info in the Net::Telnet documentation # -# Copyright (c) 2002 Charlie Carroll K1XX +# Original Copyright (c) 2002 Charlie Carroll K1XX # +# Async version (c) Dirk Koopman G1TLH # -# -use Net::Telnet; + +sub waitfor +{ + my $conn = shift; + my $msg = shift; + $msg =~ s/\cM//g; + + my $buf = $conn->{msg}; + $buf =~ s/\r/\\r/g; + $buf =~ s/\n/\\n/g; + dbg "state $conn->{state} '$msg' '$buf'"; + + if ($conn->{state} eq 'waitfor') { + if ($msg =~ /utc$/ ) { + $conn->send_later("$conn->{target_call}\n"); + $conn->{state} = 'working'; + } + } elsif ($conn->{state} eq 'working') { + if ($conn->{msg} =~ /^\rquery->\s*$/) { + $conn->send_later("QUIT\n"); + $conn->{state} = 'ending'; + } + return if $msg =~ /^query->/; + $conn->handle_raw($msg); + } else { + return if $msg =~ /^query->/ || $msg =~ /bye/; + $conn->handle_raw($msg); + } +} # wm7d accepts only single callsign sub handle @@ -17,6 +45,9 @@ sub handle my $call = $self->call; my @out; +# $DB::single = 1; + + # send 'e24' if allow in Internet.pm is not set to 1 return (1, $self->msg('e24')) unless $Internet::allow; return (1, "SHOW/WM7D , e.g. SH/WM7D k1xx") unless $line; @@ -24,27 +55,19 @@ sub handle my $port = 5000; my $cmdprompt = '/query->.*$/'; - my($info, $t); - - $t = new Net::Telnet; - $info = $t->open(Host => $target, - Port => $port, - Timeout => 20); + Log('call', "$call: show/wm7d \U$line"); - if (!$info) { + my $conn = AsyncMsg->raw($self, $target, $port, + handler => \&waitfor, prefix=>'wm7d> '); + if ($conn) { + $conn->{state} = 'waitfor'; + $conn->{target_call} = $line; + + push @out, $self->msg('m21', "show/wm7d"); + } else { push @out, $self->msg('e18', 'WM7D.net'); } - else { - ## Wait for prompt and respond with callsign. - $t->waitfor($cmdprompt); - $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; - } + return (1, @out); } diff --git a/perl/AsyncMsg.pm b/perl/AsyncMsg.pm new file mode 100644 index 00000000..618fee15 --- /dev/null +++ b/perl/AsyncMsg.pm @@ -0,0 +1,227 @@ +# +# This class is the internal subclass that does various Async connects and +# retreivals of info. Typical uses (and specific support) include http get and +# post. +# +# 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 AsyncMsg; + +use Msg; +use DXDebug; +use DXUtil; +use DXChannel; + +use vars qw(@ISA $deftimeout); + +@ISA = qw(Msg); +$deftimeout = 15; + +my %outstanding; + +# +# standard http get handler +# +sub handle_get +{ + my $conn = shift; + my $msg = shift; + + my $state = $conn->{state}; + + dbg("asyncmsg: $msg") if isdbg('async'); + + # no point in going on if there is no-one wanting the output anymore + my $dxchan = DXChannel::get($conn->{caller}); + unless ($dxchan) { + $conn->disconnect; + return; + } + + 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 { + my $prefix = $conn->{prefix} || ''; + $dxchan->send("$prefix$msg"); + } + } +} + +# +# simple raw handler +# +# Just outputs everything +# +sub handle_raw +{ + my $conn = shift; + my $msg = shift; + + # no point in going on if there is no-one wanting the output anymore + my $dxchan = DXChannel::get($conn->{caller}); + unless ($dxchan) { + $conn->disconnect; + return; + } + + # send out the data + my $prefix = $conn->{prefix} || ''; + $dxchan->send("$prefix$msg"); +} + +sub new +{ + my $pkg = shift; + my $call = shift; + my $handler = shift; + + my $conn = $pkg->SUPER::new($handler); + $conn->{caller} = ref $call ? $call->call : $call; + + # make it persistent + $outstanding{$conn} = $conn; + + return $conn; +} + +# This does a http get on a path on a host and +# returns the result (through an optional filter) +# +# expects to be called something like from a cmd.pl file: +# +# AsyncMsg->get($self, , , , [value>...] +# +# Standard key => value pairs are: +# +# filter => CODE ref (e.g. sub { ... }) +# prefix => prefix output with this string +# +# Anything else is taken and sent as (extra) http header stuff e.g: +# +# 'User-Agent' => qq{DXSpider;$main::version;$main::build;$^O} +# 'Content-Type' => q{text/xml; charset=utf-8} +# 'Content-Length' => $lth +# +# Host: is always set to the name of the host (unless overridden) +# User-Agent: is set to default above (unless overridden) +# +sub get +{ + my $pkg = shift; + my $call = shift; + my $host = shift; + my $port = shift; + my $path = shift; + my %args = @_; + + my $filter = shift; + + my $conn = $pkg->new($call, \&handle_get); + $conn->{state} = 'waitreply'; + $conn->{filter} = delete $args{filter} if exists $args{filter}; + $conn->{prefix} = delete $args{prefix} if exists $args{prefix}; + $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"); + my $h = delete $args{Host} || $host; + my $u = delete $args{'User-Agent'} || "DxSpider;$main::version;$main::build;$^O;$main::mycall"; + $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"); + } + + return $r ? $conn : undef; +} + +# do a raw connection +# +# Async->raw($self, , , [handler => CODE ref], [prefix => ]); +# +# With no handler defined, everything sent by the connection will be sent to +# the caller. +# +# One can send stuff out on the connection by doing a standard "$conn->send_later(...)" +# inside the (custom) handler. + +sub raw +{ + my $pkg = shift; + my $call = shift; + my $host = shift; + my $port = shift; + + my %args = @_; + + my $handler = delete $args{handler} || \&handle_raw; + my $conn = $pkg->new($call, $handler); + $conn->{prefix} = delete $args{prefix} if exists $args{prefix}; + $r = $conn->connect($host, $port); + return $r ? $conn : undef; +} + +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('async'); + } else { + dbg("HTTPMsg: ***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('async'); + } + + 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; + diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index d6319f3f..ad9baad0 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -36,7 +36,7 @@ use QSL; use DB_File; use VE7CC; use DXXml; -use HTTPMsg; +use AsyncMsg; use strict; use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase %nothereslug @@ -803,7 +803,7 @@ sub find_cmd_name { }; #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; use HTTPMsg; our \@ISA = qw{DXCommandmode}; ); + my $eval = qq(package DXCommandmode::$package; use POSIX qw{:math_h}; use DXLog; use DXDebug; use DXUser; use DXUtil; our \@ISA = qw{DXCommandmode}; ); if ($sub =~ m|\s*sub\s+handle\n|) { diff --git a/perl/HTTPMsg.pm b/perl/HTTPMsg.pm deleted file mode 100644 index 7918b932..00000000 --- a/perl/HTTPMsg.pm +++ /dev/null @@ -1,129 +0,0 @@ -# -# This class is the internal subclass that does the equivalent of a -# GET http:/// 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; - diff --git a/perl/Msg.pm b/perl/Msg.pm index 9251a120..83c82be6 100644 --- a/perl/Msg.pm +++ b/perl/Msg.pm @@ -506,9 +506,9 @@ sub dequeue my $conn = shift; return if $conn->{disconnecting}; - if ($conn->{msg} =~ /\n/) { - my @lines = split /\r?\n/, $conn->{msg}; - if ($conn->{msg} =~ /\n$/) { + if ($conn->{msg} =~ /\cJ/) { + my @lines = split /\cM?\cJ/, $conn->{msg}; + if ($conn->{msg} =~ /\cM?\cJ$/) { delete $conn->{msg}; } else { $conn->{msg} = pop @lines; diff --git a/perl/Version.pm b/perl/Version.pm index a45b4768..a5078436 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 = '125'; -$gitversion = 'a554922'; +$build = '128'; +$gitversion = '1ec21f9'; 1; -- 2.34.1