From: Dirk Koopman Date: Fri, 13 Sep 2013 23:06:45 +0000 (+0100) Subject: start of mojo conversion X-Git-Tag: 1.57^0 X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=commitdiff_plain;h=06a6935d583a684869129350fed170d467ad8acc;p=spider.git start of mojo conversion --- diff --git a/perl/Msg.pm b/perl/Msg.pm index 83c82be6..d62cb744 100644 --- a/perl/Msg.pm +++ b/perl/Msg.pm @@ -14,88 +14,18 @@ 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); -%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; @@ -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 {my ($stream, $err) = @_; $callback->($conn, $err);}); } -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,7 +121,7 @@ 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}; } @@ -225,35 +143,17 @@ 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 { dbg((ref $conn) . " connected $conn->{cnum} to $to_host:$to_port") if isdbg('connll');}, + error => {$conn->disconnect}, + close => {$conn->disconnect}); + + $sock->connect(address => $to_host, port => $to_port); - $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->on(read => sub {my ($stream, $msg) = @_; $conn->_rcv($msg);} ); } return $conn; } @@ -263,47 +163,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; } @@ -334,9 +234,7 @@ sub disconnect } if (defined($sock)) { - set_event_handler ($sock, read => undef, write => undef, error => undef); - shutdown($sock, 2); - close($sock); + $sock->remove; } unless ($main::is_win) { @@ -344,161 +242,76 @@ 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->destroyed) { + $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 { - my ($conn, $msg) = @_; - $conn->enqueue($msg); - my $sock = $conn->{sock}; - return unless defined($sock); - set_event_handler ($sock, write => sub {$conn->_send(0)}); + goto &send_now; } sub enqueue { my $conn = shift; - push (@{$conn->{outqueue}}, defined $_[0] ? $_[0] : ''); + 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 -} - -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); - $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; + $conn->{sock} = Mojo::IOLoop::Server->new; + $conn->{sock}->on(accept=>sub{$conn->new_client()}); + $conn->{sock}->listen(address=>$my_host, port=>$my_port); + + 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 @@ -581,37 +394,30 @@ FINISH: 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])}); + 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(); } } 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 +431,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 +456,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 2e4836cf..a9a4d35d 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.57'; $subversion = '0'; -$build = '136'; -$gitversion = '725d28d'; +$build = '1'; +$gitversion = 'e399440'; 1; diff --git a/perl/cluster.pl b/perl/cluster.pl index 5c3f0fb9..a3e915a6 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(); @@ -301,6 +302,7 @@ sub cease } LogDbg('cluster', "DXSpider V$version, build $subversion.$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 @@ -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,8 @@ $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; +Mojo::IOLoop->start; - # 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);