a11619a725ebd6f764d68004fae318c2b356fd75
[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / Array.pm
1 package DBM::Deep::Array;
2
3 use strict;
4
5 # This is to allow DBM::Deep::Array to handle negative indices on
6 # its own. Otherwise, Perl would intercept the call to negative
7 # indices for us. This was causing bugs for negative index handling.
8 use vars qw( $NEGATIVE_INDICES );
9 $NEGATIVE_INDICES = 1;
10
11 use base 'DBM::Deep';
12
13 use Scalar::Util ();
14
15 sub _get_self {
16     eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0]
17 }
18
19 sub TIEARRAY {
20 ##
21 # Tied array constructor method, called by Perl's tie() function.
22 ##
23     my $class = shift;
24     my $args = $class->_get_args( @_ );
25         
26         $args->{type} = $class->TYPE_ARRAY;
27         
28         return $class->_init($args);
29 }
30
31 sub FETCH {
32     my $self = $_[0]->_get_self;
33     my $key = $_[1];
34
35         $self->lock( $self->LOCK_SH );
36         
37     if ( $key =~ /^-?\d+$/ ) {
38         if ( $key < 0 ) {
39             $key += $self->FETCHSIZE;
40             unless ( $key >= 0 ) {
41                 $self->unlock;
42                 return;
43             }
44         }
45
46         $key = pack($DBM::Deep::LONG_PACK, $key);
47     }
48
49     my $rv = $self->SUPER::FETCH( $key );
50
51     $self->unlock;
52
53     return $rv;
54 }
55
56 sub STORE {
57     my $self = shift->_get_self;
58     my ($key, $value) = @_;
59
60     $self->lock( $self->LOCK_EX );
61
62     my $orig = $key;
63
64     my $size;
65     my $numeric_idx;
66     if ( $key =~ /^\-?\d+$/ ) {
67         $numeric_idx = 1;
68         if ( $key < 0 ) {
69             $size = $self->FETCHSIZE;
70             $key += $size;
71             if ( $key < 0 ) {
72                 die( "Modification of non-creatable array value attempted, subscript $orig" );
73             }
74         }
75
76         $key = pack($DBM::Deep::LONG_PACK, $key);
77     }
78
79     my $rv = $self->SUPER::STORE( $key, $value );
80
81     if ( $numeric_idx && $rv == 2 ) {
82         $size = $self->FETCHSIZE unless defined $size;
83         if ( $orig >= $size ) {
84             $self->STORESIZE( $orig + 1 );
85         }
86     }
87
88     $self->unlock;
89
90     return $rv;
91 }
92
93 sub EXISTS {
94     my $self = $_[0]->_get_self;
95     my $key = $_[1];
96
97         $self->lock( $self->LOCK_SH );
98
99     if ( $key =~ /^\-?\d+$/ ) {
100         if ( $key < 0 ) {
101             $key += $self->FETCHSIZE;
102             unless ( $key >= 0 ) {
103                 $self->unlock;
104                 return;
105             }
106         }
107
108         $key = pack($DBM::Deep::LONG_PACK, $key);
109     }
110
111     my $rv = $self->SUPER::EXISTS( $key );
112
113     $self->unlock;
114
115     return $rv;
116 }
117
118 sub DELETE {
119     my $self = $_[0]->_get_self;
120     my $key = $_[1];
121
122     my $unpacked_key = $key;
123
124     $self->lock( $self->LOCK_EX );
125
126     my $size = $self->FETCHSIZE;
127     if ( $key =~ /^-?\d+$/ ) {
128         if ( $key < 0 ) {
129             $key += $size;
130             unless ( $key >= 0 ) {
131                 $self->unlock;
132                 return;
133             }
134         }
135
136         $key = pack($DBM::Deep::LONG_PACK, $key);
137     }
138
139     my $rv = $self->SUPER::DELETE( $key );
140
141         if ($rv && $unpacked_key == $size - 1) {
142                 $self->STORESIZE( $unpacked_key );
143         }
144
145     $self->unlock;
146
147     return $rv;
148 }
149
150 sub FETCHSIZE {
151         ##
152         # Return the length of the array
153         ##
154     my $self = shift->_get_self;
155
156     $self->lock( $self->LOCK_SH );
157
158         my $SAVE_FILTER = $self->root->{filter_fetch_value};
159         $self->root->{filter_fetch_value} = undef;
160         
161         my $packed_size = $self->FETCH('length');
162         
163         $self->root->{filter_fetch_value} = $SAVE_FILTER;
164         
165     $self->unlock;
166
167         if ($packed_size) {
168         return int(unpack($DBM::Deep::LONG_PACK, $packed_size));
169     }
170
171         return 0;
172 }
173
174 sub STORESIZE {
175         ##
176         # Set the length of the array
177         ##
178     my $self = $_[0]->_get_self;
179         my $new_length = $_[1];
180         
181     $self->lock( $self->LOCK_EX );
182
183         my $SAVE_FILTER = $self->root->{filter_store_value};
184         $self->root->{filter_store_value} = undef;
185         
186         my $result = $self->STORE('length', pack($DBM::Deep::LONG_PACK, $new_length));
187         
188         $self->root->{filter_store_value} = $SAVE_FILTER;
189         
190     $self->unlock;
191
192         return $result;
193 }
194
195 sub POP {
196         ##
197         # Remove and return the last element on the array
198         ##
199     my $self = $_[0]->_get_self;
200
201     $self->lock( $self->LOCK_EX );
202
203         my $length = $self->FETCHSIZE();
204         
205         if ($length) {
206                 my $content = $self->FETCH( $length - 1 );
207                 $self->DELETE( $length - 1 );
208
209         $self->unlock;
210
211                 return $content;
212         }
213         else {
214         $self->unlock;
215                 return;
216         }
217 }
218
219 sub PUSH {
220         ##
221         # Add new element(s) to the end of the array
222         ##
223     my $self = shift->_get_self;
224         
225     $self->lock( $self->LOCK_EX );
226
227         my $length = $self->FETCHSIZE();
228
229         while (my $content = shift @_) {
230                 $self->STORE( $length, $content );
231                 $length++;
232         }
233
234     $self->unlock;
235
236     return $length;
237 }
238
239 sub SHIFT {
240         ##
241         # Remove and return first element on the array.
242         # Shift over remaining elements to take up space.
243         ##
244     my $self = $_[0]->_get_self;
245
246     $self->lock( $self->LOCK_EX );
247
248         my $length = $self->FETCHSIZE();
249         
250         if ($length) {
251                 my $content = $self->FETCH( 0 );
252                 
253                 ##
254                 # Shift elements over and remove last one.
255                 ##
256                 for (my $i = 0; $i < $length - 1; $i++) {
257                         $self->STORE( $i, $self->FETCH($i + 1) );
258                 }
259                 $self->DELETE( $length - 1 );
260
261         $self->unlock;
262                 
263                 return $content;
264         }
265         else {
266         $self->unlock;
267                 return;
268         }
269 }
270
271 sub UNSHIFT {
272         ##
273         # Insert new element(s) at beginning of array.
274         # Shift over other elements to make space.
275         ##
276     my $self = shift->_get_self;
277         my @new_elements = @_;
278
279     $self->lock( $self->LOCK_EX );
280
281         my $length = $self->FETCHSIZE();
282         my $new_size = scalar @new_elements;
283         
284         if ($length) {
285                 for (my $i = $length - 1; $i >= 0; $i--) {
286                         $self->STORE( $i + $new_size, $self->FETCH($i) );
287                 }
288         }
289         
290         for (my $i = 0; $i < $new_size; $i++) {
291                 $self->STORE( $i, $new_elements[$i] );
292         }
293
294     $self->unlock;
295
296     return $length + $new_size;
297 }
298
299 sub SPLICE {
300         ##
301         # Splices section of array with optional new section.
302         # Returns deleted section, or last element deleted in scalar context.
303         ##
304     my $self = shift->_get_self;
305
306     $self->lock( $self->LOCK_EX );
307
308         my $length = $self->FETCHSIZE();
309         
310         ##
311         # Calculate offset and length of splice
312         ##
313         my $offset = shift || 0;
314         if ($offset < 0) { $offset += $length; }
315         
316         my $splice_length;
317         if (scalar @_) { $splice_length = shift; }
318         else { $splice_length = $length - $offset; }
319         if ($splice_length < 0) { $splice_length += ($length - $offset); }
320         
321         ##
322         # Setup array with new elements, and copy out old elements for return
323         ##
324         my @new_elements = @_;
325         my $new_size = scalar @new_elements;
326         
327     my @old_elements = map {
328         $self->FETCH( $_ )
329     } $offset .. ($offset + $splice_length - 1);
330         
331         ##
332         # Adjust array length, and shift elements to accomodate new section.
333         ##
334     if ( $new_size != $splice_length ) {
335         if ($new_size > $splice_length) {
336             for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
337                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
338             }
339         }
340         else {
341             for (my $i = $offset + $splice_length; $i < $length; $i++) {
342                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
343             }
344             for (my $i = 0; $i < $splice_length - $new_size; $i++) {
345                 $self->DELETE( $length - 1 );
346                 $length--;
347             }
348         }
349         }
350         
351         ##
352         # Insert new elements into array
353         ##
354         for (my $i = $offset; $i < $offset + $new_size; $i++) {
355                 $self->STORE( $i, shift @new_elements );
356         }
357         
358     $self->unlock;
359
360         ##
361         # Return deleted section, or last element in scalar context.
362         ##
363         return wantarray ? @old_elements : $old_elements[-1];
364 }
365
366 #XXX We don't need to define it, yet.
367 #XXX It will be useful, though, when we split out HASH and ARRAY
368 #sub EXTEND {
369         ##
370         # Perl will call EXTEND() when the array is likely to grow.
371         # We don't care, but include it for compatibility.
372         ##
373 #}
374
375 ##
376 # Public method aliases
377 ##
378 *length = *FETCHSIZE;
379 *pop = *POP;
380 *push = *PUSH;
381 *shift = *SHIFT;
382 *unshift = *UNSHIFT;
383 *splice = *SPLICE;
384
385 1;
386 __END__