X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2Fcluster.pl;h=3596fa00432169199ff9dbcf55121c79c00d4ea7;hb=f9b0d39eb17d107b9f2b0c6c08652ea02c1d74ce;hp=572be7a9d6cdae83abe7a0ced707773ff692096d;hpb=6624dcdf07d628e8d6a16fc6549edf40be25b7b2;p=spider.git

diff --git a/perl/cluster.pl b/perl/cluster.pl
index 572be7a9..3596fa00 100755
--- a/perl/cluster.pl
+++ b/perl/cluster.pl
@@ -67,6 +67,7 @@ use DXBearing;
 use DXDb;
 use DXHash;
 use DXDupe;
+use Script;
 use Prefix;
 use Spot;
 use Bands;
@@ -97,7 +98,7 @@ package main;
 use strict;
 use vars qw(@inqueue $systime $version $starttime $lockfn @outstanding_connects 
 			$zombies $root @listeners $lang $myalias @debug $userfn $clusteraddr 
-			$clusterport $mycall $decease $build $is_win $routeroot 
+			$clusterport $mycall $decease $is_win $routeroot 
 		   );
 
 @inqueue = ();					# the main input queue, an array of hashes
@@ -107,6 +108,13 @@ $starttime = 0;                 # the starting time of the cluster
 #@outstanding_connects = ();     # list of outstanding connects
 @listeners = ();				# list of listeners
 
+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;
+$main::build += 14;				# 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
@@ -133,7 +141,12 @@ 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($call);
@@ -143,6 +156,20 @@ sub new_channel
 		already_conn($conn, $call, $mess);
 		return;
 	}
+
+	# is he locked out ?
+	my $basecall = $call;
+	$basecall =~ s/-\d+$//;
+	my $baseuser = DXUser->get($basecall);
+	if ($baseuser && $baseuser->lockout) {
+		my $lock = $user->lockout if $user;
+		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
@@ -150,12 +177,6 @@ sub new_channel
 		$user = DXUser->new($call);
 	}
 	
-	# is he locked out ?
-	if ($user->lockout) {
-		Log('DXCommand', "$call is locked out, disconnected");
-		$conn->disconnect;
-		return;
-	}
 
 	# create the channel
 	$dxchan = DXCommandmode->new($call, $conn, $user) if $user->is_user;
@@ -259,35 +280,37 @@ sub reap
 # the cluster
 sub process_inqueue
 {
-	my $self = shift @inqueue;
-	return if !$self;
+	while (@inqueue) {
+		my $self = shift @inqueue;
+		return if !$self;
 	
-	my $data = $self->{data};
-	my $dxchan = $self->{dxchan};
-	my $error;
-	my ($sort, $call, $line) = DXChannel::decode_input($dxchan, $data);
-	return unless defined $sort;
+		my $data = $self->{data};
+		my $dxchan = $self->{dxchan};
+		my $error;
+		my ($sort, $call, $line) = DXChannel::decode_input($dxchan, $data);
+		return unless defined $sort;
 	
-	# do the really sexy console interface bit! (Who is going to do the TK interface then?)
-	dbg("<- $sort $call $line\n") if $sort ne 'D' && isdbg('chan');
-
-	# handle A records
-	my $user = $dxchan->user;
-	if ($sort eq 'A' || $sort eq 'O') {
-		$dxchan->start($line, $sort);  
-	} elsif ($sort eq 'I') {
-		die "\$user not defined for $call" if !defined $user;
-		# normal input
-		$dxchan->normal($line);
-		$dxchan->disconnect if ($dxchan->{state} eq 'bye');
-	} elsif ($sort eq 'Z') {
-		$dxchan->disconnect;
-	} elsif ($sort eq 'D') {
-		;                       # ignored (an echo)
-	} elsif ($sort eq 'G') {
-		$dxchan->enhanced($line);
-	} else {
-		print STDERR atime, " Unknown command letter ($sort) received from $call\n";
+		# do the really sexy console interface bit! (Who is going to do the TK interface then?)
+		dbg("<- $sort $call $line\n") if $sort ne 'D' && isdbg('chan');
+
+		# handle A records
+		my $user = $dxchan->user;
+		if ($sort eq 'A' || $sort eq 'O') {
+			$dxchan->start($line, $sort);  
+		} elsif ($sort eq 'I') {
+			die "\$user not defined for $call" if !defined $user;
+			# normal input
+			$dxchan->normal($line);
+			$dxchan->disconnect if ($dxchan->{state} eq 'bye');
+		} elsif ($sort eq 'Z') {
+			$dxchan->disconnect;
+		} elsif ($sort eq 'D') {
+			;					# ignored (an echo)
+		} elsif ($sort eq 'G') {
+			$dxchan->enhanced($line);
+		} else {
+			print STDERR atime, " Unknown command letter ($sort) received from $call\n";
+		}
 	}
 }
 
@@ -324,29 +347,8 @@ foreach (@debug) {
 STDOUT->autoflush(1);
 
 # calculate build number
-$build = $main::version;
-
-my @fn;
-open(CL, "$main::root/perl/cluster.pl") or die "Cannot open cluster.pl $!";
-while (<CL>) {
-	next unless /^use\s+([\w:_]+)/;
-	push @fn, $1;
-}
-close CL;
-my $subbuild;
-foreach my $fn (@fn) {
-	$fn =~ s|::|/|g;
-	open(CL, "$main::root/perl/${fn}.pm") or next;
-	while (<CL>) {
-		if (/^#\s+\$Id:\s+[\w\._]+,v\s+(\d+\.\d+)\.?(\d+.\d+)?/ ) {
-			$build += $1;
-			$subbuild += $2 if $2;
-			last;
-		}
-	}
-	close CL;
-}
-$build = "$build.$subbuild" if $subbuild;
+$build += $main::version;
+$build = "$build.$branch" if $branch;
 
 Log('cluster', "DXSpider V$version, build $build started");
 
@@ -455,11 +457,16 @@ eval {
 };
 dbg("Local::init error $@") if $@;
 
+dbg("cleaning out old debug files");
+DXDebug::dbgclean();
+
 # print various flags
 #dbg("seful info - \$^D: $^D \$^W: $^W \$^S: $^S \$^P: $^P");
 
 # this, such as it is, is the main loop!
 dbg("orft we jolly well go ...");
+my $script = new Script "startup";
+$script->run($DXProt::me) if $script;
 
 #open(DB::OUT, "|tee /tmp/aa");