t/lib/symbol.t See if Symbol works
t/lib/texttabs.t See if Text::Tabs works
t/lib/textwrap.t See if Text::Wrap works
-t/lib/timelocal.t See if Time::Local works
+t/lib/tie-push.t Test for Tie::Array
+t/lib/tie-stdarray.t Test for Tie::StdArray
+lib/tie-stdpush.t Test for Tie::StdArray
t/lib/thread.t Basic test of threading (skipped if no threads)
t/lib/trig.t See if Math::Trig works
t/op/append.t See if . works
PUSHMARK(sp);
EXTEND(sp,2);
PUSHs(mg->mg_obj);
- PUSHs(sv_2mortal(newSViv(key)));
+ PUSHs(sv_2mortal(newSViv(key+1)));
PUTBACK;
perl_call_method("EXTEND", G_SCALAR|G_DISCARD);
FREETMPS;
warn("Attempt to clear deleted array");
}
#endif
- if (!av || AvMAX(av) < 0)
+ if (!av)
return;
/*SUPPRESS 560*/
if (SvRMAGICAL(av))
mg_clear((SV*)av);
+ if (AvMAX(av) < 0)
+ return;
+
if (AvREAL(av)) {
ary = AvARRAY(av);
key = AvFILLp(av) + 1;
EXTEND(sp,2);
PUSHs(mg->mg_obj);
PUSHs(val);
- PUTBACK;
+ PUTBACK;
+ ENTER;
perl_call_method("PUSH", G_SCALAR|G_DISCARD);
+ LEAVE;
return;
}
av_store(av,AvFILLp(av)+1,val);
dSP;
PUSHMARK(sp);
XPUSHs(mg->mg_obj);
- PUTBACK;
+ PUTBACK;
+ ENTER;
if (perl_call_method("POP", G_SCALAR)) {
retval = newSVsv(*stack_sp--);
} else {
retval = &sv_undef;
}
+ LEAVE;
return retval;
}
retval = AvARRAY(av)[AvFILLp(av)];
PUSHs(&sv_undef);
}
PUTBACK;
+ ENTER;
perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD);
+ LEAVE;
return;
}
dSP;
PUSHMARK(sp);
XPUSHs(mg->mg_obj);
- PUTBACK;
+ PUTBACK;
+ ENTER;
if (perl_call_method("SHIFT", G_SCALAR)) {
retval = newSVsv(*stack_sp--);
} else {
retval = &sv_undef;
- }
+ }
+ LEAVE;
return retval;
}
retval = *AvARRAY(av);
PUSHMARK(sp);
EXTEND(sp,2);
PUSHs(mg->mg_obj);
- PUSHs(sv_2mortal(newSViv(fill)));
+ PUSHs(sv_2mortal(newSViv(fill+1)));
PUTBACK;
perl_call_method("STORESIZE", G_SCALAR|G_DISCARD);
FREETMPS;
#define AvREALISH(av) (AvFLAGS(av) & (AVf_REAL|AVf_REIFY))
#define AvFILL(av) ((SvRMAGICAL((SV *) (av))) \
- ? mg_size((SV *) av) \
- : AvFILLp(av))
+ ? mg_size((SV *) av) : AvFILLp(av))
);
-sub FETCHSIZE
-{
- my $self = shift ;
- return $self->length - 1;
-}
+*FETCHSIZE = \&length;
sub AUTOLOAD {
my($constname);
-package Tie::Array;
+package Tie::Array;
+use vars qw($VERSION);
+use strict;
+$VERSION = '1.00';
-# No content yet - just pod skeleton.
+# 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->SETSIZE($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;
+}
+
+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 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;
=head1 SYNOPSIS
+ package NewArray;
use Tie::Array;
- @ISA = 'Tie::Array';
-
- sub SIZE { ... }
- sub FETCH { ... }
- sub STORE { ... }
- sub CLEAR { ... }
+ @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
+
+ # 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 some skeletal methods for array-tying classes.
+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<DELETE>
+and C<EXTEND> methods, 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::StdHash> 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 hashes, 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 assoicated 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 assoicated with
+object I<this>.
+
+=item FETCHSIZE this
+
+Returns the total number of items in the tied array assoicated with
+object I<this>. (Equivalent to C<scalar(@array)>).
+=item STORESIZE this, count
+
+Sets the total number of items in the tied array assoicated 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 CLEAR this
+
+Clear (remove, delete, ...) all values from the tied array assoicated 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 begining 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'.
+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
int
magic_setpack(SV *sv, MAGIC *mg)
-{
+{
+ ENTER;
magic_methcall(mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
+ LEAVE;
return 0;
}
SAVETMPS;
if (magic_methcall(mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
sv = *stack_sp--;
- retval = (U32) SvIV(sv);
+ retval = (U32) SvIV(sv)-1;
}
FREETMPS;
LEAVE;
PUSHMARK(sp);
XPUSHs(mg->mg_obj);
PUTBACK;
-
+ ENTER;
perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
-
+ LEAVE;
return 0;
}
=head2 Tying Arrays
A class implementing a tied ordinary array should define the following
-methods: TIEARRAY, FETCH, STORE, and perhaps DESTROY.
+methods: TIEARRAY, FETCH, STORE, FETCHSIZE, STORESIZE and perhaps DESTROY.
-B<WARNING>: Tied arrays are I<incomplete>. They are also distinctly lacking
-something for the C<$#ARRAY> access (which is hard, as it's an lvalue), as
-well as the other obvious array functions, like push(), pop(), shift(),
-unshift(), and splice().
+FETCHSIZE and STORESIZE are used to provide C<$#array> and
+equivalent C<scalar(@array)> access.
+
+The methods POP, PUSH, SHIFT, UNSHIFT, SPLICE are required if the perl
+operator with the corresponding (but lowercase) name is to operate on the
+tied array. The B<Tie::Array> class can be used as a base class to implement
+these in terms of the basic five methods above.
+
+In addition EXTEND will be called when perl would have pre-extended
+allocation in a real array.
+
+This means that tied arrays are now I<complete>. The example below needs
+upgrading to illustrate this. (The documentation in B<Tie::Array> is more
+complete.)
For this discussion, we'll implement an array whose indices are fixed at
its creation. If you try to access anything beyond those bounds, you'll
-take an exception. (Well, if you access an individual element; an
-aggregate assignment would be missed.) For example:
+take an exception. For example:
require Bounded_Array;
tie @ary, 'Bounded_Array', 2;
if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
*MARK-- = mg->mg_obj;
PUSHMARK(MARK);
- PUTBACK;
+ PUTBACK;
+ ENTER;
perl_call_method("SPLICE",GIMME_V);
+ LEAVE;
SPAGAIN;
RETURN;
}
*MARK-- = mg->mg_obj;
PUSHMARK(MARK);
PUTBACK;
- perl_call_method("PUSH",GIMME_V);
+ ENTER;
+ perl_call_method("PUSH",G_SCALAR|G_DISCARD);
+ LEAVE;
SPAGAIN;
- RETURN;
}
-
- /* Why no pre-extend of ary here ? */
- for (++MARK; MARK <= SP; MARK++) {
- sv = NEWSV(51, 0);
- if (*MARK)
- sv_setsv(sv, *MARK);
- av_push(ary, sv);
+ else {
+ /* Why no pre-extend of ary here ? */
+ for (++MARK; MARK <= SP; MARK++) {
+ sv = NEWSV(51, 0);
+ if (*MARK)
+ sv_setsv(sv, *MARK);
+ av_push(ary, sv);
+ }
}
SP = ORIGMARK;
PUSHi( AvFILL(ary) + 1 );
register I32 i = 0;
MAGIC *mg;
- if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+
+
*MARK-- = mg->mg_obj;
- PUSHMARK(MARK);
PUTBACK;
- perl_call_method("UNSHIFT",GIMME_V);
+ ENTER;
+ perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
+ LEAVE;
SPAGAIN;
- RETURN;
}
-
- av_unshift(ary, SP - MARK);
- while (MARK < SP) {
- sv = NEWSV(27, 0);
- sv_setsv(sv, *++MARK);
- (void)av_store(ary, i++, sv);
+ else {
+ av_unshift(ary, SP - MARK);
+ while (MARK < SP) {
+ sv = NEWSV(27, 0);
+ sv_setsv(sv, *++MARK);
+ (void)av_store(ary, i++, sv);
+ }
}
SP = ORIGMARK;
PUSHi( AvFILL(ary) + 1 );
gv = defoutgv;
if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
if (MARK == ORIGMARK) {
+ /* If using default handle then we need to make space to
+ * pass object as 1st arg, so move other args up ...
+ */
MEXTEND(SP, 1);
++MARK;
Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
djSP;
SV * sv ;
- sv = POPs;
+ sv = POPs;
+
if (dowarn) {
MAGIC * mg ;
stack_grow(SV **sp, SV **p, int n)
{
dTHR;
+#if defined(DEBUGGING) && !defined(USE_THREADS)
+ static int growing = 0;
+ if (growing++)
+ abort();
+#endif
stack_sp = sp;
av_extend(curstack, (p - stack_base) + (n) + 128);
+#if defined(DEBUGGING) && !defined(USE_THREADS)
+ growing--;
+#endif
return stack_sp;
}
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+{
+ package Basic;
+ use Tie::Array;
+ @ISA = qw(Tie::Array);
+
+ sub TIEARRAY { return bless [], shift }
+ sub FETCH { $_[0]->[$_[1]] }
+ sub STORE { $_[0]->[$_[1]] = $_[2] }
+ sub FETCHSIZE { scalar(@{$_[0]}) }
+ sub STORESIZE { $#{$_[0]} = $_[1]-1 }
+}
+
+tie @x,Basic;
+tie @get,Basic;
+tie @got,Basic;
+tie @tests,Basic;
+require "../t/op/push.t"
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Tie::Array;
+tie @foo,Tie::StdArray;
+tie @ary,Tie::StdArray;
+tie @bar,Tie::StdArray;
+require "../t/op/array.t"
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Tie::Array;
+tie @x,Tie::StdArray;
+require "../t/op/push.t"
#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+require Tie::Array;
-package Tie::StdArray;
+package Tie::BasicArray;
+@ISA = 'Tie::Array';
sub TIEARRAY { bless [], $_[0] }
-sub STORE { $_[0]->[$_[1]] = $_[2] }
-sub FETCH { $_[0]->[$_[1]] }
+sub STORE { $_[0]->[$_[1]] = $_[2] }
+sub FETCH { $_[0]->[$_[1]] }
+sub FETCHSIZE { scalar(@{$_[0]})}
+sub STORESIZE { $#{$_[0]} = $_[1]+1 }
package main;
-print "1..4\n";
+print "1..5\n";
$sch = {
'abc' => 1,
$a->{'abc'} = 'ABC';
if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";}
+# quick check with tied array
+tie @fake, 'Tie::BasicArray';
+$a = \@fake;
+$a->[0] = $sch;
+
+$a->{'abc'} = 'ABC';
+if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";}
+
# quick check with tied array & tied hash
-@INC = ("./lib", "../lib");
require Tie::Hash;
tie %fake, Tie::StdHash;
%fake = %$sch;
$a->[0] = \%fake;
$a->{'abc'} = 'ABC';
-if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";}
+if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";}
@x = (1,2,3);
push(@x,@x);
if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
-push(x,4);
+push(@x,4);
if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
$test = 3;
}
}
+1; # this file is require'd by lib/tie-stdpush.t
#!./perl
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
{
$seen{'STORESIZE'}++;
my ($ob,$sz) = @_;
- return @$ob = $sz;
+ return $#{$ob} = $sz-1;
}
sub EXTEND
sub FETCHSIZE
{
$seen{'FETCHSIZE'}++;
- my ($ob) = @_;
- return @$ob-1;
+ return scalar(@{$_[0]});
}
sub FETCH
sub UNSHIFT
{
$seen{'UNSHIFT'}++;
- $ob = shift;
+ my $ob = shift;
unshift(@$ob,@_);
}
sub CLEAR
{
$seen{'CLEAR'}++;
+ @{$_[0]} = ();
+}
+
+sub DESTROY
+{
+ $seen{'DESTROY'}++;
}
sub POP
package main;
-print "1..23\n";
+print "1..29\n";
my $test = 1;
{my @ary;
print "not " unless join(':',@ary) eq '1:7:4';
print "ok ", $test++,"\n";
-
-
print "not " unless shift(@ary) == 1;
print "ok ", $test++,"\n";
print "not " unless $seen{'SHIFT'} == 1;
print "not " unless join(':',@ary) eq '7:4';
print "ok ", $test++,"\n";
-
-unshift(@ary,5);
+my $n = unshift(@ary,5,6);
print "not " unless $seen{'UNSHIFT'} == 1;
print "ok ", $test++,"\n";
-print "not " unless join(':',@ary) eq '5:7:4';
+print "not " unless $n == 4;
+print "ok ", $test++,"\n";
+print "not " unless join(':',@ary) eq '5:6:7:4';
print "ok ", $test++,"\n";
@ary = split(/:/,'1:2:3');
print "not " unless join(':',@ary) eq '1:2:3';
print "ok ", $test++,"\n";
+
+my $t = 0;
+foreach $n (@ary)
+ {
+ print "not " unless $n == ++$t;
+ print "ok ", $test++,"\n";
+ }
+
+@ary = qw(3 2 1);
+print "not " unless join(':',@ary) eq '3:2:1';
+print "ok ", $test++,"\n";
-# untie @ary;
+untie @ary;
}
-
+
+print "not " unless $seen{'DESTROY'} == 1;
+print "ok ", $test++,"\n";
projects / p5sagit/p5-mst-13.2.git / commitdiff