diff options
| -rw-r--r-- | sv.c | 8 | ||||
| -rwxr-xr-x | t/op/tie.t | 42 | ||||
| -rw-r--r-- | t/run/fresh_perl.t | 6 |
3 files changed, 43 insertions, 13 deletions
@@ -4461,7 +4461,13 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, /* Some magic sontains a reference loop, where the sv and object refer to each other. To prevent a reference loop that would prevent such objects being freed, we look for such loops and if we find one we - avoid incrementing the object refcount. */ + avoid incrementing the object refcount. + + Note we cannot do this to avoid self-tie loops as intervening RV must + have its REFCNT incremented to keep it in existence - instead we could + special case them in sv_free() -- NI-S + + */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || how == PERL_MAGIC_qr || diff --git a/t/op/tie.t b/t/op/tie.t index f8f2322632..914db116a0 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -3,7 +3,7 @@ # This test harness will (eventually) test the "tie" functionality # without the need for a *DBM* implementation. -# Currently it only tests the untie warning +# Currently it only tests the untie warning chdir 't' if -d 't'; @INC = '../lib'; @@ -138,7 +138,7 @@ untie %h; EXPECT ######## -# strict error behaviour, with 2 extra references +# strict error behaviour, with 2 extra references use warnings 'untie'; use Tie::Hash ; $a = tie %h, Tie::StdHash; @@ -171,7 +171,7 @@ sub Self::DESTROY { $b = $_[0] + 1; } tie %c, 'Self', \%c; } EXPECT -Self-ties of arrays and hashes are not supported +Self-ties of arrays and hashes are not supported ######## # Allowed scalar self-ties my ($a, $b) = (0, 0); @@ -206,8 +206,38 @@ EXPECT # correct unlocalisation of tied hashes (patch #16431) use Tie::Hash ; tie %tied, Tie::StdHash; -{ local $hash{'foo'} } print "exist1\n" if exists $hash{'foo'}; -{ local $tied{'foo'} } print "exist2\n" if exists $tied{'foo'}; -{ local $ENV{'foo'} } print "exist3\n" if exists $ENV{'foo'}; +{ local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'}; +{ local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'}; +{ local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'}; EXPECT +######## +# Allowed glob self-ties +my $destroyed = 0; +my $printed = 0; +sub Self2::TIEHANDLE { bless $_[1], $_[0] } +sub Self2::DESTROY { $destroyed = 1; } +sub Self2::PRINT { $printed = 1; } +{ + use Symbol; + my $c = gensym; + tie *$c, 'Self2', $c; + print $c 'Hello'; +} +die "self-tied glob not PRINTed" unless $printed == 1; +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 +######## diff --git a/t/run/fresh_perl.t b/t/run/fresh_perl.t index 9ed6023ba7..3c0a9259ad 100644 --- a/t/run/fresh_perl.t +++ b/t/run/fresh_perl.t @@ -821,12 +821,6 @@ $人++; # a child is born print $人, "\n"; EXPECT 3 -######## -# TODO An attempt at lvalueable barewords broke this -tie FH, 'main'; -EXPECT -Can't modify constant item in tie at - line 2, near "'main';" -Execution of - aborted due to compilation errors. ######## example from Camel 5, ch. 15, pp.406 (with use vars) # SKIP: ord "A" == 193 # EBCDIC use strict; |