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