From a9bc2c5a87691ca5bed6e408c5908695bd65387a Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Fri, 20 Jun 2014 14:42:27 +0100 Subject: [PATCH] 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). --- perl/DXChannel.pm | 17 +++++++++-------- perl/DXCommandmode.pm | 3 ++- perl/DXDebug.pm | 14 ++++++++++++-- perl/DXLog.pm | 16 ++++++++++++++-- perl/Version.pm | 4 ++-- perl/cluster.pl | 6 +++--- 6 files changed, 42 insertions(+), 18 deletions(-) diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 895a47b1..c87108d6 100644 --- 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 6f01eb57..403dd134 100644 --- 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 dbeab595..5bf2470d 100644 --- 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 171b9373..e8d289b0 100644 --- 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 5d1d28a3..5327c149 100644 --- 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 c13d93a1..a811cd27 100755 --- 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) { -- 2.43.0