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