X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXCommandmode.pm;h=3eb351951c628c705b6c6d0a79cb57323809e0ac;hb=ec2bc54f842a3b684ce9375511f4ab2098717fe1;hp=691e29b2d6b3fa928933a878ec07221b579957da;hpb=11d4503c67235600af279b57b785e5657faaf63c;p=spider.git

diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm
index 691e29b2..3eb35195 100644
--- a/perl/DXCommandmode.pm
+++ b/perl/DXCommandmode.pm
@@ -32,14 +32,14 @@ use WCY;
 use Sun;
 use Internet;
 use Script;
-use Net::Telnet;
 use QSL;
 use DB_File;
 use VE7CC;
 use DXXml;
+use AsyncMsg;
 
 use strict;
-use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase $maxerrors %nothereslug
+use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase %nothereslug
 	$maxbadcount $msgpolltime $default_pagelth $cmdimportdir);
 
 %Cache = ();					# cache of dynamically loaded routine's mod times
@@ -47,12 +47,11 @@ use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase $maxerrors %notheresl
 $errstr = ();					# error string from eval
 %aliases = ();					# aliases for (parts of) commands
 $scriptbase = "$main::root/scripts"; # the place where all users start scripts go
-$maxerrors = 20;				# the maximum number of concurrent errors allowed before disconnection
 $maxbadcount = 3;				# no of bad words allowed before disconnection
 $msgpolltime = 3600;			# the time between polls for new messages 
 $cmdimportdir = "$main::root/cmd_import"; # the base directory for importing command scripts 
                                           # this does not exist as default, you need to create it manually
-					  #
+#
 
 #
 # obtain a new connection this is derived from dxchannel
@@ -66,7 +65,7 @@ sub new
 	my $pkg = shift;
 	my $call = shift;
 #	my @rout = $main::routeroot->add_user($call, Route::here(1));
-	DXProt::_add_thingy($main::routeroot, [$call, 0, 0, 1]);
+	DXProt::_add_thingy($main::routeroot, [$call, 0, 0, 1, undef, undef, $self->{conn}->peerhost], );
 
 	# ALWAYS output the user
 	my $ref = Route::User::get($call);
@@ -90,7 +89,7 @@ sub start
 	my $name = $user->{name};
 	
 	# log it
-	my $host = $self->{conn}->{peerhost};
+	my $host = $self->{conn}->peerhost;
 	$host ||= "AGW Port #$self->{conn}->{agwport}" if exists $self->{conn}->{agwport};
 	$host ||= "unknown";
 	LogDbg('DXCommand', "$call connected from $host");
@@ -125,25 +124,15 @@ sub start
 	$user->wantdxitu(0) unless defined $user->{wantdxitu};	
 	$user->wantusstate(0) unless defined $user->{wantusstate};
 
-	# sort out registration
-	if ($main::reqreg == 1) {
-		$self->{registered} = $user->registered;
-	} elsif ($main::reqreg == 2) {
+	# sort out registration (who wanted 2???) Note registration *could* be used even when reqreg == 0
+	if ($main::reqreg == 2) {
 		$self->{registered} = !$user->registered;
 	} else {
-		$self->{registered} = 1;
+		$self->{registered} = $user->registered;
 	}
 
-
-	# decide which motd to send
-	my $motd;
-	unless ($self->{registered}) {
-		$motd = "${main::motd}_nor_$self->{lang}";
-		$motd = "${main::motd}_nor" unless -e $motd;
-	}
-	$motd = "${main::motd}_$self->{lang}" unless $motd && -e $motd;
-	$motd = $main::motd unless $motd && -e $motd;
-	$self->send_file($motd) if -e $motd;
+	# send the relevant MOTD
+	$self->send_motd;
 
 	# sort out privilege reduction
 	$self->{priv} = 0 if $line =~ /^(ax|te)/ && !$self->conn->{usedpasswd};
@@ -212,7 +201,7 @@ sub start
 	foreach my $call (@{$user->buddies}) {
 		my $ref = Route::User::get($call);
 		if ($ref) {
-			foreach my $node (@{$ref->parent}) {
+			foreach my $node ($ref->parents) {
 				$self->send($self->msg($node eq $main::mycall ? 'loginb' : 'loginbn', $call, $node));
 			} 
 		}
@@ -477,6 +466,7 @@ sub send_ans
 		}
 	} 
 }
+
 # 
 # this is the thing that runs the command, it is done like this for the 
 # benefit of remote command execution
@@ -490,19 +480,22 @@ sub run_cmd
 	my $cmdline = shift;
 	my @ans;
 	
-
 	return () if length $cmdline == 0;
 	
-	
 	# split the command line up into parts, the first part is the command
 	my ($cmd, $args) = split /\s+/, $cmdline, 2;
 	$args = "" unless defined $args;
 		
 	if ($cmd) {
+
+		# check cmd
+		if ($cmd =~ m|^/| || $cmd =~ m|[^-?\w/]|) {
+			LogDbg('DXCommand', "cmd: invalid characters in '$cmd'");
+			return $self->_error_out('e1');
+		}
+
 		# strip out // on command only
 		$cmd =~ s|//|/|g;
-		$cmd =~ s|^/||g;		# no leading / either
-		$cmd =~ s|[^-?\w/]||g;		# and no funny characters either
 					
 		my ($path, $fcmd);
 			
@@ -513,7 +506,7 @@ sub run_cmd
 		if ($acmd) {
 			($cmd, $args) = split /\s+/, "$acmd $args", 2;
 			$args = "" unless defined $args;
-			dbg("aliased cmd: $cmd $args") if isdbg('command');
+			dbg("cmd: aliased $cmd $args") if isdbg('command');
 		}
 			
 		# first expand out the entry to a command
@@ -521,26 +514,23 @@ sub run_cmd
 		($path, $fcmd) = search($main::cmd, $cmd, "pl") unless $path && $fcmd;
 
 		if ($path && $cmd) {
-			dbg("path: $cmd cmd: $fcmd") if isdbg('command');
+			dbg("cmd: path $cmd cmd: $fcmd") if isdbg('command');
 			
 			my $package = find_cmd_name($path, $fcmd);
 			return ($@) if $@;
 				
-			if ($package) {
+			if ($package && $self->can("${package}::handle")) {
 				no strict 'refs';
-				dbg("package: $package") if isdbg('command');
-				eval { @ans = &$package($self, $args) };
+				dbg("cmd: package $package") if isdbg('command');
+				eval { @ans = &{"${package}::handle"}($self, $args) };
 				return (DXDebug::shortmess($@)) if $@;
+			} else {
+				dbg("cmd: $package not present") if isdbg('command');
+				return $self->_error_out('e1');
 			}
 		} else {
 			dbg("cmd: $cmd not found") if isdbg('command');
-			if (++$self->{errors} > $maxerrors) {
-				$self->send($self->msg('e26'));
-				$self->disconnect;
-				return ();
-			} else {
-				return ($self->msg('e1'));
-			}
+			return $self->_error_out('e1');
 		}
 	}
 	
@@ -548,7 +538,7 @@ sub run_cmd
 	if ($ok) {
 		delete $self->{errors};
 	} else {
-		if (++$self->{errors} > $maxerrors) {
+		if (++$self->{errors} > $DXChannel::maxerrors) {
 			$self->send($self->msg('e26'));
 			$self->disconnect;
 			return ();
@@ -753,12 +743,14 @@ sub clear_cmd_cache
 {
 	no strict 'refs';
 	
-	for (keys %Cache) {
-		undef *{$_} unless /cmd_cache/;
-		dbg("Undefining cmd $_") if isdbg('command');
+	for my $k (keys %Cache) {
+		unless ($k =~ /cmd_cache/) {
+			dbg("Undefining cmd $k") if isdbg('command');
+			undef $DXCommandmode::{"${k}::"};
+		}
 	}
 	%cmd_cache = ();
-	%Cache = ();
+	%Cache = ( cmd_clear_cmd_cache  => $Cache{cmd_clear_cmd_cache} );
 }
 
 #
@@ -769,11 +761,10 @@ sub clear_cmd_cache
 # 
 # This has been nicked directly from the perlembed pages
 #
-
 #require Devel::Symdump;  
 
 sub valid_package_name {
-	my($string) = @_;
+	my $string = shift;
 	$string =~ s|([^A-Za-z0-9_/])|sprintf("_%2x",unpack("C",$1))|eg;
 	
 	$string =~ s|/|_|g;
@@ -796,7 +787,7 @@ sub find_cmd_name {
 		return undef;
 	}
 	
-	if(defined $Cache{$package}->{mtime} &&$Cache{$package}->{mtime} <= $mtime) {
+	if(exists $Cache{$package} && exists $Cache{$package}->{mtime} && $Cache{$package}->{mtime} <= $mtime) {
 		#we have compiled this subroutine already,
 		#it has not been updated on disk, nothing left to do
 		#print STDERR "already compiled $package->handler\n";
@@ -810,7 +801,14 @@ sub find_cmd_name {
 		};
 		
 		#wrap the code into a subroutine inside our unique package
-		my $eval = qq( sub $package { $sub } );
+		my $eval = qq(package DXCommandmode::$package; use POSIX qw{:math_h}; use DXLog; use DXDebug; use DXUser; use DXUtil; our \@ISA = qw{DXCommandmode}; );
+
+
+		if ($sub =~ m|\s*sub\s+handle\n|) {
+			$eval .= $sub;
+		} else {
+			$eval .= qq(sub handle { $sub });
+		}
 		
 		if (isdbg('eval')) {
 			my @list = split /\n/, $eval;
@@ -824,18 +822,19 @@ sub find_cmd_name {
 		no strict 'refs';
 
 		if (exists $Cache{$package}) {
-			dbg("Redefining $package") if isdbg('command');
-			undef *$package;
+			dbg("find_cmd_name: Redefining $package") if isdbg('command');
+			undef $DXCommandmode::{"${package}::"};
+			delete $Cache{$package};
 		} else {
-			dbg("Defining $package") if isdbg('command');
+			dbg("find_cmd_name: Defining $package") if isdbg('command');
 		}
+
 		eval $eval;
-		
-		$Cache{$package} = {mtime => $mtime };
-	    
+
+		$Cache{$package} = {mtime => $mtime } unless $@;
 	}
 
-	return $package;
+	return "DXCommandmode::$package";
 }
 
 sub send
@@ -959,29 +958,40 @@ sub format_dx_spot
 
 	my $t = ztime($_[2]);
 	my $loc = '';
-	my $clth = $self->{consort} eq 'local' ? 29 : 30;
+
+	my $clth = 30 + $self->{width} - 80;    # allow comment to grow according the screen width 
+	#	--$clth if $self->{consort} eq 'local';
+	
 	my $comment = substr (($_[3] || ''), 0, $clth);
-	$comment .= ' ' x ($clth - length($comment));
-	if ($self->{user}->wantgrid) {
-		my $ref = DXUser->get_current($_[4]);
-		if ($ref) {
-			$loc = $ref->qra || '';
-			$loc = ' ' . substr($loc, 0, 4) if $loc;
+	$comment =~ s/\t/ /g;
+	
+	$comment .= ' ' x ($clth - (length($comment)));
+	
+    if ($self->{user}->wantgrid) {
+		my $ref = DXUser::get_current($_[1]);
+		if ($ref && $ref->qra) {
+			my $cloc = ' ' . substr($ref->qra, 0, 4);
+			$comment = substr $comment, 0,  ($clth - (length($comment)+length($cloc)));
+			$comment .= $cloc;
 		}
-	}
-
-	if ($self->{user}->wantdxitu) {
+		my $origin = $_[4];
+		$origin =~ s/-#$//;			# sigh......
+		$ref = DXUser::get_current($origin);
+		if ($ref && $ref->qra) {
+			$loc = ' ' . substr($ref->qra, 0, 4);
+		}
+	} elsif ($self->{user}->wantdxitu) {
 		$loc = ' ' . sprintf("%2d", $_[10]) if defined $_[10];
-		$comment = substr($comment, 0,  $self->{consort} eq 'local' ? 26 : 27) . ' ' . sprintf("%2d", $_[8]) if defined $_[8]; 
+		$comment = substr($comment, 0,  $clth-3) . ' ' . sprintf("%2d", $_[8]) if defined $_[8]; 
 	} elsif ($self->{user}->wantdxcq) {
 		$loc = ' ' . sprintf("%2d", $_[11]) if defined $_[11];
-		$comment = substr($comment, 0,  $self->{consort} eq 'local' ? 26 : 27) . ' ' . sprintf("%2d", $_[9]) if defined $_[9]; 
+		$comment = substr($comment, 0, $clth-3) . ' ' . sprintf("%2d", $_[9]) if defined $_[9]; 
 	} elsif ($self->{user}->wantusstate) {
 		$loc = ' ' . $_[13] if $_[13];
-		$comment = substr($comment, 0,  $self->{consort} eq 'local' ? 26 : 27) . ' ' . $_[12] if $_[12]; 
+		$comment = substr($comment, 0,  $clth-3) . ' ' . $_[12] if $_[12]; 
 	}
 
-	return sprintf "DX de %-7.7s%11.1f  %-12.12s %-s $t$loc", "$_[4]:", $_[0], $_[1], $comment;
+	return sprintf "DX de %-8.8s%10.1f  %-12.12s %-s $t$loc", "$_[4]:", $_[0], $_[1], $comment;
 }
 
 # send a dx spot
@@ -1007,7 +1017,7 @@ sub dx_spot
 	} elsif ($self->{gtk}) {
 		my ($dxloc, $byloc);
 
-		my $ref = DXUser->get_current($_[4]);
+		my $ref = DXUser::get_current($_[4]);
 		if ($ref) {
 			$byloc = $ref->qra;
 			$byloc = substr($byloc, 0, 4) if $byloc;
@@ -1015,7 +1025,7 @@ sub dx_spot
 
 		my $spot = $_[1];
 		$spot =~ s|/\w{1,4}$||;
-		$ref = DXUser->get_current($spot);
+		$ref = DXUser::get_current($spot);
 		if ($ref) {
 			$dxloc = $ref->qra;
 			$dxloc = substr($dxloc, 0, 4) if $dxloc;
@@ -1183,7 +1193,7 @@ sub import_cmd
 			    if ($dxchan) {
 					@out = $s->run($dxchan, 1);
 				} else {
-					my $u = DXUser->get($call);
+					my $u = DXUser::get($call);
 					if ($u) {
 						$dxchan = $main::me;
 						my $old = $dxchan->{call};
@@ -1193,7 +1203,7 @@ sub import_cmd
 						$dxchan->{priv} = $u->priv;
 						$dxchan->{user} = $u;
 						@out = $s->run($dxchan, 1);
-						$dxchan->{call} = $call;
+						$dxchan->{call} = $old;
 						$dxchan->{priv} = $priv;
 						$dxchan->{user} = $user;
 					} else {
@@ -1218,5 +1228,29 @@ sub print_find_reply
 	my $sort = $flag == 2 ? "External" : "Local";
 	$self->send("$sort $target found at $node in $ms ms" );
 }
+
+# send the most relevant motd
+sub send_motd
+{
+	my $self = shift;
+	my $motd;
+
+	unless ($self->registered) {
+		$motd = "${main::motd}_nor_$self->{lang}";
+		$motd = "${main::motd}_nor" unless -e $motd;
+	}
+	$motd = "${main::motd}_$self->{lang}" unless $motd && -e $motd;
+	$motd = $main::motd unless $motd && -e $motd;
+	if ($self->conn->ax25) {
+		if ($motd) {
+			$motd = "${motd}_ax25" if -e "${motd}_ax25";
+		} else {
+			$motd = "${main::motd}_ax25" if -e "${main::motd}_ax25";
+		}
+	}
+	$self->send_file($motd) if -e $motd;
+}
+
+
 1;
 __END__