From: Dirk Koopman Date: Mon, 12 Mar 2012 23:44:36 +0000 (+0000) Subject: Merge branch 'master' into anyevent X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=commitdiff_plain;h=0e896695f3297c3989a5159af0a36f28d8164c15;hp=427bd0165d0b8bec0e93cc2b262fcbe0d3cb5855;p=spider.git Merge branch 'master' into anyevent Conflicts: perl/DXUser.pm perl/Version.pm Add database handling changes from master --- diff --git a/cmd/Commands_en.hlp b/cmd/Commands_en.hlp index 8d8ba775..5fbbd719 100644 --- a/cmd/Commands_en.hlp +++ b/cmd/Commands_en.hlp @@ -2111,6 +2111,9 @@ any order to the basic SHOW/DX command, they are:- You can also use this with the 'by' keyword so eg by W dxcc + + by_dxcc - alternatively you can simply say 'by_dxcc W' instead + instead of 'by W dxcc'. real or rt - Format the output the same as for real time spots. The formats are deliberately different (so you can tell diff --git a/cmd/blank.pl b/cmd/blank.pl index 5032edf0..4a91b70f 100644 --- a/cmd/blank.pl +++ b/cmd/blank.pl @@ -6,20 +6,29 @@ # # -my ($self, $line) = @_; -my $lines = 1; -my $data = ' '; -my @f = split /\s+/, $line; -if (@f && $f[0] !~ /^\d+$/) { - $data = shift @f; - $data = $data x int(($self->width-1) / length($data)); - $data .= substr $data, 0, int(($self->width-1) % length($data)) -} -if (@f && $f[0] =~ /^\d+$/) { - $lines = shift @f; - $lines = 9 if $lines > 9; - $lines = 1 if $lines < 1; +sub this {}; + +sub that {}; + +sub another {} + +sub handle +{ + my ($self, $line) = @_; + my $lines = 1; + my $data = ' '; + my @f = split /\s+/, $line; + if (@f && $f[0] !~ /^\d+$/) { + $data = shift @f; + $data = $data x int(($self->width-1) / length($data)); + $data .= substr $data, 0, int(($self->width-1) % length($data)) + } + if (@f && $f[0] =~ /^\d+$/) { + $lines = shift @f; + $lines = 9 if $lines > 9; + $lines = 1 if $lines < 1; + } + my @out; + push @out, $data for (1..$lines); + return (1, @out); } -my @out; -push @out, $data for (1..$lines); -return (1, @out); diff --git a/cmd/bye.pl b/cmd/bye.pl index 41d3ee91..ec04f056 100644 --- a/cmd/bye.pl +++ b/cmd/bye.pl @@ -13,7 +13,7 @@ if ($self->is_user && -e "$main::data/logout") { my @in = ; close(I); $self->send_now('D', @in); - sleep(1); +# Msg->sleep(1); } #$self->send_now('Z', ""); diff --git a/cmd/export_users.pl b/cmd/export_users.pl index a8cec7de..ffe3ce67 100644 --- a/cmd/export_users.pl +++ b/cmd/export_users.pl @@ -8,5 +8,5 @@ my $line = shift || "$main::data/user_asc"; return (1, $self->msg('e5')) unless $self->priv >= 9; my ($fn, $flag) = split /\s+/, $line; -my $strip = $flag eq 'strip'; +my $strip = defined $flag && $flag eq 'strip'; return (1, DXUser::export($fn, $strip)); diff --git a/cmd/set/echo.pl b/cmd/set/echo.pl index 4bf41ae7..4e14b995 100644 --- a/cmd/set/echo.pl +++ b/cmd/set/echo.pl @@ -7,5 +7,6 @@ # my $self = shift; $self->send_now("E", "1"); +$self->conn->echo(1); $self->user->wantecho(1); return (1, $self->msg('echoon')); diff --git a/cmd/show/contest.pl b/cmd/show/contest.pl index 4b3e68ba..f29bbfe4 100644 --- a/cmd/show/contest.pl +++ b/cmd/show/contest.pl @@ -13,7 +13,7 @@ my ($self, $line) = @_; my @out; -my $mon;; +my $mon; # trying to make the syntax abit more user friendly... # and yes, I have been here and it *is* all my fault (dirk) @@ -40,32 +40,22 @@ my $port = 80; my $url = $Internet::contest_url || "http://www.sk3bg.se/contest/text"; $url .= "/$filename"; -my $t = new Net::Telnet (Telnetmode => 0); -eval { - $t->open(Host => $host, Port => $port, Timeout => 15); - }; - -if (!$t || $@) { - push @out, $self->msg('e18','sk3bg.se'); -} else { - my $s = "GET $url"; - $t->print($s); - my $notfound = $t->getline(Timeout => 10); - if ($notfound =~ /404 Object Not Found/) { - return (1, "there is no contest info for $mon") - } else { - push @out, $notfound; - } - while (!$t->eof) { - eval { - push @out, $t->getline(Timeout => 10); - }; - if ($@) { - push @out, $self->msg('e18', 'sk3bg.se'); - last; - } - } -} -$t->close; +push @out, $self->msg('http1', 'sk3bg.se', "$filename"); + +$self->http_get($host, $url, sub + { + my ($response, $header, $body) = @_; + my @out; + + if ($response =~ /^4/) { + push @out, "There is no contest info $mon"; + } elsif ($response =~ /^5/) { + push @out, $self->msg('e18','sk3bg.se'); + } else { + push @out, split /\r?\n/, $body; + } + $self->send_ans(@out); + } + ); return (1, @out); diff --git a/cmd/show/dx.pl b/cmd/show/dx.pl index f2629bff..f359aec0 100644 --- a/cmd/show/dx.pl +++ b/cmd/show/dx.pl @@ -81,10 +81,12 @@ while ($f = shift @list) { # next field $info = shift @list; next; } - if ((lc $f eq 'spotter' || lc $f eq 'by') && $list[0]) { + if ((lc $f eq 'spotter' || lc $f eq 'by' || lc $f eq 'by_dxcc') && $list[0]) { # print "got spotter\n"; $spotter = uc shift @list; - if ($list[0] && lc $list[0] eq 'dxcc') { + if ($f eq 'by_dxcc') { + $fromdxcc = 1; + } elsif ($list[0] && lc $list[0] eq 'dxcc') { $fromdxcc = 1; shift @list; } diff --git a/cmd/show/dxqsl.pl b/cmd/show/dxqsl.pl index 2017a6ae..3a00433c 100644 --- a/cmd/show/dxqsl.pl +++ b/cmd/show/dxqsl.pl @@ -16,6 +16,7 @@ return (1, $self->msg('db3', 'QSL')) unless $QSL::dbm; push @out, $self->msg('qsl1'); foreach my $call (@call) { + Log('call', "$call: show/dxqsl $call"); my $q = QSL::get($call); if ($q) { my $c = $call; diff --git a/cmd/show/qrz.pl b/cmd/show/qrz.pl index 9a3f9c3f..5aef1828 100644 --- a/cmd/show/qrz.pl +++ b/cmd/show/qrz.pl @@ -17,50 +17,58 @@ 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', 'qrz.com', "\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"); + } + if ($response =~ /^5/) { + push @out, $self->msg('e18',"qrz.com $!"); + } else { + 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/cmd/show/station.pl b/cmd/show/station.pl index 55976a69..f6e43f1a 100644 --- a/cmd/show/station.pl +++ b/cmd/show/station.pl @@ -14,8 +14,8 @@ my $seek; push @f, $self->call unless @f; if (@f <= 2 && uc $f[0] eq 'ALL') { - return (1, $self->msg('e6')) if @f == 1 && $self->priv < 6; - return (1, $self->msg('e6')) if $self->priv < 5 || $f[1] eq '*'; + return (1, $self->msg('e6')) if $self->remotecmd && $self->priv < 6; + return (1, $self->msg('e6')) if $self->priv < 5; shift @f; my $exp = shellregex(uc shift @f) if @f; my @calls; diff --git a/cmd/show/wm7d.pl b/cmd/show/wm7d.pl index 6dfb5b14..291823d7 100644 --- a/cmd/show/wm7d.pl +++ b/cmd/show/wm7d.pl @@ -21,7 +21,8 @@ my $port = 5000; my $cmdprompt = '/query->.*$/'; my($info, $t); - + +use Net::Telnet; $t = new Net::Telnet; $info = $t->open(Host => $target, Port => $port, diff --git a/cmd/shutdown.pl b/cmd/shutdown.pl index 30592ad0..cfed8d40 100644 --- a/cmd/shutdown.pl +++ b/cmd/shutdown.pl @@ -12,6 +12,6 @@ foreach $ref (DXChannel::get_all()) { } # give some time for the buffers to empty and then shutdown (see cluster.pl) -$main::decease = 25; +$main::decease->send; return (1); diff --git a/cmd/unset/echo.pl b/cmd/unset/echo.pl index 59287070..dba0b8e0 100644 --- a/cmd/unset/echo.pl +++ b/cmd/unset/echo.pl @@ -7,5 +7,6 @@ # my $self = shift; $self->send_now("E", "0"); +$self->conn->echo(0); $self->user->wantecho(0); return (1, $self->msg('echooff')); diff --git a/perl/Console.pm b/perl/Console.pm index a6dc6613..4dc72d42 100644 --- a/perl/Console.pm +++ b/perl/Console.pm @@ -31,6 +31,9 @@ package main; +use vars qw($maxkhist $maxshist $foreground $background $mycallcolor @colors ); +use Curses; + $maxkhist = 100; $maxshist = 500; if ($ENV{'TERM'} =~ /(xterm|ansi)/) { diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 958fe618..83845670 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 @@ -147,11 +148,16 @@ sub alloc { my ($pkg, $call, $conn, $user) = @_; my $self = {}; - + die "trying to create a duplicate channel for $call" if $channels{$call}; + bless $self, $pkg; + $self->{call} = $call; $self->{priv} = 0; - $self->{conn} = $conn if defined $conn; # if this isn't defined then it must be a list + if (defined $conn && ref $conn) { # if this isn't defined then it must be a list + $self->{conn} = $conn; + $conn->set_on_eof(sub {$self->disconnect}); + } if (defined $user) { $self->{user} = $user; $self->{lang} = $user->lang; @@ -174,10 +180,10 @@ sub alloc $self->{cq} = $dxcc[1]->cq; } $self->{inqueue} = []; + $self->{anyevents} = []; $count++; dbg("DXChannel $self->{call} created ($count)") if isdbg('chan'); - bless $self, $pkg; return $channels{$call} = $self; } @@ -202,7 +208,9 @@ sub rebless { my $self = shift; my $class = shift; - return $channels{$self->{call}} = bless $self, $class; + my $new = bless $self, $class; + $new->{conn}->on_eof(sub {$new->disconnect}); + return $channels{$self->{call}} = $new; } sub rec @@ -386,9 +394,9 @@ sub send_now # chomp; my @lines = split /\n/; for (@lines) { + dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan'); $conn->send_now("$sort$call|$_"); # debug log it, but not if it is a log message - dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan'); } } $self->{t} = time; @@ -410,9 +418,9 @@ sub send_later # chomp; my @lines = split /\n/; for (@lines) { + dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan'); $conn->send_later("$sort$call|$_"); # debug log it, but not if it is a log message - dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan'); } } $self->{t} = time; @@ -432,8 +440,8 @@ sub send # this is always later and always data for (ref $l ? @$l : $l) { my @lines = split /\n/; for (@lines) { - $conn->send_later("D$call|$_"); dbg("-> D $call $_") if isdbg('chan'); + $conn->send_later("D$call|$_"); } } } @@ -500,7 +508,7 @@ sub disconnect my $user = $self->{user}; $user->close() if defined $user; - $self->{conn}->disconnect if $self->{conn}; + $self->{conn}->close_on_empty if $self->{conn}; $self->del(); } @@ -698,18 +706,16 @@ sub broadcast_list sub process { - foreach my $dxchan (get_all()) { - + foreach my $dxchan (values %channels) { + + next if $dxchan->{disconnecting}; + while (my $data = shift @{$dxchan->{inqueue}}) { my ($sort, $call, $line) = $dxchan->decode_input($data); next unless defined $sort; # do the really sexy console interface bit! (Who is going to do the TK interface then?) dbg("<- $sort $call $line") if $sort ne 'D' && isdbg('chan'); - if ($dxchan->{disconnecting}) { - dbg('In disconnection, ignored'); - next; - } # handle A records my $user = $dxchan->user; @@ -746,6 +752,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..d0af6bbb 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; @@ -32,7 +36,6 @@ use WCY; use Sun; use Internet; use Script; -use Net::Telnet; use QSL; use DB_File; use VE7CC; @@ -51,7 +54,7 @@ $maxbadcount = 3; # no of bad words allowed before disconnection $msgpolltime = 3600; # the time between polls for new messages $cmdimportdir = "$main::root/cmd_import"; # the base directory for importing command scripts # this does not exist as default, you need to create it manually - # +# # # obtain a new connection this is derived from dxchannel @@ -521,10 +524,10 @@ sub run_cmd my $package = find_cmd_name($path, $fcmd); return ($@) if $@; - if ($package && DXCommandmode->can($package)) { + if ($package && $self->can("${package}::handle")) { no strict 'refs'; dbg("cmd: package $package") if isdbg('command'); - eval { @ans = &$package($self, $args) }; + eval { @ans = &{"${package}::handle"}($self, $args) }; return (DXDebug::shortmess($@)) if $@; } else { dbg("cmd: $package not present") if isdbg('command'); @@ -745,12 +748,14 @@ sub clear_cmd_cache { no strict 'refs'; - for (keys %Cache) { - undef *{$_} unless /cmd_cache/; - dbg("Undefining cmd $_") if isdbg('command'); + for my $k (keys %Cache) { + unless ($k =~ /cmd_cache/) { + dbg("Undefining cmd $k") if isdbg('command'); + undef $DXCommandmode::{"${k}::"}; + } } %cmd_cache = (); - %Cache = (); + %Cache = ( cmd_clear_cmd_cache => $Cache{cmd_clear_cmd_cache} ); } # @@ -761,11 +766,10 @@ sub clear_cmd_cache # # This has been nicked directly from the perlembed pages # - #require Devel::Symdump; sub valid_package_name { - my($string) = @_; + my $string = shift; $string =~ s|([^A-Za-z0-9_/])|sprintf("_%2x",unpack("C",$1))|eg; $string =~ s|/|_|g; @@ -788,11 +792,11 @@ sub find_cmd_name { return undef; } - if(defined $Cache{$package}->{mtime} &&$Cache{$package}->{mtime} <= $mtime) { + if(exists $Cache{$package} && exists $Cache{$package}->{mtime} && $Cache{$package}->{mtime} <= $mtime) { #we have compiled this subroutine already, #it has not been updated on disk, nothing left to do #print STDERR "already compiled $package->handler\n"; - ; + dbg("find_cmd_name: $package cached") if isdbg('command'); } else { my $sub = readfilestr($filename); @@ -802,7 +806,14 @@ sub find_cmd_name { }; #wrap the code into a subroutine inside our unique package - my $eval = qq( sub $package { $sub } ); + 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}; ); + + + if ($sub =~ m|\s*sub\s+handle\n|) { + $eval .= $sub; + } else { + $eval .= qq(sub handle { $sub }); + } if (isdbg('eval')) { my @list = split /\n/, $eval; @@ -817,7 +828,8 @@ sub find_cmd_name { if (exists $Cache{$package}) { dbg("find_cmd_name: Redefining $package") if isdbg('command'); - undef *$package; + undef $DXCommandmode::{"${package}::"}; + delete $Cache{$package}; } else { dbg("find_cmd_name: Defining $package") if isdbg('command'); } @@ -825,10 +837,9 @@ sub find_cmd_name { eval $eval; $Cache{$package} = {mtime => $mtime } unless $@; - } - return $package; + return "DXCommandmode::$package"; } sub send @@ -1233,5 +1244,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/DXLogPrint.pm b/perl/DXLogPrint.pm index c2843ed5..b16d69e4 100644 --- a/perl/DXLogPrint.pm +++ b/perl/DXLogPrint.pm @@ -33,7 +33,7 @@ sub print my $to = shift || 10; my $jdate = $fcb->unixtoj(shift); my $pattern = shift; - my $who = uc shift; + my $who = shift; my $search; my @in; my @out = (); @@ -41,6 +41,8 @@ sub print my $tot = $from + $to; my $hint = ""; + $who = uc $who if defined $who; + if ($pattern) { $hint = "m{\\Q$pattern\\E}i"; } else { diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 25672f96..d7a43326 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -9,7 +9,6 @@ package DXUser; use DXLog; -use DB_File; use Data::Dumper; use Fcntl; use IO::File; @@ -19,10 +18,11 @@ use LRU; use strict; -use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3); +use vars qw(%u $dbm $dbh $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3 $v4); %u = (); $dbm = undef; +$dbh = undef; $filename = undef; $lastoperinterval = 60*24*60*60; $lasttime = 0; @@ -30,6 +30,8 @@ $lrusize = 2000; $tooold = 86400 * 365; # this marks an old user who hasn't given enough info to be useful $v3 = 0; +my $dbh_working; + # hash of valid elements and a simple prompt %valid = ( call => '0,Callsign', @@ -121,46 +123,95 @@ sub init my $ufn; my $convert; - + eval { - require Storable; + require DBI; + require DBD::SQLite; + require JSON; }; - -# eval "use Storable qw(nfreeze thaw)"; if ($@) { - $ufn = "$fn.v2"; - $v3 = $convert = 0; - dbg("the module Storable appears to be missing!!"); + + $ufn = "$fn.v3"; + $v3 = 1; $convert = 0; + dbg("One of more of the modules DBI, DBD::SQLite and JSON appear to be missing!!"); dbg("trying to continue in compatibility mode (this may fail)"); - dbg("please install Storable from CPAN as soon as possible"); + dbg("please install DBI, DBD::SQLite and JSON from CPAN as soon as possible"); + + eval { + require DB_File; + require Storable; + }; + + if ($@) { + $ufn = "$fn.v2"; + $v3 = $convert = 0; + dbg("One of the modules DB_File and Storable appears to be missing!!"); + dbg("trying to continue in compatibility mode (this may fail)"); + dbg("please install Storable from CPAN as soon as possible"); + } else { + import DB_File; + import Storable qw(nfreeze thaw); + + $ufn = "$fn.v3"; + $v3 = 1; + $convert++ if -e "$fn.v2" && !-e $ufn; + } } else { - import Storable qw(nfreeze thaw); + import DBI; + import DBD::SQLite; + import JSON qw(-convert_blessed_universally); + + $ufn = "$fn.v4"; + $v4 = 1; + $convert++ if -e "$fn.v3" && !-e $ufn; + } - $ufn = "$fn.v3"; - $v3 = 1; - $convert++ if -e "$fn.v2" && !-e $ufn; + $main::systime ||= time; # becuase user_asc doesn't set it + + # open "database" files + if ($v3) { + if ($mode) { + $dbm = tie (%u, 'DB_File', "$fn.v3", O_CREAT|O_RDWR, 0666, $DB::File::DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]"; + } else { + $dbm = tie (%u, 'DB_File', "$fn.v3", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]"; + } + die "Cannot open $fn.v3 ($!)\n" unless $dbm; } - - if ($mode) { - $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]"; - } else { - $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]"; + if ($v4) { + my $new = ! -e $ufn; + $dbh = DBI->connect("dbi:SQLite:dbname=$ufn","","") or die "Cannot open $ufn ($!)\n"; + if ($new) { + # create the table + my $table = q{create table user( +call text not null unique, +lastseen int not null, +data text not null +)}; + $dbh->do($table) or die "cannot create user table in $ufn " . $dbh->errstr; + + # Add indexes + $dbh->do(q(create index x1 on user(lastseen))) or die $dbh->errstr; + } + $dbh->do(q{PRAGMA cache_size = 8000}); + $dbh->do(q{PRAGMA synchronous = OFF}); } - die "Cannot open $ufn ($!)\n" unless $dbm; - $lru = LRU->newbase("DXUser", $lrusize); - # do a conversion if required - if ($dbm && $convert) { + if ($dbm && $v3 && $convert) { my ($key, $val, $action, $count, $err) = ('','',0,0,0); + + require DB_File; + require Storable; + import DB_File; + import Storable qw(nfreeze thaw); my %oldu; dbg("Converting the User File to V3 "); - dbg("This will take a while, I suggest you go and have cup of strong tea"); - my $odbm = tie (%oldu, 'DB_File', "$fn.v2", O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn.v2 ($!) [rebuild it from user_asc?]"; - for ($action = R_FIRST; !$odbm->seq($key, $val, $action); $action = R_NEXT) { + dbg("This will take a while, I suggest you go and have a cup of strong tea"); + my $odbm = tie (%oldu, 'DB_File', "$fn.v2", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn.v2 ($!) [rebuild it from user_asc?]"; + for ($action = DB_File::R_FIRST(); !$odbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) { my $ref = asc_decode($val); if ($ref) { $ref->put; @@ -173,6 +224,44 @@ sub init untie %oldu; dbg("Conversion completed $count records $err errors"); } + + if ($dbh && $v4 && $convert) { + my ($key, $val, $action, $count, $err) = ('','',0,0,0); + + + my %oldu; + dbg("Converting the User File to V4 "); + dbg("This will take a while, I suggest you go and have a cup of strong tea"); + require DB_File; + require Storable; + import DB_File; + import Storable qw(nfreeze thaw); + my $odbm = tie (%oldu, 'DB_File', "$fn.v3", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn.v3 ($!) [rebuild it from user_asc?]"; + $dbh->begin_work; + $dbh_working++; + for ($action = DB_File::R_FIRST(); !$odbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) { + my $ref = thaw($val); + if ($ref) { + my $r = _insert($ref); + if ($r) { + $count++; + } else { + $err++; + dbg("error converting call $ref->{call} - " . $dbh->errstr); + } + } else { + $err++ + } + } + sync(); + undef $odbm; + untie %oldu; + dbg("Conversion completed $count records $err errors"); + + } + + $lru = LRU->newbase("DXUser", $lrusize); + $filename = $ufn; } @@ -181,7 +270,11 @@ sub del_file my ($pkg, $fn) = @_; confess "need a filename in User" if !$fn; - $fn .= $v3 ? ".v3" : ".v2"; + my $suffix; + $suffix = '.v4' if $v4; + $suffix ||= '.v3' if $v3; + $suffix ||= '.v2'; + $fn .= $suffix; unlink $fn; } @@ -190,8 +283,8 @@ sub del_file # sub process { - if ($main::systime > $lasttime + 15) { - $dbm->sync; + if ($main::systime > $lasttime + 5) { + sync(); $lasttime = $main::systime; } } @@ -202,8 +295,11 @@ sub process sub finish { - undef $dbm; - untie %u; + if ($dbm) { + undef $dbm; + untie %u; + } + $dbh->disconnect if $dbh; } # @@ -215,9 +311,38 @@ sub alloc my $pkg = shift; my $call = uc shift; my $self = bless {call => $call, 'sort'=>'U'}, $pkg; + _insert($self) or confess($dbh->errstr) if $v4; return $self; } +sub _insert +{ + my $self = shift; + my $json = JSON->new->allow_blessed->convert_blessed->encode($self); + $dbh->begin_work unless $dbh_working++; + my $r = $dbh->do(q{replace into user values(?,?,?)}, undef, $self->{call}, $main::systime, $json); + return $r; +} + +sub _select +{ + my $call = shift; + my $sth = $dbh->prepare(qq{select data from user where call = ?}) or confess($dbh->errstr); + my $rv = $sth->execute($call); + if ($rv) { + my @row = $sth->fetchrow_array; + return $row[0]; + } + return undef; +} + +sub _delete +{ + my $call =shift; + my $r = $dbh->do(q{delete from user where call = ?}, undef, $call); + return $r; +} + sub new { my $pkg = shift; @@ -227,7 +352,7 @@ sub new # confess "can't create existing call $call in User\n!" if $u{$call}; my $self = $pkg->alloc($call); - $self->put; + $self->put unless $v4; return $self; } @@ -243,21 +368,34 @@ sub get # is it in the LRU cache? my $ref = $lru->get($call); - return $ref if $ref && ref $ref eq 'DXUser'; + return $ref if $ref && UNIVERSAL::isa($ref, 'DXUser'); # search for it - unless ($dbm->get($call, $data)) { - $ref = decode($data); - if ($ref) { - if (!UNIVERSAL::isa($ref, 'DXUser')) { - dbg("DXUser::get: got strange answer from decode of $call". ref $ref. " ignoring"); + if ($v4) { + if ($data = _select($call)) { + $ref = bless decode_json($data), 'DXUser'; + unless ($ref) { + dbg("DXUser::get: no reference returned from decode of $call $!"); return undef; } - # we have a reference and it *is* a DXUser - } else { - dbg("DXUser::get: no reference returned from decode of $call $!"); + } + } else { + unless ($dbm->get($call, $data)) { + $ref = decode($data); + unless ($ref) { + dbg("DXUser::get: no reference returned from decode of $call $!"); + return undef; + } + } + } + + if ($ref) { + if (!UNIVERSAL::isa($ref, 'DXUser')) { + dbg("DXUser::get: got strange answer from decode of $call". ref $ref. " ignoring"); return undef; } + + # we have a reference and it *is* a DXUser $lru->put($call, $ref); return $ref; } @@ -292,7 +430,20 @@ sub get_current sub get_all_calls { - return (sort keys %u); + if ($v4) { + my $sth = $dbh->prepare(qq{select call from user}) or confess($dbh->errstr); + my $rv = $sth->execute(); + if ($rv) { + my @row; + my @r; + while (my @r = $sth->fetchrow_array) { + push @row, @r; + } + return @row; # 'cos it's already sorted + } + } else { + return (sort keys %u); + } } # @@ -305,13 +456,17 @@ sub put confess "Trying to put nothing!" unless $self && ref $self; my $call = $self->{call}; - $dbm->del($call); delete $self->{annok} if $self->{annok}; delete $self->{dxok} if $self->{dxok}; $lru->put($call, $self); - my $ref = $self->encode; - $dbm->put($call, $ref); + if ($v4) { + _insert($self); + } else { + $dbm->del($call); + my $ref = $self->encode; + $dbm->put($call, $ref); + } } # freeze the user @@ -374,9 +529,13 @@ sub asc_decode sub del { my $self = shift; - my $call = $self->{call}; - $lru->remove($call); - $dbm->del($call); + if ($v4) { + _delete($self) + } else { + my $call = $self->{call}; + $lru->remove($call); + $dbm->del($call); + } } # @@ -387,7 +546,7 @@ sub close { my $self = shift; $self->{lastin} = time; - $self->put(); + $self->put; } # @@ -396,7 +555,12 @@ sub close sub sync { - $dbm->sync; + if ($v4) { + $dbh->commit if $dbh_working; + $dbh_working = 0; + } else { + $dbm->sync; + } } # @@ -430,9 +594,6 @@ sub export my $del = 0; my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)"; if ($fh) { - my $key = 0; - my $val = undef; - my $action; my $t = scalar localtime; print $fh q{#!/usr/bin/perl # @@ -499,40 +660,76 @@ print "There are $count user records and $err errors\n"; }; print $fh "__DATA__\n"; - for ($action = R_FIRST; !$dbm->seq($key, $val, $action); $action = R_NEXT) { - if (!is_callsign($key) || $key =~ /^0/) { - my $eval = $val; - my $ekey = $key; - $eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; - $ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; - LogDbg('DXCommand', "Export Error1: $ekey\t$eval"); - eval {$dbm->del($key)}; - dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@; - ++$err; - next; - } - my $ref = decode($val); - if ($ref) { - my $t = $ref->{lastin} || 0; - if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) { - unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) { - eval {$dbm->del($key)}; - dbg(carp("Export Error2: $key\t$val\n$@")) if $@; - LogDbg('DXCommand', "$ref->{call} deleted, too old"); - $del++; + if ($v4) { + my $sth = $dbh->prepare(q{select call,data from user}) or confess($dbh->errstr); + my $rv = $sth->execute; + if ($rv) { + while (my @row = $sth->fetchrow_array) { + my $call = shift @row; + my $data = shift @row; + if (!is_callsign($call) || $call =~ /^0/) { + LogDbg('DXCommand', "Export Error1: $call\t$data"); + _delete($call); + ++$err; next; } + my $ref = bless decode_json($data), __PACKAGE__; + my $t = $ref->{lastin} || 0; + if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) { + unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) { + LogDbg('DXCommand', "$ref->{call} deleted, too old"); + _delete($call); + $del++; + next; + } + } + + # only store users that are reasonably active or have useful information + print $fh "$call\t" . $ref->asc_encode($basic_info_only) . "\n"; + ++$count; } - # only store users that are reasonably active or have useful information - print $fh "$key\t" . $ref->asc_encode($basic_info_only) . "\n"; - ++$count; } else { - LogDbg('DXCommand', "Export Error3: $key\t$val"); - eval {$dbm->del($key)}; - dbg(carp("Export Error3: $key\t$val\n$@")) if $@; - ++$err; + dbg(carp($dbh->errstr)); } - } + } else { + my $key = 0; + my $val = undef; + my $action; + for ($action = DB_File::R_FIRST(); !$dbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) { + if (!is_callsign($key) || $key =~ /^0/) { + my $eval = $val; + my $ekey = $key; + $eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; + $ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; + LogDbg('DXCommand', "Export Error1: $ekey\t$eval"); + eval {$dbm->del($key)}; + dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@; + ++$err; + next; + } + my $ref = decode($val); + if ($ref) { + my $t = $ref->{lastin} || 0; + if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) { + unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) { + eval {$dbm->del($key)}; + dbg(carp("Export Error2: $key\t$val\n$@")) if $@; + LogDbg('DXCommand', "$ref->{call} deleted, too old"); + $del++; + next; + } + } + # only store users that are reasonably active or have useful information + print $fh "$key\t" . $ref->asc_encode($basic_info_only) . "\n"; + ++$count; + } else { + LogDbg('DXCommand', "Export Error3: $key\t$val"); + eval {$dbm->del($key)}; + dbg(carp("Export Error3: $key\t$val\n$@")) if $@; + ++$err; + } + } + } $fh->close; } return "$count Users $del Deleted $err Errors ('sh/log Export' for details)"; diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 14819ad1..4e442140 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -15,7 +15,7 @@ use Data::Dumper; use strict; -use vars qw(@month %patmap @ISA @EXPORT); +use vars qw(@month %patmap $pi $d2r $r2d @ISA @EXPORT); require Exporter; @ISA = qw(Exporter); @@ -24,7 +24,7 @@ require Exporter; filecopy ptimelist print_all_fields cltounix unpad is_callsign is_long_callsign is_latlong is_qra is_freq is_digits is_pctext is_pcflag insertitem deleteitem - is_prefix dd is_ipaddr + is_prefix dd is_ipaddr $pi $d2r $r2d ); @@ -36,6 +36,11 @@ require Exporter; ']' => ']' ); +$pi = 3.141592653589; +$d2r = ($pi/180); +$r2d = (180/$pi); + + # a full time for logging and other purposes sub atime { diff --git a/perl/ExtMsg.pm b/perl/ExtMsg.pm index 6b2cce7d..398679c4 100644 --- a/perl/ExtMsg.pm +++ b/perl/ExtMsg.pm @@ -54,11 +54,8 @@ sub enqueue sub send_raw { my ($conn, $msg) = @_; - my $sock = $conn->{sock}; - return unless defined($sock); - push (@{$conn->{outqueue}}, $msg); dbg("connect $conn->{cnum}: $msg") if $conn->{state} ne 'C' && isdbg('connect'); - Msg::set_event_handler ($sock, "write" => sub {$conn->_send(0)}); + $conn->SUPER::send_raw($msg); } sub echo @@ -155,8 +152,7 @@ sub to_connected delete $conn->{timeout}; $conn->{csort} = $sort; unless ($conn->ax25) { - eval {$conn->{peerhost} = $conn->{sock}->peerhost}; - $conn->nolinger; +# eval {$conn->{peerhost} = $conn->{sock}->{fh}->peerhost}; } &{$conn->{rproc}}($conn, "$dir$call|$sort"); $conn->_send_file("$main::data/connected") unless $conn->{outgoing}; @@ -164,43 +160,44 @@ sub to_connected sub new_client { my $server_conn = shift; - my $sock = $server_conn->{sock}->accept(); + my $sock = shift; + my $peerhost = shift; + my $peerport = shift; if ($sock) { my $conn = $server_conn->new($server_conn->{rproc}); - $conn->{sock} = $sock; - $conn->nolinger; - Msg::blocking($sock, 0); + $conn->{sock} = AnyEvent::Handle->new( + + fh => $sock, + + on_eof => sub {$conn->disconnect}, + + on_error => sub {$conn->disconnect}, + + keepalive => 1, + + linger => 0, + ); $conn->{blocking} = 0; - eval {$conn->{peerhost} = $sock->peerhost}; - if ($@) { - dbg($@) if isdbg('connll'); - $conn->disconnect; + my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost} = $peerhost, $conn->{peerport} = $peerport); + dbg("accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}") if isdbg('connll'); + $conn->{sock}->on_read(sub{$conn->_rcv}); + if ($eproc) { + $conn->{eproc} = $eproc; + } + if ($rproc) { + $conn->{rproc} = $rproc; + # send login prompt + $conn->{state} = 'WL'; + # $conn->send_raw("\xff\xfe\x01\xff\xfc\x01\ff\fd\x22"); + # $conn->send_raw("\xff\xfa\x22\x01\x01\xff\xf0"); + # $conn->send_raw("\xFF\xFC\x01"); + $conn->_send_file("$main::data/issue"); + $conn->send_raw("login: "); + $conn->_dotimeout(60); + $conn->{echo} = 1; } else { - eval {$conn->{peerport} = $sock->peerport}; - $conn->{peerport} = 0 if $@; - my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost}, $conn->{peerport}); - dbg("accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}") if isdbg('connll'); - if ($eproc) { - $conn->{eproc} = $eproc; - Msg::set_event_handler ($sock, "error" => $eproc); - } - if ($rproc) { - $conn->{rproc} = $rproc; - my $callback = sub {$conn->_rcv}; - Msg::set_event_handler ($sock, "read" => $callback); - # send login prompt - $conn->{state} = 'WL'; - # $conn->send_raw("\xff\xfe\x01\xff\xfc\x01\ff\fd\x22"); - # $conn->send_raw("\xff\xfa\x22\x01\x01\xff\xf0"); - # $conn->send_raw("\xFF\xFC\x01"); - $conn->_send_file("$main::data/issue"); - $conn->send_raw("login: "); - $conn->_dotimeout(60); - $conn->{echo} = 1; - } else { - &{$conn->{eproc}}() if $conn->{eproc}; - $conn->disconnect(); - } + &{$conn->{eproc}}() if $conn->{eproc}; + $conn->disconnect(); } } else { dbg("ExtMsg: error on accept ($!)") if isdbg('err'); diff --git a/perl/Messages b/perl/Messages index 911f7c89..77e818e3 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 => 'Searching $_[0] for $_[1] ...', + http2 => '$_[0] returned:', init1 => 'sent initialisation message to $_[0]', iso => '$_[0] Isolated', isou => '$_[0] UnIsolated', diff --git a/perl/Msg.pm b/perl/Msg.pm index d3817bed..fc1179c5 100644 --- a/perl/Msg.pm +++ b/perl/Msg.pm @@ -14,91 +14,18 @@ use strict; use DXUtil; -use IO::Select; +use AnyEvent; +use AnyEvent::Handle; +use AnyEvent::Socket; + use DXDebug; use Timer; -use vars qw(%rd_callbacks %wt_callbacks %er_callbacks $rd_handles $wt_handles $er_handles $now %conns $noconns $blocking_supported $cnum $total_in $total_out $io_socket); +use vars qw(%conns $noconns $cnum $total_in $total_out); -%rd_callbacks = (); -%wt_callbacks = (); -%er_callbacks = (); -$rd_handles = IO::Select->new(); -$wt_handles = IO::Select->new(); -$er_handles = IO::Select->new(); $total_in = $total_out = 0; - -$now = time; - -BEGIN { - # Checks if blocking is supported - eval { - local $^W; - require POSIX; POSIX->import(qw(O_NONBLOCK F_SETFL F_GETFL)) - }; - - eval { - local $^W; - require IO::Socket::INET6; - }; - - if ($@) { - dbg($@); - require IO::Socket; - $io_socket = 'IO::Socket::INET'; - } else { - $io_socket = 'IO::Socket::INET6'; - } - $io_socket->import; - - if ($@ || $main::is_win) { - $blocking_supported = $io_socket->can('blocking') ? 2 : 0; - } else { - $blocking_supported = $io_socket->can('blocking') ? 2 : 1; - } - - - # import as many of these errno values as are available - eval { - local $^W; - require Errno; Errno->import(qw(EAGAIN EINPROGRESS EWOULDBLOCK)); - }; - - unless ($^O eq 'MSWin32') { - if ($] >= 5.6) { - eval { - local $^W; - require Socket; Socket->import(qw(IPPROTO_TCP TCP_NODELAY)); - }; - } else { - dbg("IPPROTO_TCP and TCP_NODELAY manually defined"); - eval 'sub IPPROTO_TCP { 6 };'; - eval 'sub TCP_NODELAY { 1 };'; - } - } - # http://support.microsoft.com/support/kb/articles/Q150/5/37.asp - # defines EINPROGRESS as 10035. We provide it here because some - # Win32 users report POSIX::EINPROGRESS is not vendor-supported. - if ($^O eq 'MSWin32') { - eval '*EINPROGRESS = sub { 10036 };' unless defined *EINPROGRESS; - eval '*EWOULDBLOCK = *EAGAIN = sub { 10035 };' unless defined *EWOULDBLOCK; - eval '*F_GETFL = sub { 0 };' unless defined *F_GETFL; - eval '*F_SETFL = sub { 0 };' unless defined *F_SETFL; - eval 'sub IPPROTO_TCP { 6 };'; - eval 'sub TCP_NODELAY { 1 };'; - $blocking_supported = 0; # it appears that this DOESN'T work :-( - } -} - -my $w = $^W; -$^W = 0; -my $eagain = eval {EAGAIN()}; -my $einprogress = eval {EINPROGRESS()}; -my $ewouldblock = eval {EWOULDBLOCK()}; -$^W = $w; $cnum = 0; - # #----------------------------------------------------------------- # Generalised initializer @@ -132,32 +59,21 @@ sub set_error my $conn = shift; my $callback = shift; $conn->{eproc} = $callback; - set_event_handler($conn->{sock}, error => $callback) if exists $conn->{sock}; } -sub set_rproc +sub set_on_eof { my $conn = shift; my $callback = shift; - $conn->{rproc} = $callback; + $conn->{sock}->on_eof($callback); + $conn->{sock}->on_error($callback); } -sub blocking +sub set_rproc { - return unless $blocking_supported; - - # Make the handle stop blocking, the Windows way. - if ($blocking_supported) { - $_[0]->blocking($_[1]); - } else { - my $flags = fcntl ($_[0], F_GETFL, 0); - if ($_[1]) { - $flags &= ~O_NONBLOCK; - } else { - $flags |= O_NONBLOCK; - } - fcntl ($_[0], F_SETFL, $flags); - } + my $conn = shift; + my $callback = shift; + $conn->{rproc} = $callback; } # save it @@ -222,35 +138,24 @@ sub connect { $conn->{peerport} = $to_port; $conn->{sort} = 'Outgoing'; - my $sock; - if ($blocking_supported) { - $sock = $io_socket->new(PeerAddr => $to_host, PeerPort => $to_port, Proto => 'tcp', Blocking =>0) or return undef; - } else { - # Create a new internet socket - $sock = $io_socket->new(); - return undef unless $sock; + my $sock = AnyEvent::Handle->new( - my $proto = getprotobyname('tcp'); - $sock->socket(AF_INET, SOCK_STREAM, $proto) or return undef; + connect => [$to_host, $to_port], - blocking($sock, 0); - $conn->{blocking} = 0; + on_connect => sub {my $h = shift; $conn->{peerhost} = shift;}, - # does the host resolve? - my $ip = gethostbyname($to_host); - return undef unless $ip; + on_eof => sub {$conn->disconnect}, - my $r = connect($sock, pack_sockaddr_in($to_port, $ip)); - return undef unless $r || _err_will_block($!); - } + on_error => sub {$conn->disconnect}, + + keepalive => 1, + + linger => 0, + ); $conn->{sock} = $sock; - $conn->{peerhost} = $sock->peerhost; # for consistency + $sock->on_read(sub{$conn->_rcv}); - if ($conn->{rproc}) { - my $callback = sub {$conn->_rcv}; - set_event_handler ($sock, read => $callback); - } return $conn; } @@ -259,47 +164,47 @@ sub start_program my ($conn, $line, $sort) = @_; my $pid; - local $^F = 10000; # make sure it ain't closed on exec - my ($a, $b) = $io_socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC); - if ($a && $b) { - $a->autoflush(1); - $b->autoflush(1); - $pid = fork; - if (defined $pid) { - if ($pid) { - close $b; - $conn->{sock} = $a; - $conn->{csort} = $sort; - $conn->{lineend} = "\cM" if $sort eq 'ax25'; - $conn->{pid} = $pid; - if ($conn->{rproc}) { - my $callback = sub {$conn->_rcv}; - Msg::set_event_handler ($a, read => $callback); - } - dbg("connect $conn->{cnum}: started pid: $conn->{pid} as $line") if isdbg('connect'); - } else { - $^W = 0; - dbgclose(); - STDIN->close; - STDOUT->close; - STDOUT->close; - *STDIN = IO::File->new_from_fd($b, 'r') or die; - *STDOUT = IO::File->new_from_fd($b, 'w') or die; - *STDERR = IO::File->new_from_fd($b, 'w') or die; - close $a; - unless ($main::is_win) { - # $SIG{HUP} = 'IGNORE'; - $SIG{HUP} = $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = 'DEFAULT'; - alarm(0); - } - exec "$line" or dbg("exec '$line' failed $!"); - } - } else { - dbg("cannot fork for $line"); - } - } else { - dbg("no socket pair $! for $line"); - } +# local $^F = 10000; # make sure it ain't closed on exec +# my ($a, $b) = $io_socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC); +# if ($a && $b) { +# $a->autoflush(1); +# $b->autoflush(1); +# $pid = fork; +# if (defined $pid) { +# if ($pid) { +# close $b; +# $conn->{sock} = $a; +# $conn->{csort} = $sort; +# $conn->{lineend} = "\cM" if $sort eq 'ax25'; +# $conn->{pid} = $pid; +# if ($conn->{rproc}) { +# my $callback = sub {$conn->_rcv}; +# Msg::set_event_handler ($a, read => $callback); +# } +# dbg("connect $conn->{cnum}: started pid: $conn->{pid} as $line") if isdbg('connect'); +# } else { +# $^W = 0; +# dbgclose(); +# STDIN->close; +# STDOUT->close; +# STDOUT->close; +# *STDIN = IO::File->new_from_fd($b, 'r') or die; +# *STDOUT = IO::File->new_from_fd($b, 'w') or die; +# *STDERR = IO::File->new_from_fd($b, 'w') or die; +# close $a; +# unless ($main::is_win) { +# # $SIG{HUP} = 'IGNORE'; +# $SIG{HUP} = $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = 'DEFAULT'; +# alarm(0); +# } +# exec "$line" or dbg("exec '$line' failed $!"); +# } +# } else { +# dbg("cannot fork for $line"); +# } +# } else { +# dbg("no socket pair $! for $line"); +# } return $pid; } @@ -329,10 +234,14 @@ sub disconnect } } - if (defined($sock)) { - set_event_handler ($sock, read => undef, write => undef, error => undef); - shutdown($sock, 2); - close($sock); + if (ref $sock && $sock->isa('AnyEvent::Handle') && exists $sock->{fh}) { + shutdown($sock->{fh}, 2); + $sock->destroy; + } else { + my $s; + $s = "already destroyed" unless exists $sock->{fh}; + $s ||= ref $sock || $sock || "undefined"; + dbg("Msg::disconnect trying to disconnect a $s socket") if isdbg('chan'); } unless ($main::is_win) { @@ -340,115 +249,63 @@ sub disconnect } } -sub send_now { - my ($conn, $msg) = @_; - $conn->enqueue($msg); - $conn->_send (1); # 1 ==> flush +sub _send_stuff +{ + my $conn = shift; + my $rq = $conn->{outqueue}; + my $sock = $conn->{sock}; + + while (@$rq) { + my $data = shift @$rq; + my $lth = length $data; + my $call = $conn->{call} || 'none'; + if (isdbg('raw')) { + if (isdbg('raw')) { + dbgdump('raw', "$call send $lth: ", $lth); + } + } + if (defined $sock && !$sock->destroyed) { + $sock->push_write($data); + $total_out = $lth; + } else { + dbg("_send_stuff $call ending data ignored: $data"); + } + } } sub send_later { my ($conn, $msg) = @_; - $conn->enqueue($msg); - my $sock = $conn->{sock}; - return unless defined($sock); - set_event_handler ($sock, write => sub {$conn->_send(0)}); -} + my $rq = $conn->{outqueue}; + my $sock = $conn->{sock}; -sub enqueue { - my $conn = shift; - push (@{$conn->{outqueue}}, defined $_[0] ? $_[0] : ''); + # this is done like this because enqueueing may be going on independently of + # sending (whether later or now) + $conn->enqueue($msg); + _send_stuff($conn) } -sub _send { - my ($conn, $flush) = @_; - my $sock = $conn->{sock}; - return unless defined($sock); - my $rq = $conn->{outqueue}; - - # If $flush is set, set the socket to blocking, and send all - # messages in the queue - return only if there's an error - # If $flush is 0 (deferred mode) make the socket non-blocking, and - # return to the event loop only after every message, or if it - # is likely to block in the middle of a message. +sub send_now { goto &send_later; } -# if ($conn->{blocking} != $flush) { -# blocking($sock, $flush); -# $conn->{blocking} = $flush; -# } - my $offset = (exists $conn->{send_offset}) ? $conn->{send_offset} : 0; - - while (@$rq) { - my $msg = $rq->[0]; - my $mlth = length($msg); - my $bytes_to_write = $mlth - $offset; - my $bytes_written = 0; - confess("Negative Length! msg: '$msg' lth: $mlth offset: $offset") if $bytes_to_write < 0; - while ($bytes_to_write > 0) { - $bytes_written = syswrite ($sock, $msg, - $bytes_to_write, $offset); - if (!defined($bytes_written)) { - if (_err_will_block($!)) { - # Should happen only in deferred mode. Record how - # much we have already sent. - $conn->{send_offset} = $offset; - # Event handler should already be set, so we will - # be called back eventually, and will resume sending - return 1; - } else { # Uh, oh - &{$conn->{eproc}}($conn, $!) if exists $conn->{eproc}; - $conn->disconnect; - return 0; # fail. Message remains in queue .. - } - } elsif (isdbg('raw')) { - my $call = $conn->{call} || 'none'; - dbgdump('raw', "$call send $bytes_written: ", $msg); - } - $total_out += $bytes_written; - $offset += $bytes_written; - $bytes_to_write -= $bytes_written; - } - delete $conn->{send_offset}; - $offset = 0; - shift @$rq; - #last unless $flush; # Go back to select and wait - # for it to fire again. - } - # Call me back if queue has not been drained. - unless (@$rq) { - set_event_handler ($sock, write => undef); - if (exists $conn->{close_on_empty}) { - &{$conn->{eproc}}($conn, undef) if exists $conn->{eproc}; - $conn->disconnect; - } - } - 1; # Success +sub send_raw +{ + my ($conn, $msg) = @_; + push @{$conn->{outqueue}}, $msg; + _send_stuff($conn); } -sub dup_sock -{ - my $conn = shift; - my $oldsock = $conn->{sock}; - my $rc = $rd_callbacks{$oldsock}; - my $wc = $wt_callbacks{$oldsock}; - my $ec = $er_callbacks{$oldsock}; - my $sock = $oldsock->new_from_fd($oldsock, "w+"); - if ($sock) { - set_event_handler($oldsock, read=>undef, write=>undef, error=>undef); - $conn->{sock} = $sock; - set_event_handler($sock, read=>$rc, write=>$wc, error=>$ec); - $oldsock->close; - } +sub enqueue { + my $conn = shift; + push (@{$conn->{outqueue}}, defined $_[0] ? $_[0] : ''); } sub _err_will_block { - return 0 unless $blocking_supported; - return ($_[0] == $eagain || $_[0] == $ewouldblock || $_[0] == $einprogress); + return 0; } sub close_on_empty { my $conn = shift; - $conn->{close_on_empty} = 1; + $conn->{sock}->on_drain(sub {$conn->disconnect;}); } #----------------------------------------------------------------- @@ -459,14 +316,8 @@ sub new_server { my ($pkg, $my_host, $my_port, $login_proc) = @_; my $self = $pkg->new($login_proc); - $self->{sock} = $io_socket->new ( - LocalAddr => "$my_host:$my_port", -# LocalPort => $my_port, - Listen => SOMAXCONN, - Proto => 'tcp', - Reuse => 1); + $self->{sock} = tcp_server $my_host, $my_port, sub { $self->new_client(@_); }; die "Could not create socket: $! \n" unless $self->{sock}; - set_event_handler ($self->{sock}, read => sub { $self->new_client } ); return $self; } @@ -474,27 +325,9 @@ sub new_server { sub nolinger { my $conn = shift; - - unless ($main::is_win) { - if (isdbg('sock')) { - my ($l, $t) = unpack "ll", getsockopt($conn->{sock}, SOL_SOCKET, SO_LINGER); - my $k = unpack 'l', getsockopt($conn->{sock}, SOL_SOCKET, SO_KEEPALIVE); - my $n = $main::is_win ? 0 : unpack "l", getsockopt($conn->{sock}, IPPROTO_TCP, TCP_NODELAY); - dbg("Linger is: $l $t, keepalive: $k, nagle: $n"); - } - - eval {setsockopt($conn->{sock}, SOL_SOCKET, SO_KEEPALIVE, 1)} or dbg("setsockopt keepalive: $!"); - eval {setsockopt($conn->{sock}, SOL_SOCKET, SO_LINGER, pack("ll", 0, 0))} or dbg("setsockopt linger: $!"); - eval {setsockopt($conn->{sock}, IPPROTO_TCP, TCP_NODELAY, 1)} or eval {setsockopt($conn->{sock}, SOL_SOCKET, TCP_NODELAY, 1)} or dbg("setsockopt tcp_nodelay: $!"); - $conn->{sock}->autoflush(0); - - if (isdbg('sock')) { - my ($l, $t) = unpack "ll", getsockopt($conn->{sock}, SOL_SOCKET, SO_LINGER); - my $k = unpack 'l', getsockopt($conn->{sock}, SOL_SOCKET, SO_KEEPALIVE); - my $n = $main::is_win ? 0 : unpack "l", getsockopt($conn->{sock}, IPPROTO_TCP, TCP_NODELAY); - dbg("Linger is: $l $t, keepalive: $k, nagle: $n"); - } - } + my $sock = $conn->{sock}; +# $sock->linger(0); +# $sock->keepalive(1); } sub dequeue @@ -522,76 +355,70 @@ sub _rcv { # Complement to _send return unless defined($sock); my @lines; -# if ($conn->{blocking}) { -# blocking($sock, 0); -# $conn->{blocking} = 0; -# } - $bytes_read = sysread ($sock, $msg, 1024, 0); - if (defined ($bytes_read)) { - if ($bytes_read > 0) { - $total_in += $bytes_read; - if (isdbg('raw')) { - my $call = $conn->{call} || 'none'; - dbgdump('raw', "$call read $bytes_read: ", $msg); - } - if ($conn->{echo}) { - my @ch = split //, $msg; - my $out; - for (@ch) { - if (/[\cH\x7f]/) { - $out .= "\cH \cH"; - $conn->{msg} =~ s/.$//; - } else { - $out .= $_; - $conn->{msg} .= $_; - } - } - if (defined $out) { - set_event_handler ($sock, write => sub{$conn->_send(0)}); - push @{$conn->{outqueue}}, $out; + $msg = $sock->{rbuf}; + $bytes_read = length $msg || 0; + $sock->{rbuf} = ''; + + if ($bytes_read > 0) { + $total_in += $bytes_read; + if (isdbg('raw')) { + my $call = $conn->{call} || 'none'; + dbgdump('raw', "$call read $bytes_read: ", $msg); + } + if ($conn->{echo}) { + my @ch = split //, $msg; + my $out; + for (@ch) { + if (/[\cH\x7f]/) { + $out .= "\cH \cH"; + $conn->{msg} =~ s/.$//; + } else { + $out .= $_; + $conn->{msg} .= $_; } - } else { - $conn->{msg} .= $msg; } - } - } else { - if (_err_will_block($!)) { - return ; + if (defined $out) { + $conn->send_now($out); + } } else { - $bytes_read = 0; + $conn->{msg} .= $msg; } - } + } -FINISH: - if (defined $bytes_read && $bytes_read == 0) { - &{$conn->{eproc}}($conn, $!) if exists $conn->{eproc}; - $conn->disconnect; - } else { - unless ($conn->{disable_read}) { - $conn->dequeue if exists $conn->{msg}; - } + unless ($conn->{disable_read}) { + $conn->dequeue if exists $conn->{msg}; } } sub new_client { my $server_conn = shift; - my $sock = $server_conn->{sock}->accept(); + my $sock = shift; + my $peerhost = shift; + my $peerport = shift; if ($sock) { my $conn = $server_conn->new($server_conn->{rproc}); - $conn->{sock} = $sock; - blocking($sock, 0); - $conn->nolinger; + $conn->{sock} = AnyEvent::Handle->new( + + fh => $sock, + + on_eof => sub {$conn->disconnect}, + + on_error => sub {$conn->disconnect}, + + keepalive => 1, + + linger => 0, + ); $conn->{blocking} = 0; - my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost} = $sock->peerhost(), $conn->{peerport} = $sock->peerport()); + my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost} = $peerhost, $conn->{peerport} = $peerport); + dbg("accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}") if isdbg('connll'); $conn->{sort} = 'Incoming'; + $conn->{sock}->on_read(sub {$conn->_rcv}); if ($eproc) { $conn->{eproc} = $eproc; - set_event_handler ($sock, error => $eproc); } if ($rproc) { $conn->{rproc} = $rproc; - my $callback = sub {$conn->_rcv}; - set_event_handler ($sock, read => $callback); } else { # Login failed &{$conn->{eproc}}($conn, undef) if exists $conn->{eproc}; $conn->disconnect(); @@ -604,8 +431,7 @@ sub new_client { sub close_server { my $conn = shift; - set_event_handler ($conn->{sock}, read => undef, write => undef, error => undef ); - $conn->{sock}->close; + undef $conn->{sock}; } # close all clients (this is for forking really) @@ -619,96 +445,37 @@ sub close_all_clients sub disable_read { my $conn = shift; - set_event_handler ($conn->{sock}, read => undef); - return $_[0] ? $conn->{disable_read} = $_[0] : $_[0]; + return defined $_[0] ? $conn->{disable_read} = $_[0] : $_[0]; } -# -#---------------------------------------------------- -# Event loop routines used by both client and server - -sub set_event_handler { - shift unless ref($_[0]); # shift if first arg is package name - my ($handle, %args) = @_; - my $callback; - if (exists $args{'write'}) { - $callback = $args{'write'}; - if ($callback) { - $wt_callbacks{$handle} = $callback; - $wt_handles->add($handle); - } else { - delete $wt_callbacks{$handle}; - $wt_handles->remove($handle); - } - } - if (exists $args{'read'}) { - $callback = $args{'read'}; - if ($callback) { - $rd_callbacks{$handle} = $callback; - $rd_handles->add($handle); - } else { - delete $rd_callbacks{$handle}; - $rd_handles->remove($handle); - } - } - if (exists $args{'error'}) { - $callback = $args{'error'}; - if ($callback) { - $er_callbacks{$handle} = $callback; - $er_handles->add($handle); - } else { - delete $er_callbacks{$handle}; - $er_handles->remove($handle); - } - } +sub sleep +{ + my ($pkg, $interval) = @_; + my $cv = AnyEvent->condvar; + my $wait_a_bit = AnyEvent->timer( + after => $interval, + cb => sub {$cv->send}, + ); + $cv->recv; } -sub event_loop { - my ($pkg, $loop_count, $timeout, $wronly) = @_; # event_loop(1) to process events once - my ($conn, $r, $w, $e, $rset, $wset, $eset); - while (1) { - - # Quit the loop if no handles left to process - if ($wronly) { - last unless $wt_handles->count(); - - ($rset, $wset, $eset) = IO::Select->select(undef, $wt_handles, undef, $timeout); - - foreach $w (@$wset) { - &{$wt_callbacks{$w}}($w) if exists $wt_callbacks{$w}; - } - } else { - - last unless ($rd_handles->count() || $wt_handles->count()); - - ($rset, $wset, $eset) = IO::Select->select($rd_handles, $wt_handles, $er_handles, $timeout); - - foreach $e (@$eset) { - &{$er_callbacks{$e}}($e) if exists $er_callbacks{$e}; - } - foreach $r (@$rset) { - &{$rd_callbacks{$r}}($r) if exists $rd_callbacks{$r}; - } - foreach $w (@$wset) { - &{$wt_callbacks{$w}}($w) if exists $wt_callbacks{$w}; - } - } - - Timer::handler; - - if (defined($loop_count)) { - last unless --$loop_count; - } - } +sub set_event_handler +{ + my $sock = shift; + my %args = @_; + my ($pkg, $fn, $line) = caller; + my $s; + foreach (my ($k,$v) = each %args) { + $s .= "$k => $v, "; + } + $s =~ s/[\s,]$//; + dbg("Msg::set_event_handler called from ${pkg}::${fn} line $line doing $s"); } -sub sleep +sub echo { - my ($pkg, $interval) = @_; - my $now = time; - while (time - $now < $interval) { - $pkg->event_loop(10, 0.01); - } + my $conn = shift; + return defined $_[0] ? $conn->{echo} = $_[0] : $_[0]; } sub DESTROY diff --git a/perl/Sun.pm b/perl/Sun.pm index aaf85a33..5190db18 100644 --- a/perl/Sun.pm +++ b/perl/Sun.pm @@ -33,12 +33,6 @@ require Exporter; use strict; -use vars qw($pi $d2r $r2d); - -$pi = 3.141592653589; -$d2r = ($pi/180); -$r2d = (180/$pi); - use vars qw(%keps); use Keps; use DXVars; diff --git a/perl/Version.pm b/perl/Version.pm index 2e78796b..527a4f05 100644 --- a/perl/Version.pm +++ b/perl/Version.pm @@ -9,9 +9,9 @@ package main; use vars qw($version $subversion $build $gitversion); -$version = '1.55'; +$version = '1.56'; $subversion = '0'; -$build = '110'; -$gitversion = '61885d0'; +$build = '31'; +$gitversion = '4e42369'; 1; diff --git a/perl/cluster.pl b/perl/cluster.pl index 5c3f0fb9..745ad1dd 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -52,6 +52,8 @@ BEGIN { $systime = time; } +use AnyEvent; + use DXVars; use Msg; use IntMsg; @@ -121,7 +123,7 @@ use vars qw(@inqueue $systime $starttime $lockfn @outstanding_connects $zombies $root @listeners $lang $myalias @debug $userfn $clusteraddr $clusterport $mycall $decease $is_win $routeroot $me $reqreg $bumpexisting $allowdxby $dbh $dsn $dbuser $dbpass $do_xml $systime_days $systime_daystart - $can_encode $maxconnect_user $maxconnect_node + $can_encode $maxconnect_user $maxconnect_node $idle_interval ); @inqueue = (); # the main input queue, an array of hashes @@ -136,16 +138,16 @@ $maxconnect_user = 3; # the maximum no of concurrent connections a user can ha $maxconnect_node = 0; # Ditto but for nodes. In either case if a new incoming connection # takes the no of references in the routing table above these numbers # then the connection is refused. This only affects INCOMING connections. +$idle_interval = 0.100; # the wait between invocations of the main idle loop processing. # send a message to call on conn and disconnect sub already_conn { my ($conn, $call, $mess) = @_; - $conn->disable_read(1); dbg("-> D $call $mess\n") if isdbg('chan'); + $conn->disable_read(1); $conn->send_now("D$call|$mess"); - sleep(2); $conn->disconnect; } @@ -273,7 +275,6 @@ sub cease foreach $dxchan (DXChannel::get_all_nodes) { $dxchan->disconnect(2) unless $dxchan == $main::me; } - Msg->event_loop(100, 0.01); # disconnect users foreach $dxchan (DXChannel::get_all_users) { @@ -288,7 +289,6 @@ sub cease UDPMsg::finish(); # end everything else - Msg->event_loop(100, 0.01); DXUser::finish(); DXDupe::finish(); @@ -301,6 +301,8 @@ sub cease } LogDbg('cluster', "DXSpider V$version, build $subversion.$build (git: $gitversion) ended"); + dbg("bye bye everyone - bye bye"); + dbgclose(); Logclose(); @@ -342,6 +344,47 @@ sub AGWrestart AGWMsg::init(\&new_channel); } +sub idle_loop +{ + my $timenow = time; + + DXChannel::process(); + +# $DB::trace = 0; + + # do timed stuff, ongoing processing happens one a second + if ($timenow != $systime) { + reap() if $zombies; + $systime = $timenow; + my $days = int ($systime / 86400); + if ($systime_days != $days) { + $systime_days = $days; + $systime_daystart = $days * 86400; + } + IsoTime::update($systime); + DXCron::process(); # do cron jobs + DXCommandmode::process(); # process ongoing command mode stuff + DXXml::process(); + DXProt::process(); # process ongoing ak1a pcxx stuff + DXConnect::process(); + DXMsg::process(); + DXDb::process(); + DXUser::process(); + DXDupe::process(); + AGWMsg::process(); + BPQMsg::process(); + + Timer::handler(); + + if (defined &Local::process) { + eval { + Local::process(); # do any localised processing + }; + dbg("Local::process error $@") if $@; + } + } +} + ############################################################# # # The start of the main line of code @@ -444,9 +487,16 @@ UDPMsg::init(\&new_channel); # load bad words dbg("load badwords: " . (BadWords::load or "Ok")); +# create end condvar +$decease = AnyEvent->condvar; + # prime some signals +my ($sigint, $sigterm); unless ($DB::VERSION) { - $SIG{INT} = $SIG{TERM} = sub { $decease = 1 }; + $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) { @@ -535,49 +585,12 @@ $script->run($main::me) if $script; #open(DB::OUT, "|tee /tmp/aa"); -for (;;) { -# $DB::trace = 1; - - Msg->event_loop(10, 0.010); - my $timenow = time; - - DXChannel::process(); - -# $DB::trace = 0; +my $per_sec = AnyEvent->timer(after => 0, interval => $idle_interval, cb => sub{idle_loop()}); - # do timed stuff, ongoing processing happens one a second - if ($timenow != $systime) { - reap() if $zombies; - $systime = $timenow; - my $days = int ($systime / 86400); - if ($systime_days != $days) { - $systime_days = $days; - $systime_daystart = $days * 86400; - } - IsoTime::update($systime); - DXCron::process(); # do cron jobs - DXCommandmode::process(); # process ongoing command mode stuff - DXXml::process(); - DXProt::process(); # process ongoing ak1a pcxx stuff - DXConnect::process(); - DXMsg::process(); - DXDb::process(); - DXUser::process(); - DXDupe::process(); - AGWMsg::process(); - BPQMsg::process(); +# main loop +$decease->recv; - if (defined &Local::process) { - eval { - Local::process(); # do any localised processing - }; - dbg("Local::process error $@") if $@; - } - } - if ($decease) { - last if --$decease <= 0; - } -} +idle_loop() for (1..25); cease(0); exit(0); diff --git a/perl/console.pl b/perl/console.pl index 0a6d7404..4ba23d43 100755 --- a/perl/console.pl +++ b/perl/console.pl @@ -26,6 +26,9 @@ BEGIN { $is_win = ($^O =~ /^MS/ || $^O =~ /^OS-2/) ? 1 : 0; # is it Windows? } +use strict; + +use AnyEvent; use Msg; use IntMsg; use DXVars; @@ -39,21 +42,36 @@ use Text::Wrap; use Console; +use vars qw($maxkhist $maxshist $foreground $background $mycallcolor @colors ); + # # initialisation # -$call = ""; # the callsign being used -$conn = 0; # the connection object for the cluster -$lasttime = time; # lasttime something happened on the interface +my $call = ""; # the callsign being used +my $conn = 0; # the connection object for the cluster +my $lasttime = time; # lasttime something happened on the interface + +my $connsort = "local"; +my @khistory = (); +my @shistory = (); +my $khistpos = 0; +my $pos; +my $lth; +my $bot; +my $top; +my $pagel = 25; +my $cols = 80; +my $lines = 25; +my $scr; +my $spos = $pos = $lth = 0; +my $inbuf = ""; +my @time = (); -$connsort = "local"; -@khistory = (); -@shistory = (); -$khistpos = 0; -$spos = $pos = $lth = 0; -$inbuf = ""; -@time = (); +my $lastmin = 0; +my $sigint; +my $sigterm; +my $decease; #$SIG{WINCH} = sub {@time = gettimeofday}; @@ -67,16 +85,16 @@ sub mydbg sub do_initscr { $scr = new Curses; - if ($has_colors) { + if ($main::has_colors) { start_color(); - init_pair("0", $foreground, $background); -# init_pair(0, $background, $foreground); - init_pair(1, COLOR_RED, $background); - init_pair(2, COLOR_YELLOW, $background); - init_pair(3, COLOR_GREEN, $background); - init_pair(4, COLOR_CYAN, $background); - init_pair(5, COLOR_BLUE, $background); - init_pair(6, COLOR_MAGENTA, $background); + init_pair("0", $main::foreground, $main::background); +# init_pair(0, $main::background, $main::foreground); + init_pair(1, COLOR_RED, $main::background); + init_pair(2, COLOR_YELLOW, $main::background); + init_pair(3, COLOR_GREEN, $main::background); + init_pair(4, COLOR_CYAN, $main::background); + init_pair(5, COLOR_BLUE, $main::background); + init_pair(6, COLOR_MAGENTA, $main::background); init_pair(7, COLOR_RED, COLOR_BLUE); init_pair(8, COLOR_YELLOW, COLOR_BLUE); init_pair(9, COLOR_GREEN, COLOR_BLUE); @@ -85,7 +103,7 @@ sub do_initscr init_pair(12, COLOR_MAGENTA, COLOR_BLUE); init_pair(13, COLOR_YELLOW, COLOR_GREEN); init_pair(14, COLOR_RED, COLOR_GREEN); - eval { assume_default_colors($foreground, $background) } unless $is_win; + eval { assume_default_colors($main::foreground, $main::background) } unless $main::is_win; } $top = $scr->subwin($lines-4, $cols, 0, 0); @@ -117,19 +135,29 @@ sub do_resize nonl(); $lines = LINES; $cols = COLS; - $has_colors = has_colors(); + $main::has_colors = has_colors(); do_initscr(); show_screen(); } +my $ceasing = 0; + # cease communications sub cease { my $sendz = shift; + + print "ceasing ($ceasing)\r\n"; + + return if $ceasing; + ++$ceasing; + $conn->disconnect if $conn; - endwin(); dbgclose(); + endwin(); + $decease->send; + print @_ if @_; exit(0); } @@ -143,7 +171,7 @@ sub sig_term # determine the colour of the line sub setattr { - if ($has_colors) { + if ($main::has_colors) { foreach my $ref (@colors) { if ($_[0] =~ m{$$ref[0]}) { $top->attrset($$ref[1]); @@ -176,7 +204,7 @@ sub show_screen setattr($line); $top->addstr($line); # $top->addstr("\n"); - $top->attrset(COLOR_PAIR(0)) if $has_colors; + $top->attrset(COLOR_PAIR(0)) if $main::has_colors; $spos = @shistory; } else { @@ -192,7 +220,7 @@ sub show_screen $p = 0 if $p < 0; $top->move(0, 0); - $top->attrset(COLOR_PAIR(0)) if $has_colors; + $top->attrset(COLOR_PAIR(0)) if $main::has_colors; $top->clrtobot(); for ($i = 0; $i < $pagel && $p < @shistory; $p++) { my $line = $shistory[$p]; @@ -201,7 +229,7 @@ sub show_screen $top->addstr("\n") if $i; setattr($line); $top->addstr($line); - $top->attrset(COLOR_PAIR(0)) if $has_colors; + $top->attrset(COLOR_PAIR(0)) if $main::has_colors; $i += $lines; } $spos = $p; @@ -215,9 +243,9 @@ sub show_screen $scr->addstr($lines-4, 0, $str); $scr->addstr($size); - $scr->attrset($mycallcolor) if $has_colors; + $scr->attrset($mycallcolor) if $main::has_colors; $scr->addstr($call); - $scr->attrset(COLOR_PAIR(0)) if $has_colors; + $scr->attrset(COLOR_PAIR(0)) if $main::has_colors; $scr->addstr($add); $scr->refresh(); # $top->refresh(); @@ -443,13 +471,39 @@ sub rec_stdin $bot->refresh(); } +sub idle_loop +{ + my $t; + $t = time; + if ($t > $lasttime) { + my ($min)= (gmtime($t))[1]; + if ($min != $lastmin) { + show_screen(); + $lastmin = $min; + } + $lasttime = $t; + } + my $ch = $bot->getch(); + if (@time && tv_interval(\@time, [gettimeofday]) >= 1) { +# mydbg("Got Resize"); +# do_resize(); + next; + } + if (defined $ch) { + if ($ch ne '-1') { + rec_stdin($ch); + } + } + $top->refresh() if $top->is_wintouched; + $bot->refresh(); +} # # deal with args # $call = uc shift @ARGV if @ARGV; -$call = uc $myalias if !$call; +$call = uc $main::myalias if !$call; my ($scall, $ssid) = split /-/, $call; $ssid = undef unless $ssid && $ssid =~ /^\d+$/; if ($ssid) { @@ -457,41 +511,46 @@ if ($ssid) { $call = "$scall-$ssid"; } -if ($call eq $mycall) { - print "You cannot connect as your cluster callsign ($mycall)\n"; +if ($call eq $main::mycall) { + print "You cannot connect as your cluster callsign ($main::mycall)\n"; exit(0); } +# create end condvar +$decease = AnyEvent->condvar; + dbginit(); -$conn = IntMsg->connect("$clusteraddr", $clusterport, \&rec_socket); +$conn = IntMsg->connect("$main::clusteraddr", $main::clusterport, \&rec_socket); if (! $conn) { - if (-r "$data/offline") { - open IN, "$data/offline" or die; + if (-r "$main::root/data/offline") { + open IN, "$main::root/data/offline" or die; while () { print $_; } close IN; } else { - print "Sorry, the cluster $mycall is currently off-line\n"; + print "Sorry, the cluster $main::mycall is currently off-line\n"; } exit(0); } -$conn->set_error(sub{cease(0)}); - unless ($DB::VERSION) { - $SIG{'INT'} = \&sig_term; - $SIG{'TERM'} = \&sig_term; + $sigint = AnyEvent->signal(signal=>'INT', cb=> sub{$decease->send}); + $sigterm = AnyEvent->signal(signal=>'TERM', cb=> sub{$decease->send}); } -$SIG{'HUP'} = \&sig_term; +#$SIG{'HUP'} = \&sig_term; +my $sighup = AnyEvent->signal(signal=>'HUP', cb=> sub{$decease->send}); +$conn->{sock}->on_eof(sub{$decease->send}); +$conn->{sock}->on_error(sub{$decease->send}); # start up do_resize(); -$SIG{__DIE__} = \&sig_term; +#$SIG{__DIE__} = \&sig_term; +#my $sigdie = AnyEvent->signal(signal=>'__DIE__', cb=> sub{$decease->send}); $conn->send_later("A$call|$connsort width=$cols"); $conn->send_later("I$call|set/page $maxshist"); @@ -501,32 +560,8 @@ $conn->send_later("I$call|set/page $maxshist"); $Text::Wrap::Columns = $cols; -my $lastmin = 0; -for (;;) { - my $t; - Msg->event_loop(1, 0.01); - $t = time; - if ($t > $lasttime) { - my ($min)= (gmtime($t))[1]; - if ($min != $lastmin) { - show_screen(); - $lastmin = $min; - } - $lasttime = $t; - } - my $ch = $bot->getch(); - if (@time && tv_interval(\@time, [gettimeofday]) >= 1) { -# mydbg("Got Resize"); -# do_resize(); - next; - } - if (defined $ch) { - if ($ch ne '-1') { - rec_stdin($ch); - } - } - $top->refresh() if $top->is_wintouched; - $bot->refresh(); -} +my $event_loop = AnyEvent->timer(after => 0, interval => 0.010, cb => sub{idle_loop()}); + +$decease->recv; -exit(0); +cease(0); diff --git a/perl/create_sysop.pl b/perl/create_sysop.pl index 22b64d71..0ec29039 100755 --- a/perl/create_sysop.pl +++ b/perl/create_sysop.pl @@ -19,6 +19,8 @@ BEGIN { unshift @INC, "$root/local"; } +package main; + use DXVars; use DXUser; @@ -88,9 +90,9 @@ if (-e $lockfn) { close CLLOCK; } -$DXUser::v3 = 1; +$DXUser::v4 = 1; -if (-e "$userfn.v2" || -e "$userfn.v3") { +if (-e "$userfn.v2" || -e "$userfn.v3" ||-e "$userfn.v4") { print "Do you wish to destroy your user database (THINK!!!) [y/N]: "; $ans = ; if ($ans =~ /^[Yy]/) { @@ -110,6 +112,7 @@ if (-e "$userfn.v2" || -e "$userfn.v3") { DXUser->init($userfn, 1); create_it(); } +DXUser->sync; DXUser->finish(); exit(0);