From 393e17fd3a08dd94596f1c02d4d20f6f9a44954f Mon Sep 17 00:00:00 2001 From: minima Date: Sat, 19 Feb 2005 02:26:27 +0000 Subject: [PATCH] added mkver added more pc16/17 code --- perl/AMsg.pm | 6 +- perl/Aranea.pm | 6 +- perl/DXProt.pm | 6 +- perl/Route.pm | 6 +- perl/Route/Node.pm | 6 +- perl/RouteDB.pm | 6 +- perl/Spot.pm | 6 +- perl/Thingy.pm | 6 +- perl/Thingy/Dx.pm | 6 +- perl/Thingy/Rt.pm | 18 +-- perl/cluster.pl | 386 +++++++++++++++++++++++---------------------- 11 files changed, 217 insertions(+), 241 deletions(-) diff --git a/perl/AMsg.pm b/perl/AMsg.pm index 0b94c15d..15596a98 100644 --- a/perl/AMsg.pm +++ b/perl/AMsg.pm @@ -22,10 +22,8 @@ use Thingy; use Thingy::Hello; use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /^\d+\.\d+(?:\.(\d+)\.(\d+))?$/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; + +main::mkver($VERSION = q$Revision$); use vars qw(@ISA $deftimeout); diff --git a/perl/Aranea.pm b/perl/Aranea.pm index fc77cc13..bbe24bbd 100644 --- a/perl/Aranea.pm +++ b/perl/Aranea.pm @@ -28,10 +28,8 @@ use Thingy; use RouteDB; use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /^\d+\.\d+(?:\.(\d+)\.(\d+))?$/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; + +main::mkver($VERSION = q$Revision$); use vars qw(@ISA $ntpflag $dupeage); diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 89f8f9d5..05111d40 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -44,10 +44,8 @@ use Thingy::T; use strict; use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /^\d+\.\d+(?:\.(\d+)\.(\d+))?$/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; + +main::mkver($VERSION = q$Revision$); use vars qw($pc11_max_age $pc23_max_age $last_pc50 $eph_restime $eph_info_restime $eph_pc34_restime $last_hour $last10 %eph %pings %rcmds $ann_to_talk diff --git a/perl/Route.pm b/perl/Route.pm index b4e11b4d..62631900 100644 --- a/perl/Route.pm +++ b/perl/Route.pm @@ -22,10 +22,8 @@ use strict; use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; + +main::mkver($VERSION = q$Revision$); use vars qw(%list %valid $filterdef); diff --git a/perl/Route/Node.pm b/perl/Route/Node.pm index 3c4addd0..5858ddcc 100644 --- a/perl/Route/Node.pm +++ b/perl/Route/Node.pm @@ -15,10 +15,8 @@ use Route::User; use strict; use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; + +main::mkver($VERSION = q$Revision$); use vars qw(%list %valid @ISA $max $filterdef); @ISA = qw(Route); diff --git a/perl/RouteDB.pm b/perl/RouteDB.pm index 42cf693f..83f8119e 100644 --- a/perl/RouteDB.pm +++ b/perl/RouteDB.pm @@ -25,10 +25,8 @@ use Prefix; use strict; use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; + +main::mkver($VERSION = q$Revision$); use vars qw(%list %valid $default); diff --git a/perl/Spot.pm b/perl/Spot.pm index d7c990d1..ef8d9ccd 100644 --- a/perl/Spot.pm +++ b/perl/Spot.pm @@ -22,10 +22,8 @@ use QSL; use strict; use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /^\d+\.\d+(?:\.(\d+)\.(\d+))?$/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; + +main::mkver($VERSION = q$Revision$); use vars qw($fp $statp $maxspots $defaultspots $maxdays $dirprefix $duplth $dupage $filterdef $totalspots $hfspots $vhfspots ); diff --git a/perl/Thingy.pm b/perl/Thingy.pm index c91edc0c..7bbf3edb 100644 --- a/perl/Thingy.pm +++ b/perl/Thingy.pm @@ -16,10 +16,8 @@ use strict; package Thingy; use vars qw($VERSION $BRANCH @queue @permin @persec); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /^\d+\.\d+(?:\.(\d+)\.(\d+))?$/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; + +main::mkver($VERSION = q$Revision$); @queue = (); # the input / processing queue diff --git a/perl/Thingy/Dx.pm b/perl/Thingy/Dx.pm index a74e8e9f..c4d969a0 100644 --- a/perl/Thingy/Dx.pm +++ b/perl/Thingy/Dx.pm @@ -11,10 +11,8 @@ use strict; package Thingy::Dx; use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /^\d+\.\d+(?:\.(\d+)\.(\d+))?$/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; + +main::mkver($VERSION = q$Revision$); use DXChannel; use DXDebug; diff --git a/perl/Thingy/Rt.pm b/perl/Thingy/Rt.pm index eb20fcab..bd5fd95d 100644 --- a/perl/Thingy/Rt.pm +++ b/perl/Thingy/Rt.pm @@ -11,10 +11,8 @@ use strict; package Thingy::Rt; use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /^\d+\.\d+(?:\.(\d+)\.(\d+))?$/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; + +main::mkver($VERSION = q$Revision$); use DXChannel; use DXDebug; @@ -91,9 +89,9 @@ sub handle_eau my $dxchan = shift; if (my $d = $thing->{d}) { + my $nref; for (split /:/, $d) { my ($type, $here, $call) = unpack "A1 A1 A*", $_; - my $nref; if ($type eq 'U') { unless ($nref) { dbg("Thingy::Rt::ea need a node before $call"); @@ -114,10 +112,6 @@ sub handle_eau dbg("Thingy::Rt::ea invalid type $type"); return; } - unless ($nref) { - dbg("Thingy::Rt::ea no node"); - return; - } } } return $thing; @@ -129,9 +123,9 @@ sub handle_edu my $dxchan = shift; if (my $d = $thing->{d}) { + my $nref; for (split /:/, $d) { my ($type, $here, $call) = unpack "A1 A1 A*", $_; - my $nref; if ($type eq 'U') { unless ($nref) { dbg("Thingy::Rt::ed need a node before $call"); @@ -150,10 +144,6 @@ sub handle_edu dbg("Thingy::Rt::ed invalid type $type"); return; } - unless ($nref) { - dbg("Thingy::Rt::ed no node"); - return; - } } } return $thing; diff --git a/perl/cluster.pl b/perl/cluster.pl index 6178aa49..d2d9dc60 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -47,6 +47,14 @@ BEGIN { $is_win = ($^O =~ /^MS/ || $^O =~ /^OS-2/) ? 1 : 0; # is it Windows? $systime = time; + + sub main::mkver + { + my $s = shift; + my ($v, $b) = $s =~ /(\d+\.\d+)(?:\.(\d+\.\d+))?/; + $main::build += sprintf "%.3f", $v; + $main::branch += sprintf("%.3f", $b) if $b; + } } use DXVars; @@ -131,197 +139,8 @@ $allowdxby = 0; # 1 = allow "dx by ", 0 - don't allow it use vars qw($VERSION $BRANCH $build $branch); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /^\d+\.\d+(?:\.(\d+)\.(\d+))?$/ || (0,0)); -$main::build += 1; # add an offset to make it bigger than last system -$main::build += $VERSION; -$main::branch += $BRANCH; - - -# 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->send_now("D$call|$mess"); - sleep(2); - $conn->disconnect; -} - -sub error_handler -{ - my $dxchan = shift; - $dxchan->{conn}->set_error(undef) if exists $dxchan->{conn}; - $dxchan->disconnect(1); -} - -# handle incoming messages -sub new_channel -{ - my ($conn, $msg) = @_; - my ($sort, $call, $line) = DXChannel::decode_input(0, $msg); - return unless defined $sort; - - unless (is_callsign($call)) { - already_conn($conn, $call, DXM::msg($lang, "illcall", $call)); - return; - } - - # set up the basic channel info - # is there one already connected to me - locally? - my $user = DXUser->get_current($call); - my $dxchan = DXChannel->get($call); - if ($dxchan) { - if ($user && $user->is_node) { - already_conn($conn, $call, DXM::msg($lang, 'concluster', $call, $main::mycall)); - return; - } - if ($bumpexisting && $call ne $main::mycall) { - my $ip = $conn->{peerhost} || 'unknown'; - $dxchan->send_now('D', DXM::msg($lang, 'conbump', $call, $ip)); - Log('DXCommand', "$call bumped off by $ip, disconnected"); - dbg("$call bumped off by $ip, disconnected"); - $dxchan->disconnect; - } else { - already_conn($conn, $call, DXM::msg($lang, 'conother', $call, $main::mycall)); - return; - } - } - - # is he locked out ? - my $basecall = $call; - $basecall =~ s/-\d+$//; - my $baseuser = DXUser->get_current($basecall); - my $lock = $user->lockout if $user; - if ($baseuser && $baseuser->lockout || $lock) { - if (!$user || !defined $lock || $lock) { - my $host = $conn->{peerhost} || "unknown"; - Log('DXCommand', "$call on $host is locked out, disconnected"); - $conn->disconnect; - return; - } - } - - if ($user) { - $user->{lang} = $main::lang if !$user->{lang}; # to autoupdate old systems - } else { - $user = DXUser->new($call); - } - - # create the channel - if ($user->is_node) { - $dxchan = DXProt->new($call, $conn, $user); - } elsif ($user->is_user) { - $dxchan = DXCommandmode->new($call, $conn, $user); - } elsif ($user->is_bbs) { - $dxchan = BBS->new($call, $conn, $user); - } else { - die "Invalid sort of user on $call = $sort"; - } - - # check that the conn has a callsign - $conn->conns($call) if $conn->isa('IntMsg'); - - # set callbacks - $conn->set_error(sub {error_handler($dxchan)}); - $conn->set_rproc(sub {my ($conn,$msg) = @_; $dxchan->rec($msg);}); - $dxchan->rec($msg); -} - - -sub login -{ - return \&new_channel; -} - -# cease running this program, close down all the connections nicely -sub cease -{ - my $dxchan; - - unless ($is_win) { - $SIG{'TERM'} = 'IGNORE'; - $SIG{'INT'} = 'IGNORE'; - } - - DXUser::sync; - - eval { - Local::finish(); # end local processing - }; - dbg("Local::finish error $@") if $@; - - # disconnect nodes - 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) { - $dxchan->disconnect; - } - - # disconnect AGW - AGWMsg::finish(); - - # disconnect UDP customers - UDPMsg::finish(); - - # end everything else - Msg->event_loop(100, 0.01); - DXUser::finish(); - DXDupe::finish(); - # close all databases - DXDb::closeall; - - # close all listeners - foreach my $l (@listeners) { - $l->close_server; - } - - dbg("DXSpider version $version, build $build ended") if isdbg('chan'); - Log('cluster', "DXSpider V$version, build $build ended"); - dbgclose(); - Logclose(); - unlink $lockfn; -# $SIG{__WARN__} = $SIG{__DIE__} = sub {my $a = shift; cluck($a); }; - exit(0); -} - -# the reaper of children -sub reap -{ - my $cpid; - while (($cpid = waitpid(-1, WNOHANG)) > 0) { - dbg("cpid: $cpid") if isdbg('reap'); -# Msg->pid_gone($cpid); - $zombies-- if $zombies > 0; - } - dbg("cpid: $cpid") if isdbg('reap'); -} - -# this is where the input queue is dealt with and things are dispatched off to other parts of -# the cluster - -sub uptime -{ - my $t = $systime - $starttime; - my $days = int $t / 86400; - $t -= $days * 86400; - my $hours = int $t / 3600; - $t -= $hours * 3600; - my $mins = int $t / 60; - return sprintf "%d %02d:%02d", $days, $hours, $mins; -} - -sub AGWrestart -{ - AGWMsg::init(\&new_channel); -} +mkver($VERSION = q$Revision$); ############################################################# # @@ -498,7 +317,7 @@ for (;;) { # do timed stuff, ongoing processing happens one a second if ($timenow != $systime) { rand(); # keep randomising to reduce (but not eliminate) predictability - reap if $zombies; + reap() if $zombies; $systime = $timenow; DXCron::process(); # do cron jobs DXCommandmode::process(); # process ongoing command mode stuff @@ -523,4 +342,189 @@ for (;;) { cease(0); exit(0); + +# 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->send_now("D$call|$mess"); + sleep(2); + $conn->disconnect; +} + +sub error_handler +{ + my $dxchan = shift; + $dxchan->{conn}->set_error(undef) if exists $dxchan->{conn}; + $dxchan->disconnect(1); +} + +# handle incoming messages +sub new_channel +{ + my ($conn, $msg) = @_; + my ($sort, $call, $line) = DXChannel::decode_input(0, $msg); + return unless defined $sort; + + unless (is_callsign($call)) { + already_conn($conn, $call, DXM::msg($lang, "illcall", $call)); + return; + } + + # set up the basic channel info + # is there one already connected to me - locally? + my $user = DXUser->get_current($call); + my $dxchan = DXChannel->get($call); + if ($dxchan) { + if ($user && $user->is_node) { + already_conn($conn, $call, DXM::msg($lang, 'concluster', $call, $main::mycall)); + return; + } + if ($bumpexisting && $call ne $main::mycall) { + my $ip = $conn->{peerhost} || 'unknown'; + $dxchan->send_now('D', DXM::msg($lang, 'conbump', $call, $ip)); + Log('DXCommand', "$call bumped off by $ip, disconnected"); + dbg("$call bumped off by $ip, disconnected"); + $dxchan->disconnect; + } else { + already_conn($conn, $call, DXM::msg($lang, 'conother', $call, $main::mycall)); + return; + } + } + + # is he locked out ? + my $basecall = $call; + $basecall =~ s/-\d+$//; + my $baseuser = DXUser->get_current($basecall); + my $lock = $user->lockout if $user; + if ($baseuser && $baseuser->lockout || $lock) { + if (!$user || !defined $lock || $lock) { + my $host = $conn->{peerhost} || "unknown"; + Log('DXCommand', "$call on $host is locked out, disconnected"); + $conn->disconnect; + return; + } + } + + if ($user) { + $user->{lang} = $main::lang if !$user->{lang}; # to autoupdate old systems + } else { + $user = DXUser->new($call); + } + + # create the channel + if ($user->is_node) { + $dxchan = DXProt->new($call, $conn, $user); + } elsif ($user->is_user) { + $dxchan = DXCommandmode->new($call, $conn, $user); + } elsif ($user->is_bbs) { + $dxchan = BBS->new($call, $conn, $user); + } else { + die "Invalid sort of user on $call = $sort"; + } + + # check that the conn has a callsign + $conn->conns($call) if $conn->isa('IntMsg'); + + # set callbacks + $conn->set_error(sub {error_handler($dxchan)}); + $conn->set_rproc(sub {my ($conn,$msg) = @_; $dxchan->rec($msg);}); + $dxchan->rec($msg); +} + + +sub login +{ + return \&new_channel; +} + +# cease running this program, close down all the connections nicely +sub cease +{ + my $dxchan; + + unless ($is_win) { + $SIG{'TERM'} = 'IGNORE'; + $SIG{'INT'} = 'IGNORE'; + } + + DXUser::sync; + + eval { + Local::finish(); # end local processing + }; + dbg("Local::finish error $@") if $@; + + # disconnect nodes + 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) { + $dxchan->disconnect; + } + + # disconnect AGW + AGWMsg::finish(); + + # disconnect UDP customers + UDPMsg::finish(); + + # end everything else + Msg->event_loop(100, 0.01); + DXUser::finish(); + DXDupe::finish(); + + # close all databases + DXDb::closeall; + + # close all listeners + foreach my $l (@listeners) { + $l->close_server; + } + + dbg("DXSpider version $version, build $build ended") if isdbg('chan'); + Log('cluster', "DXSpider V$version, build $build ended"); + dbgclose(); + Logclose(); + unlink $lockfn; +# $SIG{__WARN__} = $SIG{__DIE__} = sub {my $a = shift; cluck($a); }; + exit(0); +} + +# the reaper of children +sub reap +{ + my $cpid; + while (($cpid = waitpid(-1, WNOHANG)) > 0) { + dbg("cpid: $cpid") if isdbg('reap'); +# Msg->pid_gone($cpid); + $zombies-- if $zombies > 0; + } + dbg("cpid: $cpid") if isdbg('reap'); +} + +# this is where the input queue is dealt with and things are dispatched off to other parts of +# the cluster + +sub uptime +{ + my $t = $systime - $starttime; + my $days = int $t / 86400; + $t -= $days * 86400; + my $hours = int $t / 3600; + $t -= $hours * 3600; + my $mins = int $t / 60; + return sprintf "%d %02d:%02d", $days, $hours, $mins; +} + +sub AGWrestart +{ + AGWMsg::init(\&new_channel); +} -- 2.34.1