6 use constant NEXT => 0;
7 use constant PREV => 1;
10 use vars qw($docheck);
16 confess("chain broken $_[1]") unless ref $_[0] && $_[0]->isa('Chain') &&
17 $_[0]->[PREV]->[NEXT] == $_[0] &&
18 $_[0]->[NEXT]->[PREV] == $_[0];
22 # set internal checking
32 my $name = ref $pkg || $pkg;
35 push @$self, $self, $self, @_;
36 return bless $self, $name;
39 # Insert before this point of the chain
44 $docheck && _check($p);
46 my $q = ref $ref && $ref->isa('Chain') ? $ref : Chain->new($ref);
47 $q->[PREV] = $p->[PREV];
49 $p->[PREV]->[NEXT] = $q;
53 # Insert after this point of the chain
58 $docheck && _check($p);
60 $p->[NEXT]->ins($ref);
63 # Delete this item from the chain, returns the NEXT item in the chain
68 $docheck && _check($p);
70 my $q = $p->[PREV]->[NEXT] = $p->[NEXT];
71 $p->[NEXT]->[PREV] = $p->[PREV];
72 $p->[NEXT] = $p->[PREV] = undef;
76 # Is this chain empty?
81 $docheck && _check($p);
83 return $p->[NEXT] == $p;
86 # return next item or undef if end of chain
91 $docheck && _check($base);
93 return $base->[NEXT] == $base ? undef : $base->[NEXT] unless $p;
95 $docheck && _check($p);
97 return $p->[NEXT] != $base ? $p->[NEXT] : undef;
100 # return previous item or undef if end of chain
105 $docheck && _check($base);
107 return $base->[PREV] == $base ? undef : $base->[PREV] unless $p;
109 $docheck && _check($p);
111 return $p->[PREV] != $base ? $p->[PREV] : undef;
114 # return (and optionally replace) the object in this chain item
118 $p->[OBJ] = $ref if $ref;
122 # clear out the chain
126 while (!$base->isempty) {
131 # move this item after the 'base' item
136 $docheck && _check($base, "base") && _check($p, "rechained ref");
142 # count the no of items in a chain
149 ++$count while ($p = $base->next($p));
157 $base->[PREV] = $base->[NEXT] = undef;
162 # Below is the stub of documentation for your module. You better edit it!
166 Chain - Double linked circular chain handler
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);
187 A module to handle those nasty jobs where a perl list simply will
188 not do what is required.
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.
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.
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.
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
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.
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
216 A particular use of B<Chain> is for connection maps that come and go
217 during the course of execution of your program.
219 An artificial example of this is:-
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});
228 # order is now GB7BAA, GB7DJK, GB7MRS
231 while ($p = $base->next($p)) {
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'} );
248 # move the one on the end to the beginning (LRU on a stick :-).
249 $base->rechain($base->prev);
251 # order is now GB7MRS, GB7BAA, GB7DJK
253 # this is exactly equivalent to :
258 # order is now GB7DJK, GB7MRS, GB7BAA
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
273 Dirk Koopman <djk@tobit.co.uk>
277 ICL George 3 internals reference manual (a.k.a the source)