Commit | Line | Data |
6fe26b29 |
1 | package DBM::Deep::Array; |
2 | |
7f441181 |
3 | $NEGATIVE_INDICES = 1; |
4 | |
6fe26b29 |
5 | use strict; |
6 | |
7 | use base 'DBM::Deep'; |
8 | |
e1b265cc |
9 | use Scalar::Util (); |
10 | |
596e9574 |
11 | sub _get_self { |
12 | eval { tied( @{$_[0]} ) } || $_[0] |
13 | } |
14 | |
6fe26b29 |
15 | sub TIEARRAY { |
16 | ## |
17 | # Tied array constructor method, called by Perl's tie() function. |
18 | ## |
19 | my $class = shift; |
0ca7ea98 |
20 | my $args = $class->_get_args( @_ ); |
6fe26b29 |
21 | |
22 | $args->{type} = $class->TYPE_ARRAY; |
23 | |
24 | return $class->_init($args); |
25 | } |
26 | |
7f441181 |
27 | sub FETCH { |
28 | my $self = $_[0]->_get_self; |
29 | my $key = $_[1]; |
30 | |
31 | if ( $key =~ /^-?\d+$/ ) { |
32 | if ( $key < 0 ) { |
33 | $key += $self->FETCHSIZE; |
34 | return unless $key >= 0; |
35 | } |
36 | |
37 | $key = pack($DBM::Deep::LONG_PACK, $key); |
38 | } |
39 | |
40 | return $self->SUPER::FETCH( $key ); |
41 | } |
42 | |
cb79ec85 |
43 | sub STORE { |
44 | my $self = shift->_get_self; |
45 | my ($key, $value) = @_; |
46 | |
baa27ab6 |
47 | my $orig = $key; |
cb79ec85 |
48 | my $size = $self->FETCHSIZE; |
49 | |
50 | my $numeric_idx; |
51 | if ( $key =~ /^-?\d+$/ ) { |
52 | $numeric_idx = 1; |
53 | if ( $key < 0 ) { |
54 | $key += $size; |
baa27ab6 |
55 | if ( $key < 0 ) { |
56 | die( "Modification of non-creatable array value attempted, subscript $orig" ); |
57 | } |
cb79ec85 |
58 | } |
59 | |
60 | $key = pack($DBM::Deep::LONG_PACK, $key); |
61 | } |
62 | |
63 | my $rv = $self->SUPER::STORE( $key, $value ); |
64 | |
baa27ab6 |
65 | if ( $numeric_idx && $rv == 2 && $orig >= $size ) { |
66 | $self->STORESIZE( $orig + 1 ); |
cb79ec85 |
67 | } |
68 | |
69 | return $rv; |
70 | } |
71 | |
baa27ab6 |
72 | sub EXISTS { |
73 | my $self = $_[0]->_get_self; |
74 | my $key = $_[1]; |
75 | |
76 | if ( $key =~ /^-?\d+$/ ) { |
77 | if ( $key < 0 ) { |
78 | $key += $self->FETCHSIZE; |
79 | return unless $key >= 0; |
80 | } |
81 | |
82 | $key = pack($DBM::Deep::LONG_PACK, $key); |
83 | } |
84 | |
85 | return $self->SUPER::EXISTS( $key ); |
86 | } |
87 | |
6fe26b29 |
88 | sub FETCHSIZE { |
89 | ## |
90 | # Return the length of the array |
91 | ## |
2ac02042 |
92 | my $self = $_[0]->_get_self; |
6fe26b29 |
93 | |
94 | my $SAVE_FILTER = $self->root->{filter_fetch_value}; |
95 | $self->root->{filter_fetch_value} = undef; |
96 | |
97 | my $packed_size = $self->FETCH('length'); |
98 | |
99 | $self->root->{filter_fetch_value} = $SAVE_FILTER; |
100 | |
7f441181 |
101 | if ($packed_size) { |
102 | return int(unpack($DBM::Deep::LONG_PACK, $packed_size)); |
103 | } |
cb79ec85 |
104 | |
105 | return 0; |
6fe26b29 |
106 | } |
107 | |
108 | sub STORESIZE { |
109 | ## |
110 | # Set the length of the array |
111 | ## |
2ac02042 |
112 | my $self = $_[0]->_get_self; |
6fe26b29 |
113 | my $new_length = $_[1]; |
114 | |
115 | my $SAVE_FILTER = $self->root->{filter_store_value}; |
116 | $self->root->{filter_store_value} = undef; |
117 | |
118 | my $result = $self->STORE('length', pack($DBM::Deep::LONG_PACK, $new_length)); |
119 | |
120 | $self->root->{filter_store_value} = $SAVE_FILTER; |
121 | |
122 | return $result; |
123 | } |
124 | |
125 | sub POP { |
126 | ## |
127 | # Remove and return the last element on the array |
128 | ## |
2ac02042 |
129 | my $self = $_[0]->_get_self; |
6fe26b29 |
130 | my $length = $self->FETCHSIZE(); |
131 | |
132 | if ($length) { |
133 | my $content = $self->FETCH( $length - 1 ); |
134 | $self->DELETE( $length - 1 ); |
135 | return $content; |
136 | } |
137 | else { |
138 | return; |
139 | } |
140 | } |
141 | |
142 | sub PUSH { |
143 | ## |
144 | # Add new element(s) to the end of the array |
145 | ## |
2ac02042 |
146 | my $self = shift->_get_self; |
6fe26b29 |
147 | my $length = $self->FETCHSIZE(); |
148 | |
149 | while (my $content = shift @_) { |
150 | $self->STORE( $length, $content ); |
151 | $length++; |
152 | } |
8f6d6ed0 |
153 | |
154 | return $length; |
6fe26b29 |
155 | } |
156 | |
157 | sub SHIFT { |
158 | ## |
159 | # Remove and return first element on the array. |
160 | # Shift over remaining elements to take up space. |
161 | ## |
2ac02042 |
162 | my $self = $_[0]->_get_self; |
6fe26b29 |
163 | my $length = $self->FETCHSIZE(); |
164 | |
165 | if ($length) { |
166 | my $content = $self->FETCH( 0 ); |
167 | |
168 | ## |
169 | # Shift elements over and remove last one. |
170 | ## |
171 | for (my $i = 0; $i < $length - 1; $i++) { |
172 | $self->STORE( $i, $self->FETCH($i + 1) ); |
173 | } |
174 | $self->DELETE( $length - 1 ); |
175 | |
176 | return $content; |
177 | } |
178 | else { |
179 | return; |
180 | } |
181 | } |
182 | |
183 | sub UNSHIFT { |
184 | ## |
185 | # Insert new element(s) at beginning of array. |
186 | # Shift over other elements to make space. |
187 | ## |
2ac02042 |
188 | my $self = shift->_get_self; |
6fe26b29 |
189 | my @new_elements = @_; |
190 | my $length = $self->FETCHSIZE(); |
191 | my $new_size = scalar @new_elements; |
192 | |
193 | if ($length) { |
194 | for (my $i = $length - 1; $i >= 0; $i--) { |
195 | $self->STORE( $i + $new_size, $self->FETCH($i) ); |
196 | } |
197 | } |
198 | |
199 | for (my $i = 0; $i < $new_size; $i++) { |
200 | $self->STORE( $i, $new_elements[$i] ); |
201 | } |
8f6d6ed0 |
202 | |
203 | return $length + $new_size; |
6fe26b29 |
204 | } |
205 | |
206 | sub SPLICE { |
207 | ## |
208 | # Splices section of array with optional new section. |
209 | # Returns deleted section, or last element deleted in scalar context. |
210 | ## |
2ac02042 |
211 | my $self = shift->_get_self; |
6fe26b29 |
212 | my $length = $self->FETCHSIZE(); |
213 | |
214 | ## |
215 | # Calculate offset and length of splice |
216 | ## |
217 | my $offset = shift || 0; |
218 | if ($offset < 0) { $offset += $length; } |
219 | |
220 | my $splice_length; |
221 | if (scalar @_) { $splice_length = shift; } |
222 | else { $splice_length = $length - $offset; } |
223 | if ($splice_length < 0) { $splice_length += ($length - $offset); } |
224 | |
225 | ## |
226 | # Setup array with new elements, and copy out old elements for return |
227 | ## |
228 | my @new_elements = @_; |
229 | my $new_size = scalar @new_elements; |
230 | |
231 | my @old_elements = (); |
232 | for (my $i = $offset; $i < $offset + $splice_length; $i++) { |
233 | push @old_elements, $self->FETCH( $i ); |
234 | } |
235 | |
236 | ## |
237 | # Adjust array length, and shift elements to accomodate new section. |
238 | ## |
239 | if ( $new_size != $splice_length ) { |
240 | if ($new_size > $splice_length) { |
241 | for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) { |
242 | $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) ); |
243 | } |
244 | } |
245 | else { |
246 | for (my $i = $offset + $splice_length; $i < $length; $i++) { |
247 | $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) ); |
248 | } |
249 | for (my $i = 0; $i < $splice_length - $new_size; $i++) { |
250 | $self->DELETE( $length - 1 ); |
251 | $length--; |
252 | } |
253 | } |
254 | } |
255 | |
256 | ## |
257 | # Insert new elements into array |
258 | ## |
259 | for (my $i = $offset; $i < $offset + $new_size; $i++) { |
260 | $self->STORE( $i, shift @new_elements ); |
261 | } |
262 | |
263 | ## |
264 | # Return deleted section, or last element in scalar context. |
265 | ## |
266 | return wantarray ? @old_elements : $old_elements[-1]; |
267 | } |
268 | |
269 | #XXX We don't need to define it. |
270 | #XXX It will be useful, though, when we split out HASH and ARRAY |
271 | #sub EXTEND { |
272 | ## |
273 | # Perl will call EXTEND() when the array is likely to grow. |
274 | # We don't care, but include it for compatibility. |
275 | ## |
276 | #} |
277 | |
278 | ## |
279 | # Public method aliases |
280 | ## |
281 | *length = *FETCHSIZE; |
282 | *pop = *POP; |
283 | *push = *PUSH; |
284 | *shift = *SHIFT; |
285 | *unshift = *UNSHIFT; |
286 | *splice = *SPLICE; |
287 | |
288 | 1; |
289 | __END__ |