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