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