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;
12 use constant NEXT => 0;
13 use constant PREV => 1;
14 use constant OBJ => 2;
16 use vars qw($docheck);
22 confess("chain broken $_[1]") unless ref $_[0] && $_[0]->isa('Chain') &&
23 $_[0]->[PREV]->[NEXT] == $_[0] &&
24 $_[0]->[NEXT]->[PREV] == $_[0];
28 # set internal checking
38 my $name = ref $pkg || $pkg;
41 push @$self, $self, $self, @_;
42 return bless $self, $name;
45 # Insert before this point of the chain
50 $docheck && _check($p);
52 my $q = ref $ref && $ref->isa('Chain') ? $ref : Chain->new($ref);
53 $q->[PREV] = $p->[PREV];
55 $p->[PREV]->[NEXT] = $q;
59 # Insert after this point of the chain
64 $docheck && _check($p);
66 $p->[NEXT]->ins($ref);
69 # Delete this item from the chain, returns the NEXT item in the chain
74 $docheck && _check($p);
76 my $q = $p->[PREV]->[NEXT] = $p->[NEXT];
77 $p->[NEXT]->[PREV] = $p->[PREV];
78 $p->[NEXT] = $p->[PREV] = undef;
82 # Is this chain empty?
87 $docheck && _check($p);
89 return $p->[NEXT] == $p;
92 # return next item or undef if end of chain
97 $docheck && _check($base);
99 return $base->[NEXT] == $base ? undef : $base->[NEXT] unless $p;
101 $docheck && _check($p);
103 return $p->[NEXT] != $base ? $p->[NEXT] : undef;
106 # return previous item or undef if end of chain
111 $docheck && _check($base);
113 return $base->[PREV] == $base ? undef : $base->[PREV] unless $p;
115 $docheck && _check($p);
117 return $p->[PREV] != $base ? $p->[PREV] : undef;
120 # return (and optionally replace) the object in this chain item
124 $p->[OBJ] = $ref if $ref;
128 # clear out the chain
132 while (!$base->isempty) {
137 # move this item after the 'base' item
142 $docheck && _check($base, "base") && _check($p, "rechained ref");
148 # count the no of items in a chain
155 ++$count while ($p = $base->next($p));
163 $base->[PREV] = $base->[NEXT] = undef;
168 # Below is the stub of documentation for your module. You better edit it!
172 Chain - Double linked circular chain handler
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);
193 A module to handle those nasty jobs where a perl list simply will
194 not do what is required.
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.
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.
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.
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
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.
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
222 A particular use of B<Chain> is for connection maps that come and go
223 during the course of execution of your program.
225 An artificial example of this is:-
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});
234 # order is now GB7BAA, GB7DJK, GB7MRS
237 while ($p = $base->next($p)) {
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'} );
254 # move the one on the end to the beginning (LRU on a stick :-).
255 $base->rechain($base->prev);
257 # order is now GB7MRS, GB7BAA, GB7DJK
259 # this is exactly equivalent to :
264 # order is now GB7DJK, GB7MRS, GB7BAA
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
279 Dirk Koopman <djk@tobit.co.uk>
283 ICL George 3 internals reference manual (a.k.a the source)