perl/Chain.pm

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