perl/Chain.pm

   1 package Chain;
   2
   3 use strict;
   4 use Carp;
   5
   6 use vars qw($VERSION $BRANCH);
   7 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
   8 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
   9 $main::build += $VERSION;
  10 $main::branch += $BRANCH;
  11
  12 use constant NEXT => 0;
  13 use constant PREV => 1;
  14 use constant OBJ => 2;
  15
  16 use vars qw($docheck);
  17
  18 $docheck = 1;
  19
  20 sub _check
  21 {
  22         confess("chain broken $_[1]") unless ref $_[0] && $_[0]->isa('Chain') &&
  23                 $_[0]->[PREV]->[NEXT] == $_[0] &&
  24                         $_[0]->[NEXT]->[PREV] == $_[0];
  25         return 1;
  26 }
  27
  28 # set internal checking
  29 sub setcheck
  30 {
  31         $docheck = shift;
  32 }
  33
  34 # constructor
  35 sub new
  36 {
  37         my $pkg = shift;
  38         my $name = ref $pkg || $pkg;
  39
  40         my $self = [];
  41         push @$self, $self, $self, @_;
  42         return bless $self, $name;
  43 }
  44
  45 # Insert before this point of the chain
  46 sub ins
  47 {
  48         my ($p, $ref) = @_;
  49
  50         $docheck && _check($p);
  51
  52         my $q = ref $ref && $ref->isa('Chain') ? $ref : Chain->new($ref);
  53         $q->[PREV] = $p->[PREV];
  54         $q->[NEXT] = $p;
  55         $p->[PREV]->[NEXT] = $q;
  56         $p->[PREV] = $q;
  57 }
  58
  59 # Insert after this point of the chain
  60 sub add
  61 {
  62         my ($p, $ref) = @_;
  63
  64         $docheck && _check($p);
  65
  66         $p->[NEXT]->ins($ref);
  67 }
  68
  69 # Delete this item from the chain, returns the NEXT item in the chain
  70 sub del
  71 {
  72         my $p = shift;
  73
  74         $docheck && _check($p);
  75
  76         my $q = $p->[PREV]->[NEXT] = $p->[NEXT];
  77         $p->[NEXT]->[PREV] = $p->[PREV];
  78         $p->[NEXT] = $p->[PREV] = undef;
  79         return $q;
  80 }
  81
  82 # Is this chain empty?
  83 sub isempty
  84 {
  85         my $p = shift;
  86
  87         $docheck && _check($p);
  88
  89         return $p->[NEXT] == $p;
  90 }
  91
  92 # return next item or undef if end of chain
  93 sub next
  94 {
  95         my ($base, $p) = @_;
  96
  97         $docheck && _check($base);
  98
  99         return $base->[NEXT] == $base ? undef : $base->[NEXT] unless $p;
 100
 101         $docheck && _check($p);
 102
 103         return $p->[NEXT] != $base ? $p->[NEXT] : undef;
 104 }
 105
 106 # return previous item or undef if end of chain
 107 sub prev
 108 {
 109         my ($base, $p) = @_;
 110
 111         $docheck && _check($base);
 112
 113         return $base->[PREV] == $base ? undef : $base->[PREV] unless $p;
 114
 115         $docheck && _check($p);
 116
 117         return $p->[PREV] != $base ? $p->[PREV] : undef;
 118 }
 119
 120 # return (and optionally replace) the object in this chain item
 121 sub obj
 122 {
 123         my ($p, $ref) = @_;
 124         $p->[OBJ] = $ref if $ref;
 125         return $p->[OBJ];
 126 }
 127
 128 # clear out the chain
 129 sub flush
 130 {
 131         my $base = shift;
 132         while (!$base->isempty) {
 133                 $base->[NEXT]->del;
 134         }
 135 }
 136
 137 # move this item after the 'base' item
 138 sub rechain
 139 {
 140         my ($base, $p) = @_;
 141
 142         $docheck && _check($base, "base") && _check($p, "rechained ref");
 143
 144         $p->del;
 145         $base->add($p);
 146 }
 147
 148 # count the no of items in a chain
 149 sub count
 150 {
 151         my $base = shift;
 152         my $count;
 153         my $p;
 154
 155         ++$count while ($p = $base->next($p));
 156         return $count;
 157 }
 158
 159 1;
 160 __END__
 161 # Below is the stub of documentation for your module. You better edit it!
 162
 163 =head1 NAME
 164
 165 Chain - Double linked circular chain handler
 166
 167 =head1 SYNOPSIS
 168
 169   use Chain;
 170   $base = new Chain [$obj];
 171   $p->ins($ref [,$obj]);
 172   $p->add($ref [,$obj]);
 173   $ref = $p->obj or $p->obj($ref);
 174   $q = $base->next($p);
 175   $q = $base->prev($p);
 176   $base->isempty;
 177   $q = $p->del;
 178   $base->flush;
 179   $base->rechain($p);
 180   $base->count;
 181
 182   Chain::setcheck(0);
 183
 184 =head1 DESCRIPTION
 185
 186 A module to handle those nasty jobs where a perl list simply will
 187 not do what is required.
 188
 189 This module is a transliteration from a C routine I wrote in 1987, which
 190 in turn was taken directly from the doubly linked list handling in ICL
 191 George 3 originally written in GIN5 circa 1970.
 192
 193 The type of list this module manipulates is circularly doubly linked
 194 with a base.  This means that you can traverse the list backwards or
 195 forwards from any point.
 196
 197 The particular quality that makes this sort of list useful is that you
 198 can insert and delete items anywhere in the list without having to
 199 worry about end effects.
 200
 201 The list has a I<base> but it doesn't have any real end!  The I<base> is
 202 really just another (invisible) list member that you choose to
 203 remember the position of and is the reference point that determines
 204 what is an I<end>.
 205
 206 There is nothing special about a I<base>. You can choose another member
 207 of the list to be a I<base> whenever you like.
 208
 209 The difference between this module and a normal list is that it allows
 210 one to create persistant arbitrary directed graphs reasonably
 211 efficiently that are easy to traverse, insert and delete objects. You
 212 will never need to use I<splice>, I<grep> or I<map> again (for this
 213 sort of thing).
 214
 215 A particular use of B<Chain> is for connection maps that come and go
 216 during the course of execution of your program.
 217
 218 An artificial example of this is:-
 219
 220   use Chain;
 221
 222   my $base = new Chain;
 223   $base->ins({call=>'GB7BAA', users => new Chain});
 224   $base->ins({call=>'GB7DJK', users => new Chain});
 225   $base->ins({call=>'GB7MRS', users => new Chain});
 226
 227   # order is now GB7BAA, GB7DJK, GB7MRS
 228
 229   my $p;
 230   while ($p = $base->next($p)) {
 231     my $obj = $p->obj;
 232     if ($obj->{call} eq 'GB7DJK') {
 233       my $ubase = $obj->{users};
 234       $ubase->ins( {call => 'G1TLH'} );
 235       $ubase->ins( {call => 'G7BRN'} );
 236     } elsif ($obj->{call} eq 'GB7MRS') {
 237       my $ubase = $obj->{users};
 238       $ubase->ins( {call => 'G4BAH'} );
 239       $ubase->ins( {call => 'G4PIQ'} );
 240     } elsif ($obj->{call} eq 'GB7BAA') {
 241       my $ubase = $obj->{users};
 242       $ubase->ins( {call => 'G8TIC'} );
 243       $ubase->ins( {call => 'M0VHF'} );
 244     }
 245   }
 246
 247   # move the one on the end to the beginning (LRU on a stick :-).
 248   $base->rechain($base->prev);
 249
 250   # order is now GB7MRS, GB7BAA, GB7DJK
 251
 252   # this is exactly equivalent to :
 253   my $p = $base->prev;
 254   $p->del;
 255   $base->add($p);
 256
 257   # order is now GB7DJK, GB7MRS, GB7BAA
 258
 259   # disconnect (ie remove) GB7MRS
 260   for ($p = 0; $p = $base->next($p); ) {
 261     if ($p->obj->{call} eq 'GB7MRS') {
 262       $p->del;                     # remove this 'branch' from the tree
 263       $p->obj->{users}->flush;     # get rid of all its users
 264       last;
 265     }
 266   }
 267
 268
 269
 270 =head1 AUTHOR
 271
 272 Dirk Koopman <djk@tobit.co.uk>
 273
 274 =head1 SEE ALSO
 275
 276 ICL George 3 internals reference manual (a.k.a the source)
 277
 278 =cut