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