From: Nick Ing-Simmons Date: Wed, 14 Jan 1998 18:49:25 +0000 (+0000) Subject: TIEARRAY updates - almost works ... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a60c0954410db87be540ee8439afcd54350bbb8e;p=p5sagit%2Fp5-mst-13.2.git TIEARRAY updates - almost works ... p4raw-id: //depot/ansiperl@424 --- diff --git a/MANIFEST b/MANIFEST index 07a4742..f09a241 100644 --- a/MANIFEST +++ b/MANIFEST @@ -736,7 +736,9 @@ t/lib/soundex.t See if Soundex works 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 diff --git a/av.c b/av.c index e715d10..5925a17 100644 --- a/av.c +++ b/av.c @@ -56,7 +56,7 @@ av_extend(AV *av, I32 key) 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; @@ -321,7 +321,7 @@ av_clear(register AV *av) warn("Attempt to clear deleted array"); } #endif - if (!av || AvMAX(av) < 0) + if (!av) return; /*SUPPRESS 560*/ @@ -329,6 +329,9 @@ av_clear(register AV *av) if (SvRMAGICAL(av)) mg_clear((SV*)av); + if (AvMAX(av) < 0) + return; + if (AvREAL(av)) { ary = AvARRAY(av); key = AvFILLp(av) + 1; @@ -389,8 +392,10 @@ av_push(register AV *av, SV *val) 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); @@ -410,12 +415,14 @@ av_pop(register AV *av) 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)]; @@ -446,7 +453,9 @@ av_unshift(register AV *av, register I32 num) PUSHs(&sv_undef); } PUTBACK; + ENTER; perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD); + LEAVE; return; } @@ -495,12 +504,14 @@ av_shift(register AV *av) 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); @@ -535,7 +546,7 @@ av_fill(register AV *av, I32 fill) 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; diff --git a/av.h b/av.h index fd34cb0..8de81f4 100644 --- a/av.h +++ b/av.h @@ -47,6 +47,5 @@ struct xpvav { #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)) diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 4e7f0c6..8124643 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -191,11 +191,7 @@ require DynaLoader; ); -sub FETCHSIZE -{ - my $self = shift ; - return $self->length - 1; -} +*FETCHSIZE = \&length; sub AUTOLOAD { my($constname); diff --git a/lib/Tie/Array.pm b/lib/Tie/Array.pm index c3ddfa9..336e003 100644 --- a/lib/Tie/Array.pm +++ b/lib/Tie/Array.pm @@ -1,6 +1,103 @@ -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; @@ -12,29 +109,154 @@ Tie::Array - base class for tied arrays =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 for a list of the functions required in order to tie an array +to a package. The basic B package provides stub C +and C methods, and implementations of C, C, C, +C, C and C in terms of basic C, C, +C, C. + +The B package provides efficient methods required for tied arrays +which are implemented as blessed references to an "inner" perl array. +It inherits from B, 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 section for more detailed +descriptive, as well as example code: + +=over + +=item TIEARRAY classname, LIST + +The class method is invoked by the command C. Associates +an array instance with the specified class. C would represent +additional arguments (along the lines of L 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 into I for the tied array assoicated with +object I. If this makes the array larger then +class's mapping of C should be returned for new positions. + +=item FETCH this, index + +Retrieve the datum in I for the tied array assoicated with +object I. + +=item FETCHSIZE this + +Returns the total number of items in the tied array assoicated with +object I. (Equivalent to C). +=item STORESIZE this, count + +Sets the total number of items in the tied array assoicated with +object I to be I. If this makes the array larger then +class's mapping of C 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 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. + +=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 on the array. + +I is optional and defaults to zero, negative values count back +from the end of the array. + +I is optional and defaults to rest of the array. + +I may be empty. + +Returns a list of the original I elements at I. + +=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 Enik@tiuk.ti.comE =cut diff --git a/mg.c b/mg.c index 289dd3b..af2dddc 100644 --- a/mg.c +++ b/mg.c @@ -1009,8 +1009,10 @@ magic_getpack(SV *sv, MAGIC *mg) int magic_setpack(SV *sv, MAGIC *mg) -{ +{ + ENTER; magic_methcall(mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); + LEAVE; return 0; } @@ -1031,7 +1033,7 @@ magic_sizepack(SV *sv, MAGIC *mg) SAVETMPS; if (magic_methcall(mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { sv = *stack_sp--; - retval = (U32) SvIV(sv); + retval = (U32) SvIV(sv)-1; } FREETMPS; LEAVE; @@ -1045,9 +1047,9 @@ int magic_wipepack(SV *sv, MAGIC *mg) PUSHMARK(sp); XPUSHs(mg->mg_obj); PUTBACK; - + ENTER; perl_call_method("CLEAR", G_SCALAR|G_DISCARD); - + LEAVE; return 0; } diff --git a/pod/perltie.pod b/pod/perltie.pod index c6eb715..79a749e 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -180,17 +180,26 @@ TIESCALAR classes are certainly possible. =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: Tied arrays are I. 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 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 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. The example below needs +upgrading to illustrate this. (The documentation in B 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; diff --git a/pp.c b/pp.c index 3d02b09..b6b3065 100644 --- a/pp.c +++ b/pp.c @@ -2460,8 +2460,10 @@ PP(pp_splice) 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; } @@ -2658,17 +2660,19 @@ PP(pp_push) *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 ); @@ -2708,20 +2712,23 @@ PP(pp_unshift) 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 ); diff --git a/pp_hot.c b/pp_hot.c index 0462886..5bff1a1 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -297,6 +297,9 @@ PP(pp_print) 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*); diff --git a/pp_sys.c b/pp_sys.c index 85ac711..67cae15 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -590,7 +590,8 @@ PP(pp_untie) djSP; SV * sv ; - sv = POPs; + sv = POPs; + if (dowarn) { MAGIC * mg ; diff --git a/scope.c b/scope.c index 3b4428f..bca1c2b 100644 --- a/scope.c +++ b/scope.c @@ -19,8 +19,16 @@ SV** 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; } diff --git a/t/lib/tie-push.t b/t/lib/tie-push.t new file mode 100755 index 0000000..dd718de --- /dev/null +++ b/t/lib/tie-push.t @@ -0,0 +1,24 @@ +#!./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" diff --git a/t/lib/tie-stdarray.t b/t/lib/tie-stdarray.t new file mode 100755 index 0000000..7ca4d76 --- /dev/null +++ b/t/lib/tie-stdarray.t @@ -0,0 +1,12 @@ +#!./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" diff --git a/t/lib/tie-stdpush.t b/t/lib/tie-stdpush.t new file mode 100755 index 0000000..34a6947 --- /dev/null +++ b/t/lib/tie-stdpush.t @@ -0,0 +1,10 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Tie::Array; +tie @x,Tie::StdArray; +require "../t/op/push.t" diff --git a/t/op/avhv.t b/t/op/avhv.t index 0390429..a7ce58a 100755 --- a/t/op/avhv.t +++ b/t/op/avhv.t @@ -1,13 +1,23 @@ #!./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, @@ -48,12 +58,19 @@ $a->[0] = $sch; $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";} diff --git a/t/op/push.t b/t/op/push.t index 68fab66..f62a4e9 100755 --- a/t/op/push.t +++ b/t/op/push.t @@ -22,7 +22,7 @@ die "blech" unless @tests; @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; @@ -47,3 +47,4 @@ foreach $line (@tests) { } } +1; # this file is require'd by lib/tie-stdpush.t diff --git a/t/op/tiearray.t b/t/op/tiearray.t index 045891d..da25760 100755 --- a/t/op/tiearray.t +++ b/t/op/tiearray.t @@ -1,5 +1,6 @@ #!./perl + BEGIN { chdir 't' if -d 't'; @INC = '../lib'; @@ -20,7 +21,7 @@ sub STORESIZE { $seen{'STORESIZE'}++; my ($ob,$sz) = @_; - return @$ob = $sz; + return $#{$ob} = $sz-1; } sub EXTEND @@ -33,8 +34,7 @@ sub EXTEND sub FETCHSIZE { $seen{'FETCHSIZE'}++; - my ($ob) = @_; - return @$ob-1; + return scalar(@{$_[0]}); } sub FETCH @@ -54,7 +54,7 @@ sub STORE sub UNSHIFT { $seen{'UNSHIFT'}++; - $ob = shift; + my $ob = shift; unshift(@$ob,@_); } @@ -68,6 +68,12 @@ sub PUSH sub CLEAR { $seen{'CLEAR'}++; + @{$_[0]} = (); +} + +sub DESTROY +{ + $seen{'DESTROY'}++; } sub POP @@ -95,7 +101,7 @@ sub SPLICE package main; -print "1..23\n"; +print "1..29\n"; my $test = 1; {my @ary; @@ -154,8 +160,6 @@ print "ok ", $test++,"\n"; 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; @@ -163,21 +167,35 @@ print "ok ", $test++,"\n"; 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";