lib/Tie/Array.pm

package Tie::Array;

use 5.006_001;
use strict;
use Carp;
our $VERSION = '1.03';

# Pod documentation after __END__ below.

sub DESTROY { }
sub EXTEND  { }
sub UNSHIFT { scalar shift->SPLICE(0,0,@_) }
sub SHIFT { shift->SPLICE(0,1) }
sub CLEAR   { shift->STORESIZE(0) }

sub PUSH
{
 my $obj = shift;
 my $i   = $obj->FETCHSIZE;
 $obj->STORE($i++, shift) while (@_);
}

sub POP
{
 my $obj = shift;
 my $newsize = $obj->FETCHSIZE - 1;
 my $val;
 if ($newsize >= 0)
  {
   $val = $obj->FETCH($newsize);
   $obj->STORESIZE($newsize);
  }
 $val;
}

sub SPLICE {
    my $obj = shift;
    my $sz  = $obj->FETCHSIZE;
    my $off = (@_) ? shift : 0;
    $off += $sz if ($off < 0);
    my $len = (@_) ? shift : $sz - $off;
    $len += $sz - $off if $len < 0;
    my @result;
    for (my $i = 0; $i < $len; $i++) {
        push(@result,$obj->FETCH($off+$i));
    }
    $off = $sz if $off > $sz;
    $len -= $off + $len - $sz if $off + $len > $sz;
    if (@_ > $len) {
        # Move items up to make room
        my $d = @_ - $len;
        my $e = $off+$len;
        $obj->EXTEND($sz+$d);
        for (my $i=$sz-1; $i >= $e; $i--) {
            my $val = $obj->FETCH($i);
            $obj->STORE($i+$d,$val);
        }
    }
    elsif (@_ < $len) {
        # Move items down to close the gap
        my $d = $len - @_;
        my $e = $off+$len;
        for (my $i=$off+$len; $i < $sz; $i++) {
            my $val = $obj->FETCH($i);
            $obj->STORE($i-$d,$val);
        }
        $obj->STORESIZE($sz-$d);
    }
    for (my $i=0; $i < @_; $i++) {
        $obj->STORE($off+$i,$_[$i]);
    }
    return wantarray ? @result : pop @result;
}

sub EXISTS {
    my $pkg = ref $_[0];
    croak "$pkg doesn't define an EXISTS method";
}

sub DELETE {
    my $pkg = ref $_[0];
    croak "$pkg doesn't define a DELETE method";
}

package Tie::StdArray;
use vars qw(@ISA);
@ISA = 'Tie::Array';

sub TIEARRAY  { bless [], $_[0] }
sub FETCHSIZE { scalar @{$_[0]} }
sub STORESIZE { $#{$_[0]} = $_[1]-1 }
sub STORE     { $_[0]->[$_[1]] = $_[2] }
sub FETCH     { $_[0]->[$_[1]] }
sub CLEAR     { @{$_[0]} = () }
sub POP       { pop(@{$_[0]}) }
sub PUSH      { my $o = shift; push(@$o,@_) }
sub SHIFT     { shift(@{$_[0]}) }
sub UNSHIFT   { my $o = shift; unshift(@$o,@_) }
sub EXISTS    { exists $_[0]->[$_[1]] }
sub DELETE    { delete $_[0]->[$_[1]] }

sub SPLICE
{
 my $ob  = shift;
 my $sz  = $ob->FETCHSIZE;
 my $off = @_ ? shift : 0;
 $off   += $sz if $off < 0;
 my $len = @_ ? shift : $sz-$off;
 return splice(@$ob,$off,$len,@_);
}

1;

__END__

=head1 NAME

Tie::Array - base class for tied arrays

=head1 SYNOPSIS

    package Tie::NewArray;
    use Tie::Array;
    @ISA = ('Tie::Array');

    # mandatory methods
    sub TIEARRAY { ... }
    sub FETCH { ... }
    sub FETCHSIZE { ... }

    sub STORE { ... }        # mandatory if elements writeable
    sub STORESIZE { ... }    # mandatory if elements can be added/deleted
    sub EXISTS { ... }       # mandatory if exists() expected to work
    sub DELETE { ... }       # mandatory if delete() expected to work

    # optional methods - for efficiency
    sub CLEAR { ... }
    sub PUSH { ... }
    sub POP { ... }
    sub SHIFT { ... }
    sub UNSHIFT { ... }
    sub SPLICE { ... }
    sub EXTEND { ... }
    sub DESTROY { ... }

    package Tie::NewStdArray;
    use Tie::Array;

    @ISA = ('Tie::StdArray');

    # all methods provided by default

    package main;

    $object = tie @somearray,Tie::NewArray;
    $object = tie @somearray,Tie::StdArray;
    $object = tie @somearray,Tie::NewStdArray;


=head1 DESCRIPTION

This module provides methods for array-tying classes. See
L<perltie> for a list of the functions required in order to tie an array
to a package. The basic B<Tie::Array> package provides stub C<DESTROY>,
and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS>
methods that croak() if the delete() or exists() builtins are ever called
on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
C<FETCHSIZE>, C<STORESIZE>.

The B<Tie::StdArray> package provides efficient methods required for tied arrays
which are implemented as blessed references to an "inner" perl array.
It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly
like standard arrays, allowing for selective overloading of methods.

For developers wishing to write their own tied arrays, the required methods
are briefly defined below. See the L<perltie> section for more detailed
descriptive, as well as example code:

=over 4

=item TIEARRAY classname, LIST

The class method is invoked by the command C<tie @array, classname>. Associates
an array instance with the specified class. C<LIST> would represent
additional arguments (along the lines of L<AnyDBM_File> and compatriots) needed
to complete the association. The method should return an object of a class which
provides the methods below.

=item STORE this, index, value

Store datum I<value> into I<index> for the tied array associated with
object I<this>. If this makes the array larger then
class's mapping of C<undef> should be returned for new positions.

=item FETCH this, index

Retrieve the datum in I<index> for the tied array associated with
object I<this>.

=item FETCHSIZE this

Returns the total number of items in the tied array associated with
object I<this>. (Equivalent to C<scalar(@array)>).

=item STORESIZE this, count

Sets the total number of items in the tied array associated with
object I<this> to be I<count>. If this makes the array larger then
class's mapping of C<undef> should be returned for new positions.
If the array becomes smaller then entries beyond count should be
deleted.

=item EXTEND this, count

Informative call that array is likely to grow to have I<count> entries.
Can be used to optimize allocation. This method need do nothing.

=item EXISTS this, key

Verify that the element at index I<key> exists in the tied array I<this>.

The B<Tie::Array> implementation is a stub that simply croaks.

=item DELETE this, key

Delete the element at index I<key> from the tied array I<this>.

The B<Tie::Array> implementation is a stub that simply croaks.

=item CLEAR this

Clear (remove, delete, ...) all values from the tied array associated with
object I<this>.

=item DESTROY this

Normal object destructor method.

=item PUSH this, LIST

Append elements of LIST to the array.

=item POP this

Remove last element of the array and return it.

=item SHIFT this

Remove the first element of the array (shifting other elements down)
and return it.

=item UNSHIFT this, LIST

Insert LIST elements at the beginning of the array, moving existing elements
up to make room.

=item SPLICE this, offset, length, LIST

Perform the equivalent of C<splice> on the array.

I<offset> is optional and defaults to zero, negative values count back
from the end of the array.

I<length> is optional and defaults to rest of the array.

I<LIST> may be empty.

Returns a list of the original I<length> elements at I<offset>.

=back

=head1 CAVEATS

There is no support at present for tied @ISA. There is a potential conflict
between magic entries needed to notice setting of @ISA, and those needed to
implement 'tie'.

Very little consideration has been given to the behaviour of tied arrays
when C<$[> is not default value of zero.

=head1 AUTHOR

Nick Ing-Simmons E<lt>nik@tiuk.ti.comE<gt>

=cut
Revision:	1.1
Committed:	Thu Jun 30 14:27:16 2005 UTC (21 years, 3 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package Tie::Array;
2
3			use 5.006_001;
4			use strict;
5			use Carp;
6			our $VERSION = '1.03';
7
8			# Pod documentation after __END__ below.
9
10			sub DESTROY { }
11			sub EXTEND { }
12			sub UNSHIFT { scalar shift->SPLICE(0,0,@_) }
13			sub SHIFT { shift->SPLICE(0,1) }
14			sub CLEAR { shift->STORESIZE(0) }
15
16			sub PUSH
17			{
18			my $obj = shift;
19			my $i = $obj->FETCHSIZE;
20			$obj->STORE($i++, shift) while (@_);
21			}
22
23			sub POP
24			{
25			my $obj = shift;
26			my $newsize = $obj->FETCHSIZE - 1;
27			my $val;
28			if ($newsize >= 0)
29			{
30			$val = $obj->FETCH($newsize);
31			$obj->STORESIZE($newsize);
32			}
33			$val;
34			}
35
36			sub SPLICE {
37			my $obj = shift;
38			my $sz = $obj->FETCHSIZE;
39			my $off = (@_) ? shift : 0;
40			$off += $sz if ($off < 0);
41			my $len = (@_) ? shift : $sz - $off;
42			$len += $sz - $off if $len < 0;
43			my @result;
44			for (my $i = 0; $i < $len; $i++) {
45			push(@result,$obj->FETCH($off+$i));
46			}
47			$off = $sz if $off > $sz;
48			$len -= $off + $len - $sz if $off + $len > $sz;
49			if (@_ > $len) {
50			# Move items up to make room
51			my $d = @_ - $len;
52			my $e = $off+$len;
53			$obj->EXTEND($sz+$d);
54			for (my $i=$sz-1; $i >= $e; $i--) {
55			my $val = $obj->FETCH($i);
56			$obj->STORE($i+$d,$val);
57			}
58			}
59			elsif (@_ < $len) {
60			# Move items down to close the gap
61			my $d = $len - @_;
62			my $e = $off+$len;
63			for (my $i=$off+$len; $i < $sz; $i++) {
64			my $val = $obj->FETCH($i);
65			$obj->STORE($i-$d,$val);
66			}
67			$obj->STORESIZE($sz-$d);
68			}
69			for (my $i=0; $i < @_; $i++) {
70			$obj->STORE($off+$i,$_[$i]);
71			}
72			return wantarray ? @result : pop @result;
73			}
74
75			sub EXISTS {
76			my $pkg = ref $_[0];
77			croak "$pkg doesn't define an EXISTS method";
78			}
79
80			sub DELETE {
81			my $pkg = ref $_[0];
82			croak "$pkg doesn't define a DELETE method";
83			}
84
85			package Tie::StdArray;
86			use vars qw(@ISA);
87			@ISA = 'Tie::Array';
88
89			sub TIEARRAY { bless [], $_[0] }
90			sub FETCHSIZE { scalar @{$_[0]} }
91			sub STORESIZE { $#{$_[0]} = $_[1]-1 }
92			sub STORE { $_[0]->[$_[1]] = $_[2] }
93			sub FETCH { $_[0]->[$_[1]] }
94			sub CLEAR { @{$_[0]} = () }
95			sub POP { pop(@{$_[0]}) }
96			sub PUSH { my $o = shift; push(@$o,@_) }
97			sub SHIFT { shift(@{$_[0]}) }
98			sub UNSHIFT { my $o = shift; unshift(@$o,@_) }
99			sub EXISTS { exists $_[0]->[$_[1]] }
100			sub DELETE { delete $_[0]->[$_[1]] }
101
102			sub SPLICE
103			{
104			my $ob = shift;
105			my $sz = $ob->FETCHSIZE;
106			my $off = @_ ? shift : 0;
107			$off += $sz if $off < 0;
108			my $len = @_ ? shift : $sz-$off;
109			return splice(@$ob,$off,$len,@_);
110			}
111
112			1;
113
114			__END__
115
116			=head1 NAME
117
118			Tie::Array - base class for tied arrays
119
120			=head1 SYNOPSIS
121
122			package Tie::NewArray;
123			use Tie::Array;
124			@ISA = ('Tie::Array');
125
126			# mandatory methods
127			sub TIEARRAY { ... }
128			sub FETCH { ... }
129			sub FETCHSIZE { ... }
130
131			sub STORE { ... } # mandatory if elements writeable
132			sub STORESIZE { ... } # mandatory if elements can be added/deleted
133			sub EXISTS { ... } # mandatory if exists() expected to work
134			sub DELETE { ... } # mandatory if delete() expected to work
135
136			# optional methods - for efficiency
137			sub CLEAR { ... }
138			sub PUSH { ... }
139			sub POP { ... }
140			sub SHIFT { ... }
141			sub UNSHIFT { ... }
142			sub SPLICE { ... }
143			sub EXTEND { ... }
144			sub DESTROY { ... }
145
146			package Tie::NewStdArray;
147			use Tie::Array;
148
149			@ISA = ('Tie::StdArray');
150
151			# all methods provided by default
152
153			package main;
154
155			$object = tie @somearray,Tie::NewArray;
156			$object = tie @somearray,Tie::StdArray;
157			$object = tie @somearray,Tie::NewStdArray;
158
159
160
161			=head1 DESCRIPTION
162
163			This module provides methods for array-tying classes. See
164			L<perltie> for a list of the functions required in order to tie an array
165			to a package. The basic B<Tie::Array> package provides stub C<DESTROY>,
166			and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS>
167			methods that croak() if the delete() or exists() builtins are ever called
168			on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
169			C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
170			C<FETCHSIZE>, C<STORESIZE>.
171
172			The B<Tie::StdArray> package provides efficient methods required for tied arrays
173			which are implemented as blessed references to an "inner" perl array.
174			It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly
175			like standard arrays, allowing for selective overloading of methods.
176
177			For developers wishing to write their own tied arrays, the required methods
178			are briefly defined below. See the L<perltie> section for more detailed
179			descriptive, as well as example code:
180
181			=over 4
182
183			=item TIEARRAY classname, LIST
184
185			The class method is invoked by the command C<tie @array, classname>. Associates
186			an array instance with the specified class. C<LIST> would represent
187			additional arguments (along the lines of L<AnyDBM_File> and compatriots) needed
188			to complete the association. The method should return an object of a class which
189			provides the methods below.
190
191			=item STORE this, index, value
192
193			Store datum I<value> into I<index> for the tied array associated with
194			object I<this>. If this makes the array larger then
195			class's mapping of C<undef> should be returned for new positions.
196
197			=item FETCH this, index
198
199			Retrieve the datum in I<index> for the tied array associated with
200			object I<this>.
201
202			=item FETCHSIZE this
203
204			Returns the total number of items in the tied array associated with
205			object I<this>. (Equivalent to C<scalar(@array)>).
206
207			=item STORESIZE this, count
208
209			Sets the total number of items in the tied array associated with
210			object I<this> to be I<count>. If this makes the array larger then
211			class's mapping of C<undef> should be returned for new positions.
212			If the array becomes smaller then entries beyond count should be
213			deleted.
214
215			=item EXTEND this, count
216
217			Informative call that array is likely to grow to have I<count> entries.
218			Can be used to optimize allocation. This method need do nothing.
219
220			=item EXISTS this, key
221
222			Verify that the element at index I<key> exists in the tied array I<this>.
223
224			The B<Tie::Array> implementation is a stub that simply croaks.
225
226			=item DELETE this, key
227
228			Delete the element at index I<key> from the tied array I<this>.
229
230			The B<Tie::Array> implementation is a stub that simply croaks.
231
232			=item CLEAR this
233
234			Clear (remove, delete, ...) all values from the tied array associated with
235			object I<this>.
236
237			=item DESTROY this
238
239			Normal object destructor method.
240
241			=item PUSH this, LIST
242
243			Append elements of LIST to the array.
244
245			=item POP this
246
247			Remove last element of the array and return it.
248
249			=item SHIFT this
250
251			Remove the first element of the array (shifting other elements down)
252			and return it.
253
254			=item UNSHIFT this, LIST
255
256			Insert LIST elements at the beginning of the array, moving existing elements
257			up to make room.
258
259			=item SPLICE this, offset, length, LIST
260
261			Perform the equivalent of C<splice> on the array.
262
263			I<offset> is optional and defaults to zero, negative values count back
264			from the end of the array.
265
266			I<length> is optional and defaults to rest of the array.
267
268			I<LIST> may be empty.
269
270			Returns a list of the original I<length> elements at I<offset>.
271
272			=back
273
274			=head1 CAVEATS
275
276			There is no support at present for tied @ISA. There is a potential conflict
277			between magic entries needed to notice setting of @ISA, and those needed to
278			implement 'tie'.
279
280			Very little consideration has been given to the behaviour of tied arrays
281			when C<$[> is not default value of zero.
282
283			=head1 AUTHOR
284
285			Nick Ing-Simmons E<lt>nik@tiuk.ti.comE<gt>
286
287			=cut