From bf0078cc89a908d46a3f28c7f1c152c2cb4d6fc5 Mon Sep 17 00:00:00 2001 From: minima Date: Sun, 29 Sep 2002 02:13:46 +0000 Subject: [PATCH] Add Chain routines Fix log open on every log write !!! --- Changes | 1 + perl/Chain.pm | 272 ++++++++++++++++++++++++++++++++++++++++++++++++++ perl/DXLog.pm | 4 +- 3 files changed, 275 insertions(+), 2 deletions(-) create mode 100644 perl/Chain.pm diff --git a/Changes b/Changes index 4afa6830..069f8e16 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,7 @@ 28Sep02======================================================================= 1. Put some transparent caching into Prefix.pm to see if this has a performance impact. +2. Fix doing a new log open for every log file write. 26Sep02======================================================================= 1. added WWV and WCY to the Mrtg stats. Don't forget to do an indexmaker! 25Sep02======================================================================= diff --git a/perl/Chain.pm b/perl/Chain.pm new file mode 100644 index 00000000..cb3a2be8 --- /dev/null +++ b/perl/Chain.pm @@ -0,0 +1,272 @@ +package Chain; + +use strict; +use Carp; + +use vars qw($VERSION $docheck); + +$VERSION = do { my @r = (q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r}; + +use constant NEXT => 0; +use constant PREV => 1; +use constant OBJ => 2; + +$docheck = 1; + +sub _check +{ + confess("chain broken $_[1]") unless ref $_[0] && $_[0]->isa('Chain') && + $_[0]->[PREV]->[NEXT] == $_[0] && + $_[0]->[NEXT]->[PREV] == $_[0]; + return 1; +} + +# set internal checking +sub setcheck +{ + $docheck = shift; +} + +# constructor +sub new +{ + my $name = shift; + my $ref = shift; + my $self = []; + push @$self, $self, $self, $ref; + return bless $self, $name; +} + +# Insert before this point of the chain +sub ins +{ + my ($p, $ref) = @_; + + $docheck && _check($p); + + my $q = ref $ref && $ref->isa('Chain') ? $ref : new Chain $ref; + $q->[PREV] = $p->[PREV]; + $q->[NEXT] = $p; + $p->[PREV]->[NEXT] = $q; + $p->[PREV] = $q; +} + +# Insert after this point of the chain +sub add +{ + my ($p, $ref) = @_; + + $docheck && _check($p); + + $p->[NEXT]->ins($ref); +} + +# Delete this item from the chain, returns the NEXT item in the chain +sub del +{ + my $p = shift; + + $docheck && _check($p); + + $p->[PREV]->[NEXT] = $p->[NEXT]; + $p->[NEXT]->[PREV] = $p->[PREV]; + return $p->[PREV]; +} + +# Is this chain empty? +sub isempty +{ + my $p = shift; + + $docheck && _check($p); + + return $p->[NEXT] == $p; +} + +# return next item or undef if end of chain +sub next +{ + my ($base, $p) = @_; + + $docheck && _check($base); + + return $base->[NEXT] == $base ? undef : $base->[NEXT] unless $p; + + $docheck && _check($p); + + return $p->[NEXT] != $base ? $p->[NEXT] : undef; +} + +# return previous item or undef if end of chain +sub prev +{ + my ($base, $p) = @_; + + $docheck && _check($base); + + return $base->[NEXT] == $base ? undef : $base->[PREV] unless $p; + + $docheck && _check($p); + + return $p->[PREV] != $base ? $p->[PREV] : undef; +} + +# return (and optionally replace) the object in this chain item +sub obj +{ + my ($p, $ref) = @_; + $p->[OBJ] = $ref if $ref; + return $p->[OBJ]; +} + +# clear out the chain +sub flush +{ + my $base = shift; + while (!$base->isempty) { + $base->[NEXT]->del; + } +} + +# move this item after the 'base' item +sub rechain +{ + my ($base, $p) = @_; + + $docheck && _check($base, "base") && _check($p, "rechained ref"); + + $p->del; + $base->add($p); +} + +# count the no of items in a chain +sub count +{ + my $base = shift; + my $count; + my $p; + + ++$count while ($p = $base->next($p)); + return $count; +} + +1; +__END__ +# Below is the stub of documentation for your module. You better edit it! + +=head1 NAME + +Chain - Double linked circular chain handler + +=head1 SYNOPSIS + + use Chain; + $base = new Chain; + $p->ins($ref); + $p->add($ref); + $ref = $p->obj or $p->obj($ref); + $q = $base->next($p); + $q = $base->prev($p); + $base->isempty; + $q = $p->del; + $base->flush; + $base->rechain($p); + $base->count; + + Chain::setcheck(0); + +=head1 DESCRIPTION + +A module to handle those nasty jobs where a perl list simply will +not do what is required. + +This module is a transliteration from a C routine I wrote in 1987, which +in turn was taken directly from the doubly linked list handling in ICL +George 3 originally written in GIN5 circa 1970. + +The type of list this module manipulates is circularly doubly linked +with a base. This means that you can traverse the list backwards or +forwards from any point. + +The particular quality that makes this sort of list useful is that you +can insert and delete items anywhere in the list without having to +worry about end effects. + +The list has a I but it doesn't have any real end! The I is +really just another (invisible) list member that you choose to +remember the position of and is the reference point that determines +what is an I. + +There is nothing special about a I. You can choose another member +of the list to be a I whenever you like. + +The difference between this module and a normal list is that it allows +one to create persistant arbitrary directed graphs reasonably +efficiently that are easy to traverse, insert and delete objects. You +will never need to use I, I or I again (for this +sort of thing). + +A particular use of B is for connection maps that come and go +during the course of execution of your program. + +An artificial example of this is:- + + use Chain; + + my $base = new Chain; + $base->ins({call=>'GB7BAA', users => new Chain}); + $base->ins({call=>'GB7DJK', users => new Chain}); + $base->ins({call=>'GB7MRS', users => new Chain}); + + # order is now GB7BAA, GB7DJK, GB7MRS + + my $p; + while ($p = $base->next($p)) { + my $obj = $p->obj; + if ($obj->{call} eq 'GB7DJK') { + my $ubase = $obj->{users}; + $ubase->ins( {call => 'G1TLH'} ); + $ubase->ins( {call => 'G7BRN'} ); + } elsif ($obj->{call} eq 'GB7MRS') { + my $ubase = $obj->{users}; + $ubase->ins( {call => 'G4BAH'} ); + $ubase->ins( {call => 'G4PIQ'} ); + } elsif ($obj->{call} eq 'GB7BAA') { + my $ubase = $obj->{users}; + $ubase->ins( {call => 'G8TIC'} ); + $ubase->ins( {call => 'M0VHF'} ); + } + } + + # move the one on the end to the beginning (LRU on a stick :-). + $base->rechain($base->prev); + + # order is now GB7MRS, GB7BAA, GB7DJK + + # this is exactly equivalent to : + my $p = $base->prev; + $p->del; + $base->add($p); + + # order is now GB7DJK, GB7MRS, GB7BAA + + # disconnect (ie remove) GB7MRS + for ($p = 0; $p = $base->next($p); ) { + if ($p->obj->{call} eq 'GB7MRS') { + $p->del; # remove this 'branch' from the tree + $p->obj->{users}->flush; # get rid of all its users + last; + } + } + + + +=head1 AUTHOR + +Dirk Koopman + +=head1 SEE ALSO + +ICL George 3 internals reference manual (a.k.a the source) + +=cut diff --git a/perl/DXLog.pm b/perl/DXLog.pm index 22f8c808..f96ab44a 100644 --- a/perl/DXLog.pm +++ b/perl/DXLog.pm @@ -99,7 +99,7 @@ sub open $fh->autoflush(1) if $mode ne 'r'; # make it autoflushing if writable $self->{fh} = $fh; -# DXDebug::dbg("opening $self->{fn}\n") if isdbg("dxlog"); +# print "opening $self->{fn}\n"; return $self->{fh}; } @@ -155,7 +155,7 @@ sub write($$$) if (!$self->{fh} || $self->{mode} ne ">>" || $jdate->year != $self->{jdate}->year || - $jdate->thing != $self->{jdate}->year) { + $jdate->thing != $self->{jdate}->thing) { $self->open($jdate, ">>") or confess "can't open $self->{fn} $!"; } -- 2.43.0