update html docs

[spider.git] / perl / Msg.pm

diff --git a/perl/Msg.pm b/perl/Msg.pm
index e167269363d6f674ac24a016ce2fbabea51a7c0b..03151ca1976aa8906a2b7d7566143ae65dd83f8f 100644 (file)
--- a/perl/Msg.pm
+++ b/perl/Msg.pm
@@ -16,7 +16,7 @@ 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);
 
 %rd_callbacks = ();
 %wt_callbacks = ();
@@ -26,14 +26,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 {
@@ -67,9 +73,9 @@ sub new
                csort => 'telnet',
                timeval => 60,
                blocking => 0,
+               cnum => ++$noconns,
     };
 
-       $noconns++;
        dbg('connll', "Connection created ($noconns)");
        return bless $conn, $class;
 }
@@ -112,10 +118,10 @@ 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('connll', "changing $pkg->{call} to $call") if exists $pkg->{call} && $call ne $pkg->{call};
                $pkg->{call} = $call;
                $ref = $conns{$call} = $pkg;
-               dbg('connll', "Connection $call stored");
+               dbg('connll', "Connection $pkg->{cnum} $call stored");
        } else {
                $ref = $conns{$call};
        }
@@ -128,9 +134,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 +161,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 +194,9 @@ sub disconnect {
                delete $conns{$call} if $ref && $ref == $conn;
        }
        $call ||= 'unallocated';
-       dbg('connll', "Connection $call disconnected");
+       dbg('connll', "Connection $conn->{cnum} $call disconnected");
        
-       unless ($^O =~ /^MS/i) {
+       unless ($main::is_win) {
                kill 'TERM', $conn->{pid} if exists $conn->{pid};
        }
 
@@ -268,7 +272,10 @@ 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;
         }
@@ -370,6 +377,10 @@ sub _rcv {                     # Complement to _send
        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);
+                       }
                } 
        } else {
                if (_err_will_block($!)) {
@@ -391,22 +402,28 @@ FINISH:
 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('err', "Msg: error on accept ($!)");
        }
-    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,8 +436,8 @@ 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;
        }
 }
 
@@ -472,7 +489,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 +522,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('connll', "Connection $conn->{cnum} $call [$host $port] being destroyed");
        $noconns--;
 }