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