6 use vars qw($VERSION $docheck);
8 $VERSION = do { my @r = (q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r};
10 use constant NEXT => 0;
11 use constant PREV => 1;
12 use constant OBJ => 2;
18 confess("chain broken $_[1]") unless ref $_[0] && $_[0]->isa('Chain') &&
19 $_[0]->[PREV]->[NEXT] == $_[0] &&
20 $_[0]->[NEXT]->[PREV] == $_[0];
24 # set internal checking
34 my $name = ref $pkg || $pkg;
37 push @$self, $self, $self, @_;
38 return bless $self, $name;
41 # Insert before this point of the chain
46 $docheck && _check($p);
48 my $q = ref $ref && $ref->isa('Chain') ? $ref : Chain->new($ref);
49 $q->[PREV] = $p->[PREV];
51 $p->[PREV]->[NEXT] = $q;
55 # Insert after this point of the chain
60 $docheck && _check($p);
62 $p->[NEXT]->ins($ref);
65 # Delete this item from the chain, returns the NEXT item in the chain
70 $docheck && _check($p);
72 my $q = $p->[PREV]->[NEXT] = $p->[NEXT];
73 $p->[NEXT]->[PREV] = $p->[PREV];
74 $p->[NEXT] = $p->[PREV] = undef;
78 # Is this chain empty?
83 $docheck && _check($p);
85 return $p->[NEXT] == $p;
88 # return next item or undef if end of chain
93 $docheck && _check($base);
95 return $base->[NEXT] == $base ? undef : $base->[NEXT] unless $p;
97 $docheck && _check($p);
99 return $p->[NEXT] != $base ? $p->[NEXT] : undef;
102 # return previous item or undef if end of chain
107 $docheck && _check($base);
109 return $base->[PREV] == $base ? undef : $base->[PREV] unless $p;
111 $docheck && _check($p);
113 return $p->[PREV] != $base ? $p->[PREV] : undef;
116 # return (and optionally replace) the object in this chain item
120 $p->[OBJ] = $ref if $ref;
124 # clear out the chain
128 while (!$base->isempty) {
133 # move this item after the 'base' item
138 $docheck && _check($base, "base") && _check($p, "rechained ref");
144 # count the no of items in a chain
151 ++$count while ($p = $base->next($p));
157 # Below is the stub of documentation for your module. You better edit it!
161 Chain - Double linked circular chain handler
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);
182 A module to handle those nasty jobs where a perl list simply will
183 not do what is required.
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.
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.
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.
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
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.
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
211 A particular use of B<Chain> is for connection maps that come and go
212 during the course of execution of your program.
214 An artificial example of this is:-
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});
223 # order is now GB7BAA, GB7DJK, GB7MRS
226 while ($p = $base->next($p)) {
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'} );
243 # move the one on the end to the beginning (LRU on a stick :-).
244 $base->rechain($base->prev);
246 # order is now GB7MRS, GB7BAA, GB7DJK
248 # this is exactly equivalent to :
253 # order is now GB7DJK, GB7MRS, GB7BAA
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
268 Dirk Koopman <djk@tobit.co.uk>
272 ICL George 3 internals reference manual (a.k.a the source)