X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXChannel.pm;h=91900e4b3c8a360118e25075993ba8387cd20a18;hb=7f38719941b040ae64358fece992179c5938d609;hp=7d340a6165f5cfde293b725b28efea2edf9c95b7;hpb=2c50f9b4b2b3f29b000d77623a9d7c3748933aef;p=spider.git

diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm
index 7d340a61..91900e4b 100644
--- a/perl/DXChannel.pm
+++ b/perl/DXChannel.pm
@@ -19,7 +19,7 @@
 # firstly and OO about ninthly (if you don't like the design and you can't 
 # improve it with better OO and thus make it smaller and more efficient, then tough). 
 #
-# Copyright (c) 1998-2000 - Dirk Koopman G1TLH
+# Copyright (c) 1998-2016 - Dirk Koopman G1TLH
 #
 #
 #
@@ -35,7 +35,7 @@ use Prefix;
 use Route;
 
 use strict;
-use vars qw(%channels %valid @ISA $count);
+use vars qw(%channels %valid @ISA $count $maxerrors);
 
 %channels = ();
 $count = 0;
@@ -80,11 +80,13 @@ $count = 0;
 		  wcyfilter => '5,WCY Filt-out',
 		  spotsfilter => '5,Spot Filt-out',
 		  routefilter => '5,Route Filt-out',
+		  pc92filter => '5,PC92 Route Filt-out',
 		  inannfilter => '5,Ann Filt-inp',
 		  inwwvfilter => '5,WWV Filt-inp',
 		  inwcyfilter => '5,WCY Filt-inp',
 		  inspotsfilter => '5,Spot Filt-inp',
 		  inroutefilter => '5,Route Filt-inp',
+		  inpc92filter => '5,PC92 Route Filt-inp',
 		  passwd => '9,Passwd List,yesno',
 		  pingint => '5,Ping Interval ',
 		  nopings => '5,Ping Obs Count',
@@ -125,6 +127,8 @@ $count = 0;
 		  next_pc92_keepalive => '9,Next PC92 KeepAlive,atime',
 		 );
 
+$maxerrors = 20;				# the maximum number of concurrent errors allowed before disconnection
+
 # object destruction
 sub DESTROY
 {
@@ -167,7 +171,7 @@ sub alloc
 	if (@dxcc > 0) {
 		$self->{dxcc} = $dxcc[1]->dxcc;
 		$self->{itu} = $dxcc[1]->itu;
-		$self->{cq} = $dxcc[1]->cq;						
+		$self->{cq} = $dxcc[1]->cq;
 	}
 	$self->{inqueue} = [];
 
@@ -177,6 +181,22 @@ sub alloc
 	return $channels{$call} = $self;
 }
 
+# count errors and disconnect if too many
+# this has to be here because it can come from rcmd (DXProt) as
+# well as DXCommandmode.
+sub _error_out
+{
+	my $self = shift;
+	my $e = shift;
+	if (++$self->{errors} > $maxerrors) {
+		$self->send($self->msg('e26'));
+		$self->disconnect;
+		return ();
+	} else {
+		return ($self->msg($e));
+	}
+}
+
 # rebless this channel as something else
 sub rebless
 {
@@ -193,6 +213,7 @@ sub rec
 	if (defined $msg) {
 		push @{$self->{inqueue}}, $msg;
 	}
+	$self->process_one;
 }
 
 # obtain a channel object by callsign [$obj = DXChannel::get($call)]
@@ -221,6 +242,17 @@ sub get_all_nodes
 	return @out;
 }
 
+# return a list of node calls
+sub get_all_node_calls
+{
+	my $ref;
+	my @out;
+	foreach $ref (values %channels) {
+		push @out, $ref->{call} if $ref->is_node;
+	}
+	return @out;
+}
+
 # return a list of all users
 sub get_all_users
 {
@@ -555,7 +587,7 @@ sub decode_input
 {
 	my $dxchan = shift;
 	my $data = shift;
-	my ($sort, $call, $line) = $data =~ /^([A-Z])([A-Z0-9\-]{3,9})\|(.*)$/;
+	my ($sort, $call, $line) = $data =~ /^([A-Z])([A-Z0-9\/\-]{3,25})\|(.*)$/;
 
 	my $chcall = (ref $dxchan) ? $dxchan->call : "UN.KNOWN";
 	
@@ -665,43 +697,46 @@ sub broadcast_list
 	}
 }
 
-sub process
+sub process_one
 {
-	foreach my $dxchan (get_all()) {
-
-		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;
-			}
+	my $self = shift;
 
-			# 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;
+	while (my $data = shift @{$self->{inqueue}}) {
+		my ($sort, $call, $line) = $self->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');
+		
+		# handle A records
+		my $user = $self->user;
+		if ($sort eq 'I') {
+			die "\$user not defined for $call" unless defined $user;
 			
-				# normal input
-				$dxchan->normal($line);
-			} 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";
-			}
+			# normal input
+			$self->normal($line);
+		} elsif ($sort eq 'G') {
+			$self->enhanced($line);
+		} elsif ($sort eq 'A' || $sort eq 'O') {
+			$self->start($line, $sort);
+		} elsif ($sort eq 'Z') {
+			$self->disconnect;
+		} elsif ($sort eq 'D') {
+			;				# ignored (an echo)
+		} else {
+			dbg atime . " DXChannel::process_one: Unknown command letter ($sort) received from $call\n";
 		}
 	}
 }
 
+sub process
+{
+	foreach my $dxchan (values %channels) {
+		next if $dxchan->{disconnecting};
+		$dxchan->process_one;
+	}
+}
+
 sub handle_xml
 {
 	my $self = shift;
@@ -715,6 +750,16 @@ sub handle_xml
 	return $r;
 }
 
+sub error_handler
+{
+	my $self = shift;
+	my $error = shift || '';
+	dbg("$self->{call} ERROR '$error', closing") if isdbg('chan');
+	$self->{conn}->set_error(undef) if exists $self->{conn};
+	$self->disconnect(1);
+}
+
+
 #no strict;
 sub AUTOLOAD
 {