From b881518d78374cbb36c0ad56c39aaca9fc97154d Mon Sep 17 00:00:00 2001 From: Jarkko Hietaniemi Date: Tue, 28 May 2002 22:05:55 +0000 Subject: [PATCH] Retract #16820, #16819, #16810, #16669, #16531, #16530, #16501 to restore some level of sanity in the tied scalars can of worms. p4raw-id: //depot/perl@16845 --- mg.c | 13 +------ pp_sys.c | 4 +- sv.c | 24 ++---------- t/op/tie.t | 112 ++++++++++++++++++++--------------------------------- t/run/fresh_perl.t | 6 +++ 5 files changed, 57 insertions(+), 102 deletions(-) diff --git a/mg.c b/mg.c index 6176034..63de612 100644 --- a/mg.c +++ b/mg.c @@ -359,17 +359,8 @@ Perl_mg_free(pTHX_ SV *sv) else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); } - if (mg->mg_flags & MGf_REFCOUNTED) { - SV *obj = mg->mg_obj; - if (mg->mg_type == PERL_MAGIC_tiedscalar && SvROK(obj) && - (SvRV(obj) == sv || GvIO(SvRV(obj)) == (IO *) sv)) { - /* We are already free'ing the self-tied thing - so must not SvREFCNT_dec. - */ - SvROK_off(obj); - } else - SvREFCNT_dec(obj); - } + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); Safefree(mg); } SvMAGIC(sv) = 0; diff --git a/pp_sys.c b/pp_sys.c index 880c327..c199cf7 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -827,7 +827,9 @@ 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) && how == PERL_MAGIC_tied) + if (varsv == SvRV(sv) && + (SvTYPE(sv) == SVt_PVAV || + SvTYPE(sv) == SVt_PVHV)) Perl_croak(aTHX_ "Self-ties of arrays and hashes are not supported"); sv_magic(varsv, sv, how, Nullch, 0); diff --git a/sv.c b/sv.c index 193b141..8b707f7 100644 --- a/sv.c +++ b/sv.c @@ -3194,7 +3194,7 @@ Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) { SV *tmpsv; - if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) && + if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) && (tmpsv = AMG_CALLun(ssv,string))) { if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) { SvSetSV(dsv,tmpsv); @@ -4461,11 +4461,7 @@ 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. - Note we cannot do this to avoid self-tie loops as intervening RV must - have its REFCNT incremented to keep it in existence - instead special - case them in mg_free(). - */ + avoid incrementing the object refcount. */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || how == PERL_MAGIC_qr || @@ -4479,15 +4475,6 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, else { mg->mg_obj = SvREFCNT_inc(obj); mg->mg_flags |= MGf_REFCOUNTED; - - /* Break self-tie loops */ - if (how == PERL_MAGIC_tiedscalar && SvROK(obj) && - (SvRV(obj) == sv || GvIO(SvRV(obj)) == (IO *) sv)) { - /* We have to have a REFCNT to obj, so drop REFCNT - of what if references instead - */ - SvREFCNT_dec(SvRV(obj)); - } } mg->mg_type = how; mg->mg_len = namlen; @@ -5180,12 +5167,8 @@ Perl_sv_free(pTHX_ SV *sv) return; } ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv)); - if (!refcount_is_zero) { - /* Do not be tempted to test SvMAGIC here till scope.c - stops sharing MAGIC * between SVs - */ + if (!refcount_is_zero) return; - } #ifdef DEBUGGING if (SvTEMP(sv)) { if (ckWARN_d(WARN_DEBUGGING)) @@ -6228,6 +6211,7 @@ SV * Perl_sv_mortalcopy(pTHX_ SV *oldstr) { register SV *sv; + new_SV(sv); sv_setsv(sv,oldstr); EXTEND_MORTAL(1); diff --git a/t/op/tie.t b/t/op/tie.t index d147f6b..f8f2322 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -1,13 +1,9 @@ #!./perl -# Add new tests to the end with format: -# ######## -# -# # test description -# Test code -# EXPECT -# Warn or die msgs (if any) at - line 1234 -# +# This test harness will (eventually) test the "tie" functionality +# without the need for a *DBM* implementation. + +# Currently it only tests the untie warning chdir 't' if -d 't'; @INC = '../lib'; @@ -15,22 +11,29 @@ $ENV{PERL5LIB} = "../lib"; $|=1; +# catch warnings into fatal errors +$SIG{__WARN__} = sub { die "WARNING: @_" } ; +$SIG{__DIE__} = sub { die @_ }; + undef $/; -@prgs = split /^########\n/m, ; +@prgs = split "\n########\n", ; +print "1..", scalar @prgs, "\n"; -require './test.pl'; -plan(tests => scalar @prgs); for (@prgs){ - ++$i; - my($prog,$expected) = split(/\nEXPECT\n/, $_, 2); - print("not ok $i # bad test format\n"), next - unless defined $expected; - my ($testname) = $prog =~ /^# (.*)\n/m; - $testname ||= ''; + my($prog,$expected) = split(/\nEXPECT\n/, $_); + eval "$prog" ; + $status = $?; + $results = $@ ; $results =~ s/\n+$//; $expected =~ s/\n+$//; - - fresh_perl_is($prog, $expected, {}, $testname); + if ( $status or $results and $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 "ok ", ++$i, "\n"; } __END__ @@ -103,7 +106,7 @@ use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; EXPECT -untie attempted while 1 inner references still exist at - line 6. +untie attempted while 1 inner references still exist ######## # strict behaviour, with 1 extra references via tied generating an error @@ -113,7 +116,7 @@ tie %h, Tie::StdHash; $a = tied %h; untie %h; EXPECT -untie attempted while 1 inner references still exist at - line 7. +untie attempted while 1 inner references still exist ######## # strict behaviour, with 1 extra references which are destroyed @@ -135,14 +138,14 @@ 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; $b = tied %h ; untie %h; EXPECT -untie attempted while 2 inner references still exist at - line 7. +untie attempted while 2 inner references still exist ######## # strict behaviour, check scope of strictness. @@ -159,59 +162,29 @@ $C = $B = tied %H ; 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; + my %c = 42; tie %c, 'Self', \%c; } EXPECT -Self-ties of arrays and hashes are not supported at - line 6. +Self-ties of arrays and hashes are not supported ######## - # Allowed scalar self-ties -my $destroyed = 0; +my ($a, $b) = (0, 0); sub Self::TIESCALAR { bless $_[1], $_[0] } -sub Self::DESTROY { $destroyed = 1; } +sub Self::DESTROY { $b = $_[0] + 1; } { my $c = 42; + $a = $c + 0; tie $c, 'Self', \$c; } -die "self-tied scalar not DESTROYd" unless $destroyed == 1; +die unless $a == 0 && $b == 43; 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 -######## - # Interaction of tie and vec my ($a, $b); @@ -224,18 +197,17 @@ vec($b,1,1)=0; die unless $a eq $b; EXPECT ######## +# An attempt at lvalueable barewords broke this + +tie FH, 'main'; +EXPECT +######## # correct unlocalisation of tied hashes (patch #16431) use Tie::Hash ; tie %tied, Tie::StdHash; -{ 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'}; +{ 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'}; EXPECT -######## -# An attempt at lvalueable barewords broke this -tie FH, 'main'; -EXPECT -Can't modify constant item in tie at - line 3, near "'main';" -Execution of - aborted due to compilation errors. diff --git a/t/run/fresh_perl.t b/t/run/fresh_perl.t index 3c0a925..9ed6023 100644 --- a/t/run/fresh_perl.t +++ b/t/run/fresh_perl.t @@ -821,6 +821,12 @@ $人++; # 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; -- 2.7.4