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 sub close
 160 {
 161         my $base = shift;
 162         $base->flush;
 163         $base->[PREV] = $base->[NEXT] = undef;
 164 }
 165
 166 1;
 167 __END__
 168 # Below is the stub of documentation for your module. You better edit it!
 169
 170 =head1 NAME
 171
 172 Chain - Double linked circular chain handler
 173
 174 =head1 SYNOPSIS
 175
 176   use Chain;
 177   $base = new Chain [$obj];
 178   $p->ins($ref [,$obj]);
 179   $p->add($ref [,$obj]);
 180   $ref = $p->obj or $p->obj($ref);
 181   $q = $base->next($p);
 182   $q = $base->prev($p);
 183   $base->isempty;
 184   $q = $p->del;
 185   $base->flush;
 186   $base->rechain($p);
 187   $base->count;
 188
 189   Chain::setcheck(0);
 190
 191 =head1 DESCRIPTION
 192
 193 A module to handle those nasty jobs where a perl list simply will
 194 not do what is required.
 195
 196 This module is a transliteration from a C routine I wrote in 1987, which
 197 in turn was taken directly from the doubly linked list handling in ICL
 198 George 3 originally written in GIN5 circa 1970.
 199
 200 The type of list this module manipulates is circularly doubly linked
 201 with a base.  This means that you can traverse the list backwards or
 202 forwards from any point.
 203
 204 The particular quality that makes this sort of list useful is that you
 205 can insert and delete items anywhere in the list without having to
 206 worry about end effects.
 207
 208 The list has a I<base> but it doesn't have any real end!  The I<base> is
 209 really just another (invisible) list member that you choose to
 210 remember the position of and is the reference point that determines
 211 what is an I<end>.
 212
 213 There is nothing special about a I<base>. You can choose another member
 214 of the list to be a I<base> whenever you like.
 215
 216 The difference between this module and a normal list is that it allows
 217 one to create persistant arbitrary directed graphs reasonably
 218 efficiently that are easy to traverse, insert and delete objects. You
 219 will never need to use I<splice>, I<grep> or I<map> again (for this
 220 sort of thing).
 221
 222 A particular use of B<Chain> is for connection maps that come and go
 223 during the course of execution of your program.
 224
 225 An artificial example of this is:-
 226
 227   use Chain;
 228
 229   my $base = new Chain;
 230   $base->ins({call=>'GB7BAA', users => new Chain});
 231   $base->ins({call=>'GB7DJK', users => new Chain});
 232   $base->ins({call=>'GB7MRS', users => new Chain});
 233
 234   # order is now GB7BAA, GB7DJK, GB7MRS
 235
 236   my $p;
 237   while ($p = $base->next($p)) {
 238     my $obj = $p->obj;
 239     if ($obj->{call} eq 'GB7DJK') {
 240       my $ubase = $obj->{users};
 241       $ubase->ins( {call => 'G1TLH'} );
 242       $ubase->ins( {call => 'G7BRN'} );
 243     } elsif ($obj->{call} eq 'GB7MRS') {
 244       my $ubase = $obj->{users};
 245       $ubase->ins( {call => 'G4BAH'} );
 246       $ubase->ins( {call => 'G4PIQ'} );
 247     } elsif ($obj->{call} eq 'GB7BAA') {
 248       my $ubase = $obj->{users};
 249       $ubase->ins( {call => 'G8TIC'} );
 250       $ubase->ins( {call => 'M0VHF'} );
 251     }
 252   }
 253
 254   # move the one on the end to the beginning (LRU on a stick :-).
 255   $base->rechain($base->prev);
 256
 257   # order is now GB7MRS, GB7BAA, GB7DJK
 258
 259   # this is exactly equivalent to :
 260   my $p = $base->prev;
 261   $p->del;
 262   $base->add($p);
 263
 264   # order is now GB7DJK, GB7MRS, GB7BAA
 265
 266   # disconnect (ie remove) GB7MRS
 267   for ($p = 0; $p = $base->next($p); ) {
 268     if ($p->obj->{call} eq 'GB7MRS') {
 269       $p->del;                     # remove this 'branch' from the tree
 270       $p->obj->{users}->flush;     # get rid of all its users
 271       last;
 272     }
 273   }
 274
 275
 276
 277 =head1 AUTHOR
 278
 279 Dirk Koopman <djk@tobit.co.uk>
 280
 281 =head1 SEE ALSO
 282
 283 ICL George 3 internals reference manual (a.k.a the source)
 284
 285 =cut