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