From ed2d469812ca5ab82baab7f8b4795660e01ef539 Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Tue, 27 Dec 2011 13:59:32 +0000 Subject: [PATCH] now with async sh/qrz! There is a new DXCommandmode::http_get() async http get routine that is callable from a command such as sh/qrz. --- cmd/show/qrz.pl | 82 +++++++++++++++++++++++-------------------- perl/DXChannel.pm | 21 +++++++++++ perl/DXCommandmode.pm | 49 ++++++++++++++++++++++++++ perl/Messages | 2 ++ perl/Version.pm | 4 +-- perl/cluster.pl | 3 ++ 6 files changed, 120 insertions(+), 41 deletions(-) diff --git a/cmd/show/qrz.pl b/cmd/show/qrz.pl index 9a3f9c3f..a5d14138 100644 --- a/cmd/show/qrz.pl +++ b/cmd/show/qrz.pl @@ -17,50 +17,54 @@ return (1, "SHOW/QRZ , e.g. SH/QRZ g1tlh") unless @list; my $target = $Internet::http_proxy || $Internet::qrz_url || 'xml.qrz.com'; my $port = $Internet::http_proxy_port || 80; my $url = ''; -$url = 'http://' . ($Internet::qrz_url | 'xml.qrz.com') if $Internet::http_proxy; +$url = 'http://' . ($Internet::qrz_url || 'xml.qrz.com') if $Internet::http_proxy; +foreach $l (@list) { -use Net::Telnet; + my $host = $url?$url:$target; + my $s = "$url/xml?callsign=$l;username=$Internet::qrz_uid;password=$Internet::qrz_pw;agent=dxspider"; + if (isdbg('qrz')) { + dbg("qrz: $host"); + dbg("qrz: $s"); + } -my $t = new Net::Telnet; + Log('call', "$call: show/qrz \U$l"); + push @out, $self->msg('http1', "show/qrz \U$l"); -foreach $l (@list) { - eval { - $t->open(Host => $target, - Port => $port, - Timeout => 15); - }; + $self->http_get($host, $s, sub + { + my ($response, $header, $body) = @_; + my @out; - if (!$t || $@) { - push @out, $self->msg('e18', 'QRZ.com'); - } else { - my $s = "GET /xml?callsign=$l;username=$Internet::qrz_uid;password=$Internet::qrz_pw;agent=dxspider HTTP/1.0\n\n"; - dbg($s) if isdbg('qrz'); - $t->print($s); - Log('call', "$call: show/qrz \U$l"); - my $state = "blank"; - while (my $result = eval { $t->getline(Timeout => 30) } || $@) { - dbg($result) if isdbg('qrz') && $result; - if ($@) { - push @out, $self->msg('e18', 'QRZ.com'); - last; - } - if ($state eq 'blank' && $result =~ /^/i) { - $state = 'go'; - } elsif ($state eq 'go') { - next if $result =~ m||; - next if $result =~ m||; - next if $result =~ m||; - next if $result =~ m||; - next if $result =~ m||; - last if $result =~ m||; - my ($tag, $data) = $result =~ m|^\s*<(\w+)>(.*)close; - push @out, $self->msg('e3', 'qrz.com', uc $l) unless @out; - } + if (isdbg('qrz')) { + dbg("qrz response: $response"); + dbg("qrz body: $body"); + } + Log('call', "$call: show/qrz \U$body"); + my $state = "blank"; + foreach my $result (split /\r?\n/, $body) { + dbg("qrz: $result") if isdbg('qrz') && $result; + if ($state eq 'blank' && $result =~ /^/i) { + $state = 'go'; + } elsif ($state eq 'go') { + next if $result =~ m||; + next if $result =~ m||; + next if $result =~ m||; + next if $result =~ m||; + next if $result =~ m||; + last if $result =~ m||; + my ($tag, $data) = $result =~ m|^\s*<(\w+)>(.*)msg('http2', "show/qrz \U$l"); + } else { + push @out, $self->msg('e3', 'show/qrz', uc $l); + } + $self->send_ans(@out); + } + ); } return (1, @out); diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 584a541c..64a9a1ae 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -125,6 +125,7 @@ $count = 0; inqueue => '9,Input Queue,parray', next_pc92_update => '9,Next PC92 Update,atime', next_pc92_keepalive => '9,Next PC92 KeepAlive,atime', + anyevents => '9,outstanding AnyEvent handles,parray', ); $maxerrors = 20; # the maximum number of concurrent errors allowed before disconnection @@ -179,6 +180,7 @@ sub alloc $self->{cq} = $dxcc[1]->cq; } $self->{inqueue} = []; + $self->{anyevents} = []; $count++; dbg("DXChannel $self->{call} created ($count)") if isdbg('chan'); @@ -752,6 +754,25 @@ sub handle_xml return $r; } +sub anyevent_add +{ + my $self = shift; + my $handle = shift; + my $sort = shift || "unknown"; + + push @{$self->{anyevents}}, $handle; + dbg("anyevent: add $sort handle making " . scalar @{$self->{anyevents}} . " handles in use") if isdbg('anyevent'); +} + +sub anyevent_del +{ + my $self = shift; + my $handle = shift; + my $sort = shift || "unknown"; + $self->{anyevents} = [ grep {$_ != $handle} @{$self->{anyevents}} ]; + dbg("anyevent: delete $sort handle making " . scalar @{$self->{anyevents}} . " handles in use") if isdbg('anyevent'); +} + #no strict; sub AUTOLOAD { diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 79835177..a9777cbf 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -13,6 +13,10 @@ package DXCommandmode; @ISA = qw(DXChannel); +use AnyEvent; +use AnyEvent::Handle; +use AnyEvent::Socket; + use POSIX qw(:math_h); use DXUtil; use DXChannel; @@ -1233,5 +1237,50 @@ sub send_motd } $self->send_file($motd) if -e $motd; } + +sub http_get +{ + my $self = shift; + my ($host, $uri, $cb) = @_; + + # store results here + my ($response, $header, $body); + + my $handle; + $handle = AnyEvent::Handle->new( + connect => [$host => 'http'], + on_error => sub { + $cb->("HTTP/1.0 500 $!"); + $self->anyevent_del($handle); + $handle->destroy; # explicitly destroy handle + }, + on_eof => sub { + $cb->($response, $header, $body); + $self->anyevent_del($handle); + $handle->destroy; # explicitly destroy handle + } + ); + $self->anyevent_add($handle); + $handle->push_write ("GET $uri HTTP/1.0\015\012\015\012"); + + # now fetch response status line + $handle->push_read (line => sub { + my ($handle, $line) = @_; + $response = $line; + }); + + # then the headers + $handle->push_read (line => "\015\012\015\012", sub { + my ($handle, $line) = @_; + $header = $line; + }); + + # and finally handle any remaining data as body + $handle->on_read (sub { + $body .= $_[0]->rbuf; + $_[0]->rbuf = ""; + }); +} + 1; __END__ diff --git a/perl/Messages b/perl/Messages index 911f7c89..22551f00 100644 --- a/perl/Messages +++ b/perl/Messages @@ -150,6 +150,8 @@ package DXM; hnodee1 => 'Please enter your Home Node, set/homenode ', hnodee2 => 'Failed to set homenode on $_[0]', hnode => 'Your Homenode is now \"$_[0]\"', + http1 => '$_[0] working ...', + http2 => '$_[0] returned:', init1 => 'sent initialisation message to $_[0]', iso => '$_[0] Isolated', isou => '$_[0] UnIsolated', diff --git a/perl/Version.pm b/perl/Version.pm index 3c7bad08..3088501f 100644 --- a/perl/Version.pm +++ b/perl/Version.pm @@ -11,7 +11,7 @@ use vars qw($version $subversion $build $gitversion); $version = '1.56'; $subversion = '0'; -$build = '9'; -$gitversion = 'a22dbff'; +$build = '10'; +$gitversion = '370d356'; 1; diff --git a/perl/cluster.pl b/perl/cluster.pl index a40a5aa5..43828974 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -492,6 +492,8 @@ my ($sigint, $sigterm); unless ($DB::VERSION) { $sigint = AnyEvent->signal(signal=>'INT', cb=> sub{$decease->send}); $sigterm = AnyEvent->signal(signal=>'TERM', cb=> sub{$decease->send}); +# $sigint = AnyEvent->signal(signal=>'INT', cb=> sub{AnyEvent->unloop}); +# $sigterm = AnyEvent->signal(signal=>'TERM', cb=> sub{AnyEvent->unloop}); } unless ($is_win) { @@ -584,6 +586,7 @@ my $per_sec = AnyEvent->timer(after => 0, interval => 0.010, cb => sub{idle_loop # main loop $decease->recv; +#AnyEvent->loop; idle_loop() for (1..25); cease(0); -- 2.43.0