added perl socket blocking where available

change timestamp in PC9x to seconds in day.

diff --git a/perl/DXLog.pm b/perl/DXLog.pm
index 785483533c562f50dfc438e30ecfebfda9cf024b..07038433d440a3161dc6aa4c597ceefd9ea60c41 100644 (file)
--- a/perl/DXLog.pm
+++ b/perl/DXLog.pm
@@ -206,7 +206,7 @@ sub Log
 
 sub LogDbg
 {
-       DXDebug::dbg($_[$#_]);
+       DXDebug::dbg($_) for @_;
        Log(@_);
 }
 

diff --git a/perl/DXProtHandle.pm b/perl/DXProtHandle.pm
index 26781885eb318f38292b2a9d1858c6549614ddc1..fc05280a92afd22317cce66601e064478fcd3caf 100644 (file)
--- a/perl/DXProtHandle.pm
+++ b/perl/DXProtHandle.pm
@@ -1339,7 +1339,7 @@ sub gen_pc9x_t
        if (!$_last_time || $_last_time != $main::systime) {
                $_last_time = $main::systime;
                $_last_occurs = 0;
-               return $_last_time;
+               return $_last_time - $main::systime_daystart;
        } else {
                $_last_occurs++;
                return sprintf "$_last_time.%02d", $_last_occurs;
@@ -1356,10 +1356,12 @@ sub check_pc9x_t
        my $parent = ref $call ? $call : Route::Node::get($call);
        if ($parent) {
                my $lastid = $parent->lastid->{$pc} || 0;
+               $t += 86400 if $t < $lastid - 43200;
                if ($lastid >= $t) {
                        dbg("PCPROT: dup / old id on $call <= $lastid, ignored") if isdbg('chanerr');
                        return;
                }
+               $t -= 86400 if $t >= 86400;
        } elsif ($create) {
                $parent = Route::Node->new($call);
        }
@@ -1394,6 +1396,7 @@ sub handle_92
        }
 
        my $parent = check_pc9x_t($pcall, $t, 92, 1);
+       return unless $parent;
        
        $parent->lastid->{92} = $t;
        $parent->do_pc92(1);
@@ -1404,6 +1407,10 @@ sub handle_92
                # and update any information that needs to be done. 
                my ($call, $is_node, $is_extnode, $here, $version, $build) = _decode_pc92_call($ent[0]);
                if ($call && $is_node) {
+                       if ($call eq $main::mycall) {
+                               dbg("PCPROT: looped back on node entry, ignored") if isdbg('chanerr');
+                               return;
+                       }
                        if ($is_extnode) {
                                # reparent to external node (note that we must have received a 'C' or 'A' record
                                # from the true parent node for this external before we get one for the this node

diff --git a/perl/Msg.pm b/perl/Msg.pm
index 00569928165bb2a630862b4d1fd9603ee05f6d8a..e13be8f31d90f00329ff08a628c66fa79ac5cffb 100644 (file)
--- a/perl/Msg.pm
+++ b/perl/Msg.pm
@@ -42,11 +42,9 @@ BEGIN {
         require POSIX; POSIX->import(qw(O_NONBLOCK F_SETFL F_GETFL))
     };
        if ($@ || $main::is_win) {
-#              print STDERR "POSIX Blocking *** NOT *** supported $@\n";
-               $blocking_supported = 0;
+               $blocking_supported = IO::Socket->can('blocking') ? 2 : 0;
        } else {
-               $blocking_supported = 1;
-#              print STDERR "POSIX Blocking enabled\n";
+               $blocking_supported = IO::Socket->can('blocking') ? 2 : 1;
        }
 
 
@@ -139,12 +137,8 @@ sub blocking
        return unless $blocking_supported;
 
        # Make the handle stop blocking, the Windows way.
-       if ($main::is_win) { 
-         # 126 is FIONBIO (some docs say 0x7F << 16)
-               ioctl( $_[0],
-                          0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
-                          "$_[1]"
-                        );
+       if ($blocking_supported) { 
+               $_[0]->blocking($_[1]);
        } else {
                my $flags = fcntl ($_[0], F_GETFL, 0);
                if ($_[1]) {
@@ -346,10 +340,10 @@ sub _send {
     # return to the event loop only after every message, or if it
     # is likely to block in the middle of a message.
 
-       if ($conn->{blocking} != $flush) {
-               blocking($sock, $flush);
-               $conn->{blocking} = $flush;
-       }
+#      if ($conn->{blocking} != $flush) {
+#              blocking($sock, $flush);
+#              $conn->{blocking} = $flush;
+#      }
     my $offset = (exists $conn->{send_offset}) ? $conn->{send_offset} : 0;
 
     while (@$rq) {

diff --git a/perl/cluster.pl b/perl/cluster.pl
index 0fc478ea4dd4adc0b366b037b197ed975223c3c6..79bca2649becc379f9977628e6ad23443c9e6e71 100755 (executable)
--- a/perl/cluster.pl
+++ b/perl/cluster.pl
@@ -116,7 +116,7 @@ use strict;
 use vars qw(@inqueue $systime $version $starttime $lockfn @outstanding_connects 
                        $zombies $root @listeners $lang $myalias @debug $userfn $clusteraddr 
                        $clusterport $mycall $decease $is_win $routeroot $me $reqreg $bumpexisting
-                       $allowdxby $dbh $dsn $dbuser $dbpass $do_xml
+                       $allowdxby $dbh $dsn $dbuser $dbpass $do_xml $systime_days $systime_daystart
                   );
 
 @inqueue = ();                                 # the main input queue, an array of hashes
@@ -332,6 +332,8 @@ sub AGWrestart
 #############################################################
 
 $starttime = $systime = time;
+$systime_days = int ($systime / 86400);
+$systime_daystart = $systime_days * 86400; 
 $lang = 'en' unless $lang;
 
 unless ($DB::VERSION) {
@@ -511,7 +513,13 @@ for (;;) {
        # do timed stuff, ongoing processing happens one a second
        if ($timenow != $systime) {
                reap() if $zombies;
-               IsoTime::update($systime = $timenow);
+               $systime = $timenow;
+               my $days = int ($systime / 86400);
+               if ($systime_days != $days) {
+                       $systime_days = $days;
+                       $systime_daystart = $days * 86400;
+               }
+               IsoTime::update($systime);
                DXCron::process();      # do cron jobs
                DXCommandmode::process(); # process ongoing command mode stuff
                DXXml::process();