Added guard to make sure values that cannot be read correctly aren't stored, plus...
[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / Array.pm
CommitLineData
6fe26b29 1package DBM::Deep::Array;
2
3use strict;
4
8fec41b9 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.
7910cf68 8use vars qw( $NEGATIVE_INDICES );
9$NEGATIVE_INDICES = 1;
10
6fe26b29 11use base 'DBM::Deep';
12
e1b265cc 13use Scalar::Util ();
14
596e9574 15sub _get_self {
8db25060 16 eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0]
596e9574 17}
18
6fe26b29 19sub TIEARRAY {
20##
21# Tied array constructor method, called by Perl's tie() function.
22##
23 my $class = shift;
0ca7ea98 24 my $args = $class->_get_args( @_ );
6fe26b29 25
26 $args->{type} = $class->TYPE_ARRAY;
27
28 return $class->_init($args);
29}
30
7f441181 31sub FETCH {
eea0d863 32 my $self = shift->_get_self;
33 my ($key) = @_;
7f441181 34
9281d66b 35 $self->lock( $self->LOCK_SH );
36
7f441181 37 if ( $key =~ /^-?\d+$/ ) {
38 if ( $key < 0 ) {
39 $key += $self->FETCHSIZE;
9281d66b 40 unless ( $key >= 0 ) {
41 $self->unlock;
42 return;
43 }
7f441181 44 }
45
612969fb 46 $key = pack($self->{engine}{long_pack}, $key);
7f441181 47 }
48
9281d66b 49 my $rv = $self->SUPER::FETCH( $key );
50
51 $self->unlock;
52
53 return $rv;
7f441181 54}
55
cb79ec85 56sub STORE {
57 my $self = shift->_get_self;
58 my ($key, $value) = @_;
59
9281d66b 60 $self->lock( $self->LOCK_EX );
61
baa27ab6 62 my $orig = $key;
cb79ec85 63
9ab67b8c 64 my $size;
cb79ec85 65 my $numeric_idx;
9ab67b8c 66 if ( $key =~ /^\-?\d+$/ ) {
cb79ec85 67 $numeric_idx = 1;
68 if ( $key < 0 ) {
9ab67b8c 69 $size = $self->FETCHSIZE;
cb79ec85 70 $key += $size;
baa27ab6 71 if ( $key < 0 ) {
72 die( "Modification of non-creatable array value attempted, subscript $orig" );
73 }
cb79ec85 74 }
75
612969fb 76 $key = pack($self->{engine}{long_pack}, $key);
cb79ec85 77 }
78
79 my $rv = $self->SUPER::STORE( $key, $value );
80
9ab67b8c 81 if ( $numeric_idx && $rv == 2 ) {
82 $size = $self->FETCHSIZE unless defined $size;
83 if ( $orig >= $size ) {
84 $self->STORESIZE( $orig + 1 );
85 }
cb79ec85 86 }
87
9281d66b 88 $self->unlock;
89
cb79ec85 90 return $rv;
91}
92
baa27ab6 93sub EXISTS {
eea0d863 94 my $self = shift->_get_self;
95 my ($key) = @_;
baa27ab6 96
9281d66b 97 $self->lock( $self->LOCK_SH );
98
9ab67b8c 99 if ( $key =~ /^\-?\d+$/ ) {
baa27ab6 100 if ( $key < 0 ) {
101 $key += $self->FETCHSIZE;
9281d66b 102 unless ( $key >= 0 ) {
103 $self->unlock;
104 return;
105 }
106 }
107
612969fb 108 $key = pack($self->{engine}{long_pack}, $key);
9281d66b 109 }
110
111 my $rv = $self->SUPER::EXISTS( $key );
112
113 $self->unlock;
114
115 return $rv;
116}
117
118sub DELETE {
eea0d863 119 my $self = shift->_get_self;
120 my ($key) = @_;
9281d66b 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 }
baa27ab6 134 }
135
612969fb 136 $key = pack($self->{engine}{long_pack}, $key);
baa27ab6 137 }
138
9281d66b 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;
baa27ab6 148}
149
6fe26b29 150sub FETCHSIZE {
151 ##
152 # Return the length of the array
153 ##
9281d66b 154 my $self = shift->_get_self;
155
156 $self->lock( $self->LOCK_SH );
157
4d35d856 158 my $SAVE_FILTER = $self->_root->{filter_fetch_value};
159 $self->_root->{filter_fetch_value} = undef;
6fe26b29 160
161 my $packed_size = $self->FETCH('length');
162
4d35d856 163 $self->_root->{filter_fetch_value} = $SAVE_FILTER;
6fe26b29 164
9281d66b 165 $self->unlock;
166
7f441181 167 if ($packed_size) {
612969fb 168 return int(unpack($self->{engine}{long_pack}, $packed_size));
7f441181 169 }
cb79ec85 170
171 return 0;
6fe26b29 172}
173
174sub STORESIZE {
175 ##
176 # Set the length of the array
177 ##
eea0d863 178 my $self = shift->_get_self;
179 my ($new_length) = @_;
6fe26b29 180
9281d66b 181 $self->lock( $self->LOCK_EX );
182
4d35d856 183 my $SAVE_FILTER = $self->_root->{filter_store_value};
184 $self->_root->{filter_store_value} = undef;
6fe26b29 185
612969fb 186 my $result = $self->STORE('length', pack($self->{engine}{long_pack}, $new_length));
6fe26b29 187
4d35d856 188 $self->_root->{filter_store_value} = $SAVE_FILTER;
6fe26b29 189
9281d66b 190 $self->unlock;
191
6fe26b29 192 return $result;
193}
194
195sub POP {
196 ##
197 # Remove and return the last element on the array
198 ##
eea0d863 199 my $self = shift->_get_self;
9281d66b 200
201 $self->lock( $self->LOCK_EX );
202
6fe26b29 203 my $length = $self->FETCHSIZE();
204
205 if ($length) {
206 my $content = $self->FETCH( $length - 1 );
207 $self->DELETE( $length - 1 );
9281d66b 208
209 $self->unlock;
210
6fe26b29 211 return $content;
212 }
213 else {
9281d66b 214 $self->unlock;
6fe26b29 215 return;
216 }
217}
218
219sub PUSH {
220 ##
221 # Add new element(s) to the end of the array
222 ##
2ac02042 223 my $self = shift->_get_self;
6fe26b29 224
9281d66b 225 $self->lock( $self->LOCK_EX );
226
227 my $length = $self->FETCHSIZE();
228
6fe26b29 229 while (my $content = shift @_) {
230 $self->STORE( $length, $content );
231 $length++;
232 }
8f6d6ed0 233
9281d66b 234 $self->unlock;
235
8f6d6ed0 236 return $length;
6fe26b29 237}
238
239sub SHIFT {
240 ##
241 # Remove and return first element on the array.
242 # Shift over remaining elements to take up space.
243 ##
eea0d863 244 my $self = shift->_get_self;
9281d66b 245
246 $self->lock( $self->LOCK_EX );
247
6fe26b29 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 );
9281d66b 260
261 $self->unlock;
6fe26b29 262
263 return $content;
264 }
265 else {
9281d66b 266 $self->unlock;
6fe26b29 267 return;
268 }
269}
270
271sub UNSHIFT {
272 ##
273 # Insert new element(s) at beginning of array.
274 # Shift over other elements to make space.
275 ##
2ac02042 276 my $self = shift->_get_self;
6fe26b29 277 my @new_elements = @_;
9281d66b 278
279 $self->lock( $self->LOCK_EX );
280
6fe26b29 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 }
8f6d6ed0 293
9281d66b 294 $self->unlock;
295
8f6d6ed0 296 return $length + $new_size;
6fe26b29 297}
298
299sub SPLICE {
300 ##
301 # Splices section of array with optional new section.
302 # Returns deleted section, or last element deleted in scalar context.
303 ##
2ac02042 304 my $self = shift->_get_self;
9281d66b 305
306 $self->lock( $self->LOCK_EX );
307
6fe26b29 308 my $length = $self->FETCHSIZE();
309
310 ##
311 # Calculate offset and length of splice
312 ##
714618f0 313 my $offset = shift;
314 $offset = 0 unless defined $offset;
6fe26b29 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
df3c5701 328 my @old_elements = map {
329 $self->FETCH( $_ )
330 } $offset .. ($offset + $splice_length - 1);
6fe26b29 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
9281d66b 359 $self->unlock;
360
6fe26b29 361 ##
362 # Return deleted section, or last element in scalar context.
363 ##
364 return wantarray ? @old_elements : $old_elements[-1];
365}
366
9281d66b 367#XXX We don't need to define it, yet.
6fe26b29 368#XXX 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 for compatibility.
373 ##
374#}
375
376##
377# Public method aliases
378##
f75b719e 379sub length { (CORE::shift)->FETCHSIZE(@_) }
380sub pop { (CORE::shift)->POP(@_) }
381sub push { (CORE::shift)->PUSH(@_) }
382sub shift { (CORE::shift)->SHIFT(@_) }
383sub unshift { (CORE::shift)->UNSHIFT(@_) }
384sub splice { (CORE::shift)->SPLICE(@_) }
6fe26b29 385
3861;
387__END__