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