]> scm.dxcluster.org Git - spider.git/blob - perl/Chain.pm
remove typo in dxprothandle
[spider.git] / perl / Chain.pm
1 package Chain;
2
3 use strict;
4 use Carp;
5
6 use constant NEXT => 0;
7 use constant PREV => 1;
8 use constant OBJ => 2;
9
10 use vars qw($docheck);
11
12 $docheck = 0;
13                         
14 sub _check
15 {
16         confess("chain broken $_[1]") unless ref $_[0] && $_[0]->isa('Chain') &&
17                 $_[0]->[PREV]->[NEXT] == $_[0] &&
18                         $_[0]->[NEXT]->[PREV] == $_[0];
19         return 1;
20 }
21
22 # set internal checking
23 sub setcheck
24 {
25         $docheck = shift;
26 }
27
28 # constructor                   
29 sub new
30 {
31         my $pkg = shift;
32         my $name = ref $pkg || $pkg;
33
34         my $self = [];
35         push @$self, $self, $self, @_;
36         return bless $self, $name;
37 }
38
39 # Insert before this point of the chain
40 sub ins
41 {
42         my ($p, $ref) = @_;
43         
44         $docheck && _check($p);
45         
46         my $q = ref $ref && $ref->isa('Chain') ? $ref : Chain->new($ref);
47         $q->[PREV] = $p->[PREV];
48         $q->[NEXT] = $p;
49         $p->[PREV]->[NEXT] = $q;
50         $p->[PREV] = $q;
51 }
52
53 # Insert after this point of the chain
54 sub add  
55 {
56         my ($p, $ref) = @_;
57         
58         $docheck && _check($p);
59         
60         $p->[NEXT]->ins($ref);
61 }
62
63 # Delete this item from the chain, returns the NEXT item in the chain
64 sub del
65 {
66         my $p = shift;
67         
68         $docheck && _check($p);
69         
70         my $q = $p->[PREV]->[NEXT] = $p->[NEXT];
71         $p->[NEXT]->[PREV] = $p->[PREV];
72         $p->[NEXT] = $p->[PREV] = undef;
73         return $q;
74 }
75
76 # Is this chain empty?
77 sub isempty
78 {
79         my $p = shift;
80         
81         $docheck && _check($p);
82         
83         return $p->[NEXT] == $p;
84 }
85
86 # return next item or undef if end of chain
87 sub next
88 {
89         my ($base, $p) = @_;
90         
91         $docheck && _check($base);
92         
93         return $base->[NEXT] == $base ? undef : $base->[NEXT] unless $p; 
94         
95         $docheck && _check($p);
96         
97         return $p->[NEXT] != $base ? $p->[NEXT] : undef; 
98 }
99
100 # return previous item or undef if end of chain
101 sub prev
102 {
103         my ($base, $p) = @_;
104         
105         $docheck && _check($base);
106         
107         return $base->[PREV] == $base ? undef : $base->[PREV] unless $p; 
108         
109         $docheck && _check($p);
110         
111         return $p->[PREV] != $base ? $p->[PREV] : undef; 
112 }
113
114 # return (and optionally replace) the object in this chain item
115 sub obj
116 {
117         my ($p, $ref) = @_;
118         $p->[OBJ] = $ref if $ref;
119         return $p->[OBJ];
120 }
121
122 # clear out the chain
123 sub flush
124 {
125         my $base = shift;
126         while (!$base->isempty) {
127                 $base->[NEXT]->del;
128         }
129 }
130
131 # move this item after the 'base' item
132 sub rechain
133 {
134         my ($base, $p) = @_;
135         
136         $docheck && _check($base, "base") && _check($p, "rechained ref");
137         
138         $p->del;
139         $base->add($p);
140 }
141
142 # count the no of items in a chain
143 sub count
144 {
145         my $base = shift;
146         my $count;
147         my $p;
148         
149         ++$count while ($p = $base->next($p));
150         return $count;
151 }
152
153 sub close
154 {
155         my $base = shift;
156         $base->flush;
157         $base->[PREV] = $base->[NEXT] = undef;
158 }
159
160 1;
161 __END__
162 # Below is the stub of documentation for your module. You better edit it!
163
164 =head1 NAME
165
166 Chain - Double linked circular chain handler
167
168 =head1 SYNOPSIS
169
170   use Chain;
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);
177   $base->isempty;                       
178   $q = $p->del;
179   $base->flush;
180   $base->rechain($p);                   
181   $base->count;
182
183   Chain::setcheck(0);
184
185 =head1 DESCRIPTION
186
187 A module to handle those nasty jobs where a perl list simply will
188 not do what is required.
189
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. 
193
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.  
197
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. 
201
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
205 what is an I<end>.
206
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.
209
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
214 sort of thing).
215
216 A particular use of B<Chain> is for connection maps that come and go
217 during the course of execution of your program.
218
219 An artificial example of this is:-
220
221   use Chain;
222
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});
227
228   # order is now GB7BAA, GB7DJK, GB7MRS
229   
230   my $p;
231   while ($p = $base->next($p)) {
232     my $obj = $p->obj;
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'} );
245     }
246   }
247
248   # move the one on the end to the beginning (LRU on a stick :-).
249   $base->rechain($base->prev);
250
251   # order is now GB7MRS, GB7BAA, GB7DJK
252
253   # this is exactly equivalent to :
254   my $p = $base->prev;
255   $p->del;
256   $base->add($p);
257
258   # order is now GB7DJK, GB7MRS, GB7BAA
259
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
265       last;
266     }
267   }
268  
269   
270     
271 =head1 AUTHOR
272
273 Dirk Koopman <djk@tobit.co.uk>
274
275 =head1 SEE ALSO
276
277 ICL George 3 internals reference manual (a.k.a the source)
278
279 =cut