From: Dirk Koopman Date: Fri, 13 Jun 2014 12:24:38 +0000 (+0100) Subject: Merge branch 'master' into mojo X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=commitdiff_plain;h=b0d9bed295647635da9cd1ceeb5e4592bd87094b;hp=6543cc71201e2aaa882801b8624b15ab88aa9a31;p=spider.git Merge branch 'master' into mojo Just bring stuff up to date Conflicts: Changes data/cty.dat data/prefix_data.pl perl/Version.pm --- diff --git a/cmd/show/version.pl b/cmd/show/version.pl index 7107570d..b57dd36c 100644 --- a/cmd/show/version.pl +++ b/cmd/show/version.pl @@ -9,7 +9,7 @@ my @out; my ($year) = (gmtime($main::systime))[5]; $year += 1900; -push @out, "DX Spider Cluster version $main::version (build $main::subversion.$main::build git: $main::gitversion) on \u$^O"; +push @out, "DX Spider Cluster version $main::version (build $main::build git: $main::gitversion) on \u$^O"; push @out, "Copyright (c) 1998-$year Dirk Koopman G1TLH"; return (1, @out); diff --git a/data/cty.dat b/data/cty.dat index a37c8ae5..6d782aaf 100644 --- a/data/cty.dat +++ b/data/cty.dat @@ -121,7 +121,7 @@ Trinidad & Tobago: 09: 11: SA: 10.38: 61.28: 4.0: 9Y: Botswana: 38: 57: AF: -22.00: -24.00: -2.0: A2: 8O,A2; Tonga: 32: 62: OC: -21.22: 175.13: -13.0: A3: - A3; + A3,=A35JP/H; Oman: 21: 39: AS: 23.60: -58.55: -4.0: A4: A4; Bhutan: 22: 41: AS: 27.40: -90.18: -6.0: A5: @@ -489,7 +489,8 @@ Thailand: 26: 49: AS: 12.60: -99.70: -7.0: HS: Vatican City: 15: 28: EU: 41.90: -12.47: -1.0: HV: HV; Saudi Arabia: 21: 39: AS: 24.20: -43.83: -3.0: HZ: - 7Z,8Z,HZ; + 7Z,8Z,HZ,=7Z1BL/ND,=7Z1CQ/ND,=7Z1TT/ND,=HZ1BO/ND,=HZ1BW/ND,=HZ1DG/ND, + =HZ1HN/ND,=HZ1SK/ND,=HZ1XB/ND; Italy: 15: 28: EU: 42.82: -12.58: -1.0: I: I,=4U0WFP,=4U1GSC,=4U4F; African Italy: 33: 37: AF: 35.67: -12.67: -1.0: *IG9: @@ -1188,7 +1189,7 @@ Cocos (Keeling) Islands: 29: 54: OC: -12.15: -96.82: -6.5: VK9C: AX9C,AX9Y,VH9C,VH9Y,VI9C,VI9Y,VJ9C,VJ9Y,VK9C,VK9Y,VL9C,VL9Y,VM9C,VM9Y, VN9C,VN9Y,VZ9C,VZ9Y; Lord Howe Island: 30: 60: OC: -31.55: -159.08: -10.5: VK9L: - AX9L,VH9L,VI9L,VJ9L,VK9L,VL9L,VM9L,VN9L,VZ9L; + AX9L,VH9L,VI9L,VJ9L,VK9L,VL9L,VM9L,VN9L,VZ9L,=VK9DAC; Mellish Reef: 30: 56: OC: -17.40: -155.85: -10.0: VK9M: AX9M,VH9M,VI9M,VJ9M,VK9M,VL9M,VM9M,VN9M,VZ9M; Norfolk Island: 32: 60: OC: -29.03: -167.93: -11.5: VK9N: @@ -1274,7 +1275,7 @@ Romania: 20: 28: EU: 45.78: -24.70: -2.0: YO: El Salvador: 07: 11: NA: 14.00: 89.00: 6.0: YS: HU,YS; Serbia: 15: 28: EU: 44.00: -21.00: -1.0: YU: - YT,YU; + YT,YU,=YU7RQ/FAIR; Venezuela: 09: 12: SA: 8.00: 66.00: 4.5: YV: 4M,YV,YW,YX,YY; Aves Island: 08: 11: NA: 15.67: 63.60: 4.0: YV0: @@ -1288,7 +1289,7 @@ Kosovo: 15: 28: EU: 42.67: -21.17: -1.0: *Z6: Republic of South Sudan: 34: 48: AF: 4.85: -31.60: -3.0: Z8: Z8; Albania: 15: 28: EU: 41.00: -20.00: -1.0: ZA: - ZA; + ZA,=VERSION; Gibraltar: 14: 37: EU: 36.15: 5.37: -1.0: ZB: ZB,ZG; UK Base Areas on Cyprus: 20: 39: AS: 35.32: -33.57: -2.0: ZC4: diff --git a/data/prefix_data.pl b/data/prefix_data.pl index 2da7a5d8..e0307edd 100644 --- a/data/prefix_data.pl +++ b/data/prefix_data.pl @@ -3441,9 +3441,13 @@ '=4U1WB' => '178', '=4U4F' => '164,773,775,777,779,781,783,785,787,789,791,793,795,797,799,801,803,805,807,809,811,813,815,817,819,821,823,825', '=4Y1A' => '946', + '=7Z1BL/ND' => '163,767,769,771', + '=7Z1CQ/ND' => '163,767,769,771', + '=7Z1TT/ND' => '163,767,769,771', '=8J1RL' => '1674,1676,1679,1681,1683,1685,1687,330,342', '=9M4RSA' => '54', '=9M8DX/2' => '53', + '=A35JP/H' => '62', '=AA4DD' => '178', '=AA4R' => '178', '=AA4YL' => '178', @@ -3617,6 +3621,12 @@ '=GS3ZET' => '676', '=HF0POL' => '342', '=HK0TU' => '332', + '=HZ1BO/ND' => '163,767,769,771', + '=HZ1BW/ND' => '163,767,769,771', + '=HZ1DG/ND' => '163,767,769,771', + '=HZ1HN/ND' => '163,767,769,771', + '=HZ1SK/ND' => '163,767,769,771', + '=HZ1XB/ND' => '163,767,769,771', '=IA/IZ3SUS' => '1674,1676,1679,1681,1683,1685,1687,330,342', '=II0ICH' => '165', '=II0IDP' => '165', @@ -4262,6 +4272,7 @@ '=VER20140420' => '277,1464,1466,1468,1470,1472,1474,1476,1478,1480,1482,1484,1486,1488,1490,1492,1494', '=VERSION' => '88,531,533,535,537,539,541,543,545,547,549,551,553,555,557,559,561,563,565,567', '=VK0IR' => '334', + '=VK9DAC' => '337', '=VP6DX' => '285', '=VP8ADE' => '1674,1676,1679,1681,1683,1685,1687,330,342', '=VP8ADE/B' => '1674,1676,1679,1681,1683,1685,1687,330,342', @@ -4435,6 +4446,7 @@ '=WY7SS' => '178', '=WZ4F' => '178', '=WZ7I' => '178', + '=YU7RQ/FAIR' => '309,1576', '=ZM90DX' => '323,1600,1602,1604,1606', 'A2' => '61', 'A3' => '62', diff --git a/perl/AsyncMsg.pm b/perl/AsyncMsg.pm index c2eeaadc..7a62bbcc 100644 --- a/perl/AsyncMsg.pm +++ b/perl/AsyncMsg.pm @@ -180,26 +180,29 @@ sub _getpost $conn->{_assort} = $sort; $r = $conn->connect($host, $port); - if ($r) { - 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 _getpost_onconnect +{ + + 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"); +} + sub get { my $pkg = shift; @@ -215,6 +218,7 @@ sub post # do a raw connection # # Async->raw($self, , , [handler => CODE ref], [prefix => ]); +b390vpw # # With no handler defined, everything sent by the connection will be sent to # the caller. @@ -238,6 +242,20 @@ sub raw return $r ? $conn : undef; } +sub _on_connect +{ + my $conn = shift; + my $handle = shift; + dbg("AsyncMsg: Connected $conn->{cnum} to $host $port") if isdbg('async'); +} + +sub _on_error +{ + my $conn = shift; + my $msg = shift; + dbg("AsyncMsg: ***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('async'); +} + sub connect { my $conn = shift; @@ -245,13 +263,8 @@ sub connect my $port = shift; # start a connection - my $r = $conn->SUPER::connect($host, $port); - if ($r) { - dbg("AsyncMsg: Connected $conn->{cnum} to $host $port") if isdbg('async'); - } else { - dbg("AsyncMsg: ***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('async'); - } - + my $r = $conn->SUPER::connect($host, $port, on_connect => &\_on_connect); + return $r; } diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 35c92341..7147b35c 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -793,7 +793,7 @@ sub find_cmd_name { #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); diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 09ab5451..ca9b4922 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -246,7 +246,7 @@ sub init $main::me->{pingave} = 0; $main::me->{registered} = 1; $main::me->{version} = $main::version; - $main::me->{build} = "$main::subversion.$main::build"; + $main::me->{build} = $main::build; $main::me->{do_pc9x} = 1; $main::me->update_pc92_next($pc92_short_update_period); $main::me->update_pc92_keepalive; diff --git a/perl/DXProtout.pm b/perl/DXProtout.pm index fc116f8e..088d82e5 100644 --- a/perl/DXProtout.pm +++ b/perl/DXProtout.pm @@ -130,7 +130,7 @@ sub pc17 sub pc18 { my $flags = shift; - return "PC18^DXSpider Version: $main::version Build: $main::subversion.$main::build Git: $main::gitversion$flags^$DXProt::myprot_version^"; + return "PC18^DXSpider Version: $main::version Build: $main::build Git: $main::gitversion$flags^$DXProt::myprot_version^"; } # diff --git a/perl/ExtMsg.pm b/perl/ExtMsg.pm index f3f473ab..19aa3b47 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)}); + dbg((ref $conn) . " connect $conn->{cnum}: $msg") if $conn->{state} ne 'C' && isdbg('connect'); + $conn->SUPER::send_raw($msg); } sub echo @@ -154,57 +151,21 @@ sub to_connected $conn->{timeout}->del if $conn->{timeout}; delete $conn->{timeout}; $conn->{csort} = $sort; - unless ($conn->ax25) { - eval {$conn->{peerhost} = $conn->{sock}->peerhost}; - $conn->nolinger; - } &{$conn->{rproc}}($conn, "$dir$call|$sort"); $conn->_send_file("$main::data/connected") unless $conn->{outgoing}; } sub new_client { + my $server_conn = shift; - my $sock = $server_conn->{sock}->accept(); - if ($sock) { - my $conn = $server_conn->new($server_conn->{rproc}); - $conn->{sock} = $sock; - $conn->nolinger; - Msg::blocking($sock, 0); - $conn->{blocking} = 0; - eval {$conn->{peerhost} = $sock->peerhost}; - if ($@) { - dbg($@) if isdbg('connll'); - $conn->disconnect; - } 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(); - } - } - } else { - dbg("ExtMsg: error on accept ($!)") if isdbg('err'); - } + my $client = shift; + my $conn = $server_conn->SUPER::new_client($client); + # send login prompt + $conn->{state} = 'WL'; + $conn->_send_file("$main::data/issue"); + $conn->send_raw("login: "); + $conn->_dotimeout(60); + $conn->{echo} = 1; } sub start_connect diff --git a/perl/Messages b/perl/Messages index 71218892..78ad3164 100644 --- a/perl/Messages +++ b/perl/Messages @@ -159,7 +159,7 @@ package DXM; isow => '$_[0] is isolated; unset/isolate $_[0] first', join => 'joining group $_[0]', l1 => 'Sorry $_[0], you are already logged on on another channel', - l2 => 'Hello $_[0], this is $main::mycall in $main::myqth\nrunning DXSpider V$main::version build $main::subversion.$main::build', + l2 => 'Hello $_[0], this is $main::mycall in $main::myqth\nrunning DXSpider V$main::version build $main::build', lang => 'Language is now English', lange1 => 'set/language where is one of ($_[0])', lange2 => 'failed to set language on $_[0]', @@ -584,7 +584,7 @@ package DXM; isow => '$_[0] est isolé; utilisez d\'abord unset/isolate $_[0]', join => 'Affiliation au groupe $_[0]', l1 => 'Désolé $_[0], vous êtes déjà connecté sur un autre canal', - l2 => 'Bonjour $_[0], bienvenue sur $main::mycall à $main::myqth\nServeur DXSpider V$main::version ($main::subversion.$main::build)', + l2 => 'Bonjour $_[0], bienvenue sur $main::mycall à $main::myqth\nServeur DXSpider V$main::version ($main::build)', lang => 'Je parle maintenant français', lange1 => 'Syntaxe : set/language , où est à choisir parmi ($_[0])', lange2 => 'Impossible de fixer la langue à $_[0]', @@ -1228,7 +1228,7 @@ package DXM; isow => '$_[0] ist isoliert; unset/isolate $_[0] zuerst', join => 'Trete Gespraechsgruppe $_[0] bei', l1 => 'Sorry $_[0], Du bist bereits auf einem anderen Kanal eingeloggt', - l2 => 'Moin $_[0], hier ist $main::mycall in $main::myqth\nrunning DXSpider V$main::version build $main::subversion.$main::build', + l2 => 'Moin $_[0], hier ist $main::mycall in $main::myqth\nrunning DXSpider V$main::version build $main::build', lang => 'Sprache ist jetzt Deutsch', lange1 => 'set/language wobei ist eine von ($_[0])', lange2 => 'Fehler beim Setzen der Sprache auf $_[0]', @@ -1496,7 +1496,7 @@ package DXM; isoaro => 'c\'e\' una filtro sulla rotta in uscita per $_[0]; eliminala con clear/route $_[0] prima', isow => '$_[0] e\' isolato; unset/isolate $_[0] prima', l1 => 'Spiacente $_[0], sei già collegato sun un altro canale', - l2 => 'Benvenuto $_[0] sul Cluster $main::mycall a $main::myqth\nsoftware in uso DXSpider V$main::version build $main::subversion.$main::build', + l2 => 'Benvenuto $_[0] sul Cluster $main::mycall a $main::myqth\nsoftware in uso DXSpider V$main::version build $main::build', lang => 'La lingua selezionata e\' adesso Italiano', lange1 => 'set/language dove e\' una tra ($_[0])', lange2 => 'impostazione lingua fallita per $_[0]', @@ -1773,7 +1773,7 @@ package DXM; isoaro => 'vystupni route filtr pro $_[0] uz existuje; zadej nejprve clear/route $_[0]', isow => '$_[0] je izolovan; zadej nejprve unset/isolate $_[0]', l1 => 'Lituji $_[0], uz jsi zalogovan na jinem kanalu', - l2 => 'Ahoj $_[0], toto je $main::mycall, $main::myqth\npouzivajici DXSpider V$main::version build $main::subversion.$main::build', + l2 => 'Ahoj $_[0], toto je $main::mycall, $main::myqth\npouzivajici DXSpider V$main::version build $main::build', lang => 'Jazyk je nyni nastaven na Cestinu (napoveda zatim v procesu)', lange1 => 'set/language kde je jedno z ($_[0])', lange2 => 'selhalo nastaveni jazyka na $_[0]', @@ -2068,7 +2068,7 @@ package DXM; isow => '$_[0] est isolado; unset/isolate $_[0] primeiro', join => 'a juntar ao grupo $_[0]', l1 => 'Desculpe $_[0], voc est ligado noutro canal', - l2 => 'Ol $_[0], isto $main::mycall em $main::myqth\nrunning DXSpider V$main::version build $main::subversion.$main::build', + l2 => 'Ol $_[0], isto $main::mycall em $main::myqth\nrunning DXSpider V$main::version build $main::build', lang => 'Linguagem agora o Portugus', lange1 => 'set/language aonde uma de ($_[0])', lange2 => 'falha ao definir uma lngua em $_[0]', diff --git a/perl/Msg.pm b/perl/Msg.pm index 83c82be6..1c86c70d 100644 --- a/perl/Msg.pm +++ b/perl/Msg.pm @@ -14,90 +14,20 @@ use strict; use DXUtil; -use IO::Select; +use Mojo::IOLoop; +use Mojo::IOLoop::Stream; + 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($now %conns $noconns $cnum $total_in $total_out $connect_timeout); -%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; - +$connect_timeout = 5; # #----------------------------------------------------------------- @@ -123,7 +53,7 @@ sub new $noconns++; - dbg("$class Connection $conn->{cnum} created (total $noconns)") if isdbg('connll'); + dbg("$class Connection created (total $noconns)") if isdbg('connll'); return bless $conn, $class; } @@ -131,33 +61,21 @@ sub set_error { my $conn = shift; my $callback = shift; - $conn->{eproc} = $callback; - set_event_handler($conn->{sock}, error => $callback) if exists $conn->{sock}; + $conn->{sock}->on(error => sub {$callback->($conn, $_[1]);}); } -sub set_rproc +sub set_on_eof { my $conn = shift; my $callback = shift; - $conn->{rproc} = $callback; + $conn->{sock}->on(close => sub {$callback->($conn);}); } -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 @@ -203,19 +121,47 @@ sub peerhost { my $conn = shift; $conn->{peerhost} ||= 'ax25' if $conn->ax25; - $conn->{peerhost} ||= $conn->{sock}->peerhost if $conn->{sock} && $conn->{sock}->isa('IO::Socket::INET'); + $conn->{peerhost} ||= $conn->{sock}->handle->peerhost if $conn->{sock}; $conn->{peerhost} ||= 'UNKNOWN'; return $conn->{peerhost}; } #----------------------------------------------------------------- # Send side routines -sub connect { - my ($pkg, $to_host, $to_port, $rproc) = @_; +sub _on_connect +{ + my $conn = shift; + my $handle = shift; + undef $conn->{sock}; + my $sock = $conn->{sock} = Mojo::IOLoop::Stream->new($handle); + $sock->on(read => sub {$conn->_rcv($_[1]);} ); + $sock->on(error => sub {$conn->disconnect;}); + $sock->on(close => sub {$conn->disconnect;}); + $sock->timeout(0); + $sock->start; + $conn->{peerhost} = eval { $handle->peerhost; }; + dbg((ref $conn) . " connected $conn->{cnum} to $conn->{peerhost}:$conn->{peerport}") if isdbg('connll'); + if ($conn->{on_connect}) { + &{$conn->{on_connect}}($conn, $handle); + } +} + +sub is_connected +{ + my $conn = shift; + my $sock = $conn->{sock}; + return ref $sock && $sock->isa('Mojo::IOLoop::Stream'); +} + +sub connect { + my ($pkg, $to_host, $to_port, %args) = @_; + my $timeout = delete $args{timeout} || $connect_timeout; + # Create a connection end-point object my $conn = $pkg; unless (ref $pkg) { + my $rproc = delete $args{rproc}; $conn = $pkg->new($rproc); } $conn->{peerhost} = $to_host; @@ -225,36 +171,18 @@ sub connect { dbg((ref $conn) . " connecting $conn->{cnum} to $to_host:$to_port") if isdbg('connll'); 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 $proto = getprotobyname('tcp'); - $sock->socket(AF_INET, SOCK_STREAM, $proto) or return undef; - - blocking($sock, 0); - $conn->{blocking} = 0; - - # does the host resolve? - my $ip = gethostbyname($to_host); - return undef unless $ip; - - my $r = connect($sock, pack_sockaddr_in($to_port, $ip)); - return undef unless $r || _err_will_block($!); + $conn->{sock} = $sock = Mojo::IOLoop::Client->new; + $sock->on(connect => sub {$conn->_on_connect($_[1])} ); + $sock->on(error => sub {&{$conn->{eproc}}($conn, $_[1]) if exists $conn->{eproc}; $conn->disconnect}); + $sock->on(close => sub {$conn->disconnect}); + + # copy any args like on_connect, on_disconnect etc + while (my ($k, $v) = each %args) { + $conn->{$k} = $v; } - $conn->{sock} = $sock; -# $conn->{peerhost} = $sock->peerhost; # for consistency - - dbg((ref $conn) . " connected $conn->{cnum} to $to_host:$to_port") if isdbg('connll'); - - if ($conn->{rproc}) { - my $callback = sub {$conn->_rcv}; - set_event_handler ($sock, read => $callback); - } + $sock->connect(address => $to_host, port => $to_port, timeout => $timeout); + return $conn; } @@ -263,47 +191,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; } @@ -326,6 +254,10 @@ sub disconnect $call ||= 'unallocated'; dbg((ref $conn) . " Connection $conn->{cnum} $call disconnected") if isdbg('connll'); + if ($conn->{on_disconnect}) { + &{$conn->{on_disconnect}}($conn); + } + # get rid of any references for (keys %$conn) { if (ref($conn->{$_})) { @@ -334,9 +266,7 @@ sub disconnect } if (defined($sock)) { - set_event_handler ($sock, read => undef, write => undef, error => undef); - shutdown($sock, 2); - close($sock); + $sock->close_gracefully; } unless ($main::is_win) { @@ -344,161 +274,84 @@ sub disconnect } } +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->write($data); + $total_out = $lth; + } else { + dbg("_send_stuff $call ending data ignored: $data"); + } + } +} + sub send_now { my ($conn, $msg) = @_; $conn->enqueue($msg); - $conn->_send (1); # 1 ==> flush + _send_stuff($conn); } sub send_later { + goto &send_now; +} + +sub send_raw +{ my ($conn, $msg) = @_; - $conn->enqueue($msg); - my $sock = $conn->{sock}; - return unless defined($sock); - set_event_handler ($sock, write => sub {$conn->_send(0)}); + push @{$conn->{outqueue}}, $msg; + _send_stuff($conn); } sub enqueue { my $conn = shift; - push (@{$conn->{outqueue}}, defined $_[0] ? $_[0] : ''); -} - -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. - -# 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 + push @{$conn->{outqueue}}, defined $_[0] ? $_[0] : ''; } -sub dup_sock +sub _err_will_block { - 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 _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;}); } #----------------------------------------------------------------- # Receive side routines -sub new_server { - @_ == 4 || die "Msg->new_server (myhost, myport, login_proc\n"; - my ($pkg, $my_host, $my_port, $login_proc) = @_; - my $self = $pkg->new($login_proc); +sub new_server +{ +# @_ == 4 || die "Msg->new_server (myhost, myport, login_proc)\n"; + my ($pkg, $my_host, $my_port, $login_proc) = @_; + my $conn = $pkg->new($login_proc); + + my $sock = $conn->{sock} = Mojo::IOLoop::Server->new; + $sock->on(accept=>sub{$conn->new_client($_[1]);}); + $sock->listen(address=>$my_host, port=>$my_port); + $sock->start; - $self->{sock} = $io_socket->new ( - LocalAddr => $my_host, - LocalPort => $my_port, - Listen => SOMAXCONN, - Proto => 'tcp', - Reuse => 1); - die "Could not create socket: $! \n" unless $self->{sock}; - set_event_handler ($self->{sock}, read => sub { $self->new_client } ); - return $self; + die "Could not create socket: $! \n" unless $conn->{sock}; + return $conn; } 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"); - } - } } sub dequeue @@ -522,96 +375,69 @@ sub dequeue sub _rcv { # Complement to _send my $conn = shift; # $rcv_now complement of $flush - # Find out how much has already been received, if at all - my ($msg, $offset, $bytes_to_read, $bytes_read); + my $msg = shift; my $sock = $conn->{sock}; 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; + if (isdbg('raw')) { + my $call = $conn->{call} || 'none'; + my $lth = length $msg; + dbgdump('raw', "$call read $lth: ", $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; } - } + if (defined $out) { + $conn->send_raw($out); + } } else { - if (_err_will_block($!)) { - return ; - } 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(); - if ($sock) { - my $conn = $server_conn->new($server_conn->{rproc}); - $conn->{sock} = $sock; - blocking($sock, 0); - $conn->nolinger; - $conn->{blocking} = 0; - my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost} = $sock->peerhost(), $conn->{peerport} = $sock->peerport()); - $conn->{sort} = 'Incoming'; - 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(); - } - } else { - dbg("Msg: error on accept ($!)") if isdbg('err'); + my $client = shift; + + my $conn = $server_conn->new($server_conn->{rproc}); + my $sock = $conn->{sock} = Mojo::IOLoop::Stream->new($client); + $sock->on(read => sub {$conn->_rcv($_[1])}); + $sock->timeout(0); + $sock->start; + dbg((ref $conn) . "accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}") if isdbg('connll'); + + my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost} = $client->peerhost, $conn->{peerport} = $client->peerport); + $conn->{sort} = 'Incoming'; + if ($eproc) { + $conn->{eproc} = $eproc; + } + if ($rproc) { + $conn->{rproc} = $rproc; + } else { # Login failed + &{$conn->{eproc}}($conn, undef) if exists $conn->{eproc}; + $conn->disconnect(); } + return $conn; } sub close_server { my $conn = shift; - set_event_handler ($conn->{sock}, read => undef, write => undef, error => undef ); - $conn->{sock}->close; + delete $conn->{sock}; } # close all clients (this is for forking really) @@ -625,87 +451,24 @@ 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 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; - } - } + 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 @@ -713,7 +476,7 @@ sub sleep my ($pkg, $interval) = @_; my $now = time; while (time - $now < $interval) { - $pkg->event_loop(10, 0.01); + sleep 1; } } diff --git a/perl/Version.pm b/perl/Version.pm index aef8c26f..c37f7209 100644 --- a/perl/Version.pm +++ b/perl/Version.pm @@ -7,11 +7,11 @@ package main; -use vars qw($version $subversion $build $gitversion); +use vars qw($version $build $gitversion); -$version = '1.55'; +$version = '1.57'; +$build = '4'; $subversion = '0'; -$build = '146'; -$gitversion = '66d98a2'; +$gitversion = '316a74d'; 1; diff --git a/perl/cluster.pl b/perl/cluster.pl index 5c3f0fb9..39c65c02 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -52,6 +52,8 @@ BEGIN { $systime = time; } +use Mojo::IOLoop; + 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,6 +138,7 @@ $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 @@ -273,7 +276,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 +290,6 @@ sub cease UDPMsg::finish(); # end everything else - Msg->event_loop(100, 0.01); DXUser::finish(); DXDupe::finish(); @@ -300,7 +301,8 @@ sub cease $l->close_server; } - LogDbg('cluster', "DXSpider V$version, build $subversion.$build (git: $gitversion) ended"); + LogDbg('cluster', "DXSpider V$version, build $build (git: $gitversion) ended"); + dbg("bye bye everyone - bye bye"); dbgclose(); Logclose(); @@ -342,6 +344,60 @@ 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(); + $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 @@ -389,7 +445,7 @@ DXXml::init(); # banner my ($year) = (gmtime)[5]; $year += 1900; -LogDbg('cluster', "DXSpider V$version, build $subversion.$build (git: $gitversion) started"); +LogDbg('cluster', "DXSpider V$version, build $build (git: $gitversion) started"); dbg("Copyright (c) 1998-$year Dirk Koopman G1TLH"); # load Prefixes @@ -446,7 +502,7 @@ dbg("load badwords: " . (BadWords::load or "Ok")); # prime some signals unless ($DB::VERSION) { - $SIG{INT} = $SIG{TERM} = sub { $decease = 1 }; + $SIG{INT} = $SIG{TERM} = sub { Mojo::IOLoop->stop; }; } unless ($is_win) { @@ -535,49 +591,10 @@ $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(); +my $main_loop = Mojo::IOLoop->recurring($idle_interval => \&idle_loop); -# $DB::trace = 0; +Mojo::IOLoop->start unless Mojo::IOLoop->is_running; - # 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(); - - if (defined &Local::process) { - eval { - Local::process(); # do any localised processing - }; - dbg("Local::process error $@") if $@; - } - } - if ($decease) { - last if --$decease <= 0; - } -} cease(0); exit(0); diff --git a/perl/console.pl b/perl/console.pl index 0a6d7404..56394888 100755 --- a/perl/console.pl +++ b/perl/console.pl @@ -26,6 +26,8 @@ BEGIN { $is_win = ($^O =~ /^MS/ || $^O =~ /^OS-2/) ? 1 : 0; # is it Windows? } +use Mojo::IOLoop; + use Msg; use IntMsg; use DXVars; @@ -54,6 +56,9 @@ $khistpos = 0; $spos = $pos = $lth = 0; $inbuf = ""; @time = (); +$lastmin = 0; +$idle = 0; + #$SIG{WINCH} = sub {@time = gettimeofday}; @@ -443,6 +448,46 @@ 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) { + next; + } + if (defined $ch) { + if ($ch ne '-1') { + rec_stdin($ch); + } + } + $top->refresh() if $top->is_wintouched; + $bot->refresh(); +} + +sub on_connect +{ + my $conn = shift; + $conn->send_later("A$call|$connsort width=$cols"); + $conn->send_later("I$call|set/page $maxshist"); + #$conn->send_later("I$call|set/nobeep"); +} + +sub on_disconnect +{ + $conn = shift; + Mojo::IOLoop->remove($idle); + Mojo::IOLoop->stop; +} # # deal with args @@ -464,23 +509,6 @@ if ($call eq $mycall) { dbginit(); -$conn = IntMsg->connect("$clusteraddr", $clusterport, \&rec_socket); -if (! $conn) { - if (-r "$data/offline") { - open IN, "$data/offline" or die; - while () { - print $_; - } - close IN; - } else { - print "Sorry, the cluster $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; @@ -493,40 +521,17 @@ do_resize(); $SIG{__DIE__} = \&sig_term; -$conn->send_later("A$call|$connsort width=$cols"); -$conn->send_later("I$call|set/page $maxshist"); -#$conn->send_later("I$call|set/nobeep"); - -#Msg->set_event_handler(\*STDIN, "read" => \&rec_stdin); - $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(); -} -exit(0); + +$conn = IntMsg->connect($clusteraddr, $clusterport, rproc => \&rec_socket); +$conn->{on_connect} = \&on_connect; +$conn->{on_disconnect} = \&on_disconnect; + +$idle = Mojo::IOLoop->recurring(0.100 => \&idle_loop); +Mojo::IOLoop->start; + + +cease(0); diff --git a/perl/issue.pl b/perl/issue.pl index 065c9abd..ea0c083f 100755 --- a/perl/issue.pl +++ b/perl/issue.pl @@ -20,7 +20,6 @@ use vars qw($root); my $fn = "$root/perl/Version.pm"; my $desc = `git describe --long`; my ($v, $s, $b, $g) = $desc =~ /^([\d.]+)(?:\.(\d+))?-(\d+)-g([0-9a-f]+)/; -$s ||= '0'; # account for missing subversion $b++; # to account for the commit that is about to happen open F, ">$fn" or die "issue.pl: can't open $fn $!\n"; @@ -33,10 +32,9 @@ print F qq(# package main; -use vars qw(\$version \$subversion \$build \$gitversion); +use vars qw(\$version \$build \$gitversion); \$version = '$v'; -\$subversion = '$s'; \$build = '$b'; \$gitversion = '$g';