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