mirror of
https://github.com/Perl/perl5.git
synced 2026-01-26 08:38:23 +00:00
to restore some level of sanity in the tied scalars can of worms. p4raw-id: //depot/perl@16845
This commit is contained in:
Jarkko Hietaniemi
parent
4282de365a
commit
b881518d78
13
mg.c
13
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;
|
||||
|
||||
4
pp_sys.c
4
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);
|
||||
|
||||
24
sv.c
24
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);
|
||||
|
||||
114
t/op/tie.t
114
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;
|
||||
|
||||
undef $/;
|
||||
@prgs = split /^########\n/m, <DATA>;
|
||||
# catch warnings into fatal errors
|
||||
$SIG{__WARN__} = sub { die "WARNING: @_" } ;
|
||||
$SIG{__DIE__} = sub { die @_ };
|
||||
|
||||
undef $/;
|
||||
@prgs = split "\n########\n", <DATA>;
|
||||
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.
|
||||
|
||||
@ -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;
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user