[p5sagit/p5-mst-13.2.git] / lib / Tie / Array.pm

package Tie::Array;
use vars qw($VERSION); 
use strict;
use Carp;
$VERSION = '1.01';

# Pod documentation after __END__ below.

sub DESTROY { }
sub EXTEND  { }          
sub UNSHIFT { 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;
 my @result;
 for (my $i = 0; $i < $len; $i++)
  {
   push(@result,$obj->FETCH($off+$i));
  }
 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 @result;
} 

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

sub DELETE {
    my $pkg = ref $_[0];
    croak "$pkg dosn'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 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 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 

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