perl/Chain.pm

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