diff options
| -rw-r--r-- | pp_sys.c | 4 | ||||
| -rw-r--r-- | sv.c | 4 | ||||
| -rwxr-xr-x | t/op/tie.t | 55 |
3 files changed, 46 insertions, 17 deletions
@@ -824,9 +824,7 @@ PP(pp_tie) if (sv_isobject(sv)) { sv_unmagic(varsv, how); /* Croak if a self-tie on an aggregate is attempted. */ - if (varsv == SvRV(sv) && - (SvTYPE(sv) == SVt_PVAV || - SvTYPE(sv) == SVt_PVHV)) + if (varsv == SvRV(sv) && how == PERL_MAGIC_tied) Perl_croak(aTHX_ "Self-ties of arrays and hashes are not supported"); sv_magic(varsv, sv, how, Nullch, 0); @@ -4466,7 +4466,9 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, (SvTYPE(obj) == SVt_PVGV && (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || - GvFORM(obj) == (CV*)sv))) + GvFORM(obj) == (CV*)sv)) || + (how == PERL_MAGIC_tiedscalar && + SvROK(obj) && (SvRV(obj) == sv || GvIO(SvRV(obj)) == (IO*)sv))) { mg->mg_obj = obj; } diff --git a/t/op/tie.t b/t/op/tie.t index f8f2322632..ea37cb3a92 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -16,24 +16,32 @@ $SIG{__WARN__} = sub { die "WARNING: @_" } ; $SIG{__DIE__} = sub { die @_ }; undef $/; -@prgs = split "\n########\n", <DATA>; +@prgs = split /^########\n/m, <DATA>; print "1..", scalar @prgs, "\n"; for (@prgs){ - my($prog,$expected) = split(/\nEXPECT\n/, $_); + ++$i; + my($prog,$expected) = split(/\nEXPECT\n/, $_, 2); + print("not ok $i # bad test format\n"), next + unless defined $expected; + my ($testname) = $prog =~ /^(# .*)\n/; + $testname ||= ''; eval "$prog" ; $status = $?; $results = $@ ; $results =~ s/\n+$//; $expected =~ s/\n+$//; - if ( $status or $results and $results !~ /^(WARNING: )?$expected/){ + if ( $status || ($expected eq '') != ($results eq '') || + $results !~ /^(WARNING: )?$expected/){ print STDERR "STATUS: $status\n"; print STDERR "PROG: $prog\n"; print STDERR "EXPECTED:\n$expected\n"; print STDERR "GOT:\n$results\n"; - print "not "; + print "not ok $i $testname\n"; + } + else { + print "ok $i $testname\n"; } - print "ok ", ++$i, "\n"; } __END__ @@ -163,26 +171,47 @@ untie %H; EXPECT ######## # Forbidden aggregate self-ties -my ($a, $b) = (0, 0); sub Self::TIEHASH { bless $_[1], $_[0] } -sub Self::DESTROY { $b = $_[0] + 1; } { - my %c = 42; + my %c; tie %c, 'Self', \%c; } EXPECT Self-ties of arrays and hashes are not supported ######## # Allowed scalar self-ties -my ($a, $b) = (0, 0); +my $destroyed = 0; sub Self::TIESCALAR { bless $_[1], $_[0] } -sub Self::DESTROY { $b = $_[0] + 1; } +sub Self::DESTROY { $destroyed = 1; } { my $c = 42; - $a = $c + 0; tie $c, 'Self', \$c; } -die unless $a == 0 && $b == 43; +die "self-tied scalar not DESTROYd" unless $destroyed == 1; +EXPECT +######## +# Allowed glob self-ties +my $destroyed = 0; +sub Self2::TIEHANDLE { bless $_[1], $_[0] } +sub Self2::DESTROY { $destroyed = 1; } +{ + use Symbol; + my $c = gensym; + tie *$c, 'Self2', $c; +} +die "self-tied glob not DESTROYd" unless $destroyed == 1; +EXPECT +######## +# Allowed IO self-ties +my $destroyed = 0; +sub Self3::TIEHANDLE { bless $_[1], $_[0] } +sub Self3::DESTROY { $destroyed = 1; } +{ + use Symbol 'geniosym'; + my $c = geniosym; + tie *$c, 'Self3', $c; +} +die "self-tied IO not DESTROYd" unless $destroyed == 1; EXPECT ######## # Interaction of tie and vec @@ -197,7 +226,7 @@ vec($b,1,1)=0; die unless $a eq $b; EXPECT ######## -# An attempt at lvalueable barewords broke this +# TODO An attempt at lvalueable barewords broke this tie FH, 'main'; EXPECT |