X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FMsg.pm;h=615feb1987e4a102def727f208d093107f63d85b;hb=407d9a80a8af1fa6c1ae2c8fbca833e49da6e816;hp=e167269363d6f674ac24a016ce2fbabea51a7c0b;hpb=c644e2f01b7528fb3cd4666a552a5ee282462e88;p=spider.git

diff --git a/perl/Msg.pm b/perl/Msg.pm
index e1672693..615feb19 100644
--- a/perl/Msg.pm
+++ b/perl/Msg.pm
@@ -11,12 +11,19 @@
 package Msg;
 
 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;
+$main::build += $VERSION;
+$main::branch += $BRANCH;
+
 use IO::Select;
 use IO::Socket;
 use DXDebug;
 use Timer;
 
-use vars qw(%rd_callbacks %wt_callbacks %er_callbacks $rd_handles $wt_handles $er_handles $now %conns $noconns);
+use vars qw(%rd_callbacks %wt_callbacks %er_callbacks $rd_handles $wt_handles $er_handles $now %conns $noconns $blocking_supported $cnum);
 
 %rd_callbacks = ();
 %wt_callbacks = ();
@@ -26,14 +33,20 @@ $wt_handles   = IO::Select->new();
 $er_handles   = IO::Select->new();
 
 $now = time;
-my $blocking_supported = 0;
 
 BEGIN {
     # Checks if blocking is supported
     eval {
-        require POSIX; POSIX->import(qw (F_SETFL F_GETFL O_NONBLOCK));
+        require POSIX; POSIX->import(qw(O_NONBLOCK F_SETFL F_GETFL))
     };
-    $blocking_supported = 1 unless $@;
+	if ($@ || $main::is_win) {
+#		print STDERR "POSIX Blocking *** NOT *** supported $@\n";
+		$blocking_supported = 0;
+	} else {
+		$blocking_supported = 1;
+#		print STDERR "POSIX Blocking enabled\n";
+	}
+
 
 	# import as many of these errno values as are available
 	eval {
@@ -47,6 +60,8 @@ my $eagain = eval {EAGAIN()};
 my $einprogress = eval {EINPROGRESS()};
 my $ewouldblock = eval {EWOULDBLOCK()};
 $^W = $w;
+$cnum = 0;
+
 
 #
 #-----------------------------------------------------------------
@@ -67,10 +82,12 @@ sub new
 		csort => 'telnet',
 		timeval => 60,
 		blocking => 0,
+		cnum => (($cnum < 999) ? (++$cnum) : ($cnum = 1)),
     };
 
 	$noconns++;
-	dbg('connll', "Connection created ($noconns)");
+	
+	dbg("Connection created ($noconns)") if isdbg('connll');
 	return bless $conn, $class;
 }
 
@@ -112,10 +129,11 @@ sub conns
 	if (ref $pkg) {
 		$call = $pkg->{call} unless $call;
 		return undef unless $call;
-		confess "changing $pkg->{call} to $call" if exists $pkg->{call} && $call ne $pkg->{call};
+		dbg("changing $pkg->{call} to $call") if isdbg('connll') && exists $pkg->{call} && $call ne $pkg->{call};
+		delete $conns{$pkg->{call}} if exists $pkg->{call} && exists $conns{$pkg->{call}} && $pkg->{call} ne $call; 
 		$pkg->{call} = $call;
 		$ref = $conns{$call} = $pkg;
-		dbg('connll', "Connection $call stored");
+		dbg("Connection $pkg->{cnum} $call stored") if isdbg('connll');
 	} else {
 		$ref = $conns{$call};
 	}
@@ -128,9 +146,9 @@ sub pid_gone
 	my ($pkg, $pid) = @_;
 	
 	my @pid = grep {$_->{pid} == $pid} values %conns;
-	for (@pid) {
-		&{$_->{eproc}}($_, "$pid has gorn") if exists $_->{eproc};
-		$_->disconnect;
+	foreach my $p (@pid) {
+		&{$p->{eproc}}($p, "$pid has gorn") if exists $p->{eproc};
+		$p->disconnect;
 	}
 }
 
@@ -155,10 +173,8 @@ sub connect {
 	my $proto = getprotobyname('tcp');
 	$sock->socket(AF_INET, SOCK_STREAM, $proto) or return undef;
 	
-	if ($conn->{blocking}) {
-		blocking($sock, 0);
-		$conn->{blocking} = 0;
-	}
+	blocking($sock, 0);
+	$conn->{blocking} = 0;
 
 	my $ip = gethostbyname($to_host);
 #	my $r = $sock->connect($to_port, $ip);
@@ -190,9 +206,9 @@ sub disconnect {
 		delete $conns{$call} if $ref && $ref == $conn;
 	}
 	$call ||= 'unallocated';
-	dbg('connll', "Connection $call disconnected");
+	dbg("Connection $conn->{cnum} $call disconnected") if isdbg('connll');
 	
-	unless ($^O =~ /^MS/i) {
+	unless ($main::is_win) {
 		kill 'TERM', $conn->{pid} if exists $conn->{pid};
 	}
 
@@ -268,20 +284,21 @@ sub _send {
 					$conn->disconnect;
                     return 0; # fail. Message remains in queue ..
                 }
-            }
+            } elsif (isdbg('raw')) {
+				my $call = $conn->{call} || 'none';
+				dbgdump('raw', "$call send $bytes_written: ", $msg);
+			}
             $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
+        #last unless $flush; # Go back to select and wait
                             # for it to fire again.
     }
     # Call me back if queue has not been drained.
-    if (@$rq) {
-        set_event_handler ($sock, write => sub {$conn->_send(0)});
-    } else {
+    unless (@$rq) {
         set_event_handler ($sock, write => undef);
 		if (exists $conn->{close_on_empty}) {
 			&{$conn->{eproc}}($conn, undef) if exists $conn->{eproc};
@@ -369,7 +386,29 @@ sub _rcv {                     # Complement to _send
 	$bytes_read = sysread ($sock, $msg, 1024, 0);
 	if (defined ($bytes_read)) {
 		if ($bytes_read > 0) {
-			$conn->{msg} .= $msg;
+			if (isdbg('raw')) {
+				my $call = $conn->{call} || 'none';
+				dbgdump('raw', "$call read $bytes_read: ", $msg);
+			}
+			if ($conn->{echo}) {
+				my @ch = split //, $msg;
+				my $out;
+				for (@ch) {
+					if (/[\cH\x7f]/) {
+						$out .= "\cH \cH";
+						$conn->{msg} =~ s/.$//;
+					} else {
+						$out .= $_;
+						$conn->{msg} .= $_;
+					}
+				}
+				if (defined $out) {
+					set_event_handler ($sock, write => sub{$conn->_send(0)});
+					push @{$conn->{outqueue}}, $out;
+				}
+			} else {
+				$conn->{msg} .= $msg;
+			}
 		} 
 	} else {
 		if (_err_will_block($!)) {
@@ -384,29 +423,37 @@ FINISH:
 		&{$conn->{eproc}}($conn, $!) if exists $conn->{eproc};
 		$conn->disconnect;
     } else {
-		$conn->dequeue if exists $conn->{msg};
+		unless ($conn->{disable_read}) {
+			$conn->dequeue if exists $conn->{msg};
+		}
 	}
 }
 
 sub new_client {
 	my $server_conn = shift;
     my $sock = $server_conn->{sock}->accept();
-    my $conn = $server_conn->new($server_conn->{rproc});
-	$conn->{sock} = $sock;
-    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 ($sock) {
+		my $conn = $server_conn->new($server_conn->{rproc});
+		$conn->{sock} = $sock;
+		blocking($sock, 0);
+		$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');
 	}
-    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();
-    }
 }
 
 sub close_server
@@ -419,11 +466,18 @@ sub close_server
 # close all clients (this is for forking really)
 sub close_all_clients
 {
-	for (values %conns) {
-		$_->disconnect;
+	foreach my $conn (values %conns) {
+		$conn->disconnect;
 	}
 }
 
+sub disable_read
+{
+	my $conn = shift;
+	set_event_handler ($conn->{sock}, read => undef);
+	return $_[0] ? $conn->{disable_read} = $_[0] : $_[0];
+}
+
 #
 #----------------------------------------------------
 # Event loop routines used by both client and server
@@ -472,7 +526,7 @@ sub event_loop {
        # Quit the loop if no handles left to process
         last unless ($rd_handles->count() || $wt_handles->count());
         
-		($rset, $wset) = IO::Select->select($rd_handles, $wt_handles, $er_handles, $timeout);
+		($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};
@@ -505,7 +559,9 @@ sub DESTROY
 {
 	my $conn = shift;
 	my $call = $conn->{call} || 'unallocated';
-	dbg('connll', "Connection $call being destroyed ($noconns)");
+	my $host = $conn->{peerhost} || '';
+	my $port = $conn->{peerport} || '';
+	dbg("Connection $conn->{cnum} $call [$host $port] being destroyed") if isdbg('connll');
 	$noconns--;
 }