Some more optimisations

Process input directly after receipt.
Do the most common case of input processing first!
Don't autoflush things like debug files automatically but do it
in periodic processing every second (for now).

diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm
index 895a47b14d655ff7c6f3dd66d93d02ea757104d2..c87108d60d4c363ceb367cb61b59739ae0f11bb0 100644 (file)
--- a/perl/DXChannel.pm
+++ b/perl/DXChannel.pm
@@ -213,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)]
@@ -709,28 +710,28 @@ sub process_one
                
                # handle A records
                my $user = $self->user;
-               if ($sort eq 'A' || $sort eq 'O') {
-                       $self->start($line, $sort);
-               } elsif ($sort eq 'I') {
-                       die "\$user not defined for $call" if !defined $user;
+               if ($sort eq 'I') {
+                       die "\$user not defined for $call" unless defined $user;
                        
                        # 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)
-               } elsif ($sort eq 'G') {
-                       $self->enhanced($line);
                } else {
-                       dbg atime . " Unknown command letter ($sort) received from $call\n";
+                       dbg atime . " DXChannel::process_one: Unknown command letter ($sort) received from $call\n";
                }
        }
 }
 
 sub process
 {
-       foreach my $dxchan (get_all()) {
+       foreach my $dxchan (values %channels) {
                next if $dxchan->{disconnecting};
                $dxchan->process_one;
        }

diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm
index 6f01eb574f54dd618a083a30e0f1a6306b5218de..403dd134072841269777a6eda12e8f01d5561559 100644 (file)
--- a/perl/DXCommandmode.pm
+++ b/perl/DXCommandmode.pm
@@ -122,6 +122,7 @@ sub start
        $self->{ann_talk} = $user->wantann_talk;
        $self->{here} = 1;
        $self->{prompt} = $user->prompt if $user->prompt;
+       $self->{lastmsgpoll} = 0;
 
        # sort out new dx spot stuff
        $user->wantdxcq(0) unless defined $user->{wantdxcq};
@@ -564,7 +565,7 @@ sub process
        my $dxchan;
        
        foreach $dxchan (@dxchan) {
-               next if $dxchan->{sort} ne 'U';  
+               next unless $dxchan->{sort} eq 'U';  
        
                # send a outstanding message prompt if required
                if ($t >= $dxchan->lastmsgpoll + $msgpolltime) {

diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm
index dbeab595045870a1ee74e360ea5a5af5bf4f9aac..5bf2470dbf8526282902c7592eab9234654f4ade 100644 (file)
--- a/perl/DXDebug.pm
+++ b/perl/DXDebug.pm
@@ -19,6 +19,7 @@ use vars qw(%dbglevel $fp $callback $cleandays $keepdays);
 use DXUtil;
 use DXLog ();
 use Carp ();
+use POSIX qw(isatty);
 
 %dbglevel = ();
 $fp = undef;
@@ -26,6 +27,8 @@ $callback = undef;
 $keepdays = 10;
 $cleandays = 100;
 
+our $no_stdout;                                        # set if not running in a terminal
+
 # Avoid generating "subroutine redefined" warnings with the following
 # hack (from CGI::Carp):
 if (!defined $DB::VERSION) {
@@ -66,7 +69,7 @@ sub dbg($)
                my @l = split /\n/, $r;
                for (@l) {
                        s/([\x00-\x08\x0B-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;
-                       print "$_\n" if defined \*STDOUT;
+                       print "$_\n" if defined \*STDOUT && !$no_stdout;
                        my $str = "$t^$_";
                        &$callback($str) if $callback;
                        $fp->writeunix($t, $str); 
@@ -79,7 +82,7 @@ sub dbginit
        $callback = shift;
        
        # add sig{__DIE__} handling
-       if (!defined $DB::VERSION) {
+       unless (defined $DB::VERSION) {
                $SIG{__WARN__} = sub { 
                        if ($_[0] =~ /Deep\s+recursion/i) {
                                dbg($@);
@@ -92,6 +95,13 @@ sub dbginit
                };
                
                $SIG{__DIE__} = sub { dbg($@); dbg(Carp::longmess(@_)); };
+
+               # switch off STDOUT printing if we are not talking to a TTY
+               unless ($^O =~ /^MS/ || $^O =~ /^OS-2/) {
+                       unless (isatty(STDOUT->fileno)) {
+                               ++$no_stdout;
+                       }
+               }
        }
 
        $fp = DXLog::new('debug', 'dat', 'd');

diff --git a/perl/DXLog.pm b/perl/DXLog.pm
index 171b9373d9dacf379ed2bbe802049bb6760413bf..e8d289b0995079b531eb0ce8ff1431626583db3a 100644 (file)
--- a/perl/DXLog.pm
+++ b/perl/DXLog.pm
@@ -40,6 +40,8 @@ use strict;
 
 use vars qw($log);
 
+our %logobj;
+
 $log = new('log', 'dat', 'm');
 
 # create a log object that contains all the useful info needed
@@ -55,7 +57,9 @@ sub new
        
        # make sure the directory exists
        mkdir($ref->{prefix}, 0777) unless -e $ref->{prefix};
-       return bless $ref;
+       my $self = bless $ref;
+       $logobj{$self} = $self;
+       return $self;
 }
 
 sub _genfn
@@ -90,7 +94,7 @@ sub open
        
        my $fh = new IO::File $self->{fn}, $mode, 0666;
        return undef if !$fh;
-       $fh->autoflush(1) if $mode ne 'r'; # make it autoflushing if writable
+       $fh->autoflush(0) if $mode ne 'r'; # make it (not) autoflushing if writable
        $self->{fh} = $fh;
 
 #      print "opening $self->{fn}\n";
@@ -181,9 +185,17 @@ sub close
        delete $self->{fh};     
 }
 
+sub flush_all
+{
+       foreach my $l (values %logobj) {
+               $l->{fh}->flush if exists $l->{fh};
+       }
+}
+
 sub DESTROY
 {
        my $self = shift;
+       delete $logobj{$self};
        undef $self->{fh};                      # close the filehandle
        delete $self->{fh} if $self->{fh};
 }

diff --git a/perl/Version.pm b/perl/Version.pm
index 5d1d28a3250b4fb8ca700d15b5cd4e9128c1638d..5327c1494c74957a0c7397431e2ed371fba565c9 100644 (file)
--- a/perl/Version.pm
+++ b/perl/Version.pm
@@ -10,7 +10,7 @@ package main;
 use vars qw($version $build $gitversion);
 
 $version = '1.57';
-$build = '33';
-$gitversion = '4b94818';
+$build = '34';
+$gitversion = '981c165';
 
 1;

diff --git a/perl/cluster.pl b/perl/cluster.pl
index c13d93a1df72b3238e7b23011e96b956434789df..a811cd2779ba7b1174ebbd58c316a28482a5c10a 100755 (executable)
--- a/perl/cluster.pl
+++ b/perl/cluster.pl
@@ -138,7 +138,7 @@ $maxconnect_user = 3;                       # the maximum no of concurrent connections a user can ha
 $maxconnect_node = 0;                  # Ditto but for nodes. In either case if a new incoming connection
                                                                # takes the no of references in the routing table above these numbers
                                                                # then the connection is refused. This only affects INCOMING connections.
-$idle_interval = 0.100;                        # the wait between invocations of the main idle loop processing.
+$idle_interval = 0.500;                        # the wait between invocations of the main idle loop processing.
 our $ending;                                                              # signal that we are ending;
 
 
@@ -342,7 +342,7 @@ sub idle_loop
        my $timenow = time;
 
        BPQMsg::process();
-       DXChannel::process();
+#      DXChannel::process();
 
        #      $DB::trace = 0;
 
@@ -373,7 +373,7 @@ sub idle_loop
                AGWMsg::process();
                
                Timer::handler();
-
+               DXLog::flush_all();
        }
 
        if (defined &Local::process) {