[svn:ponie] rev 292 - in trunk: perl perl/ext/B/t perl/t/op src/pmc
[email protected] 24 Jun 2005 15:59:44 -0000
| Newsgroups | perl.ponie.changes |
|---|---|
| Message-ID | <[email protected]> |
Author: nicholas
Date: Fri Jun 24 08:59:43 2005
New Revision: 292
Modified:
trunk/perl/embed.fnc
trunk/perl/embed.h
trunk/perl/ext/B/t/f_sort.t
trunk/perl/ext/B/t/optree_samples.t
trunk/perl/gv.c
trunk/perl/mg.c
trunk/perl/pad.c
trunk/perl/perl.c
trunk/perl/proto.h
trunk/perl/sv.c
trunk/perl/t/op/gv.t
trunk/src/pmc/perl5cargo_cult.pmc
trunk/src/pmc/perl5pvgv.pmc
trunk/src/pmc/perl5rv.pmc
Log:
Merge in 24927 24952 24966 24967 24968 24972 24973 from blead.
(replace the reference count loop between typeglobs and symbol tables with
a weak reference from the typeglob to the symbol table)
Modified: trunk/perl/embed.fnc
==============================================================================
--- trunk/perl/embed.fnc (original)
+++ trunk/perl/embed.fnc Fri Jun 24 08:59:43 2005
@@ -1168,13 +1168,16 @@ s |void |debprof |const OP *o
s |SV* |save_scalar_at |SV **sptr
#endif
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+po |void |sv_add_backref |SV *tsv|SV *sv
+#endif
+
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
s |IV |asIV |SV* sv
s |UV |asUV |SV* sv
s |void |not_a_number |SV *sv
s |I32 |visit |SVFUNC_t f|U32 flags|U32 mask
-s |void |sv_add_backref |SV *tsv|SV *sv
-p |void |sv_del_backref |SV *sv
+p |void |sv_del_backref |SV *target|SV *ref
# if !defined(NV_PRESERVES_UV)
s |int |sv_2iuv_non_preserve |SV *sv|I32 numtype
# endif
Modified: trunk/perl/embed.h
==============================================================================
--- trunk/perl/embed.h (original)
+++ trunk/perl/embed.h Fri Jun 24 08:59:43 2005
@@ -1698,6 +1698,8 @@
#define save_scalar_at S_save_scalar_at
#endif
#endif
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+#endif
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
#define asIV S_asIV
@@ -1712,9 +1714,6 @@
#define visit S_visit
#endif
#ifdef PERL_CORE
-#define sv_add_backref S_sv_add_backref
-#endif
-#ifdef PERL_CORE
#define sv_del_backref Perl_sv_del_backref
#endif
# if !defined(NV_PRESERVES_UV)
@@ -4180,6 +4179,10 @@
#define save_scalar_at(a) S_save_scalar_at(aTHX_ a)
#endif
#endif
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#endif
+#endif
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
#define asIV(a) S_asIV(aTHX_ a)
@@ -4194,10 +4197,7 @@
#define visit(a,b,c) S_visit(aTHX_ a,b,c)
#endif
#ifdef PERL_CORE
-#define sv_add_backref(a,b) S_sv_add_backref(aTHX_ a,b)
-#endif
-#ifdef PERL_CORE
-#define sv_del_backref(a) Perl_sv_del_backref(aTHX_ a)
+#define sv_del_backref(a,b) Perl_sv_del_backref(aTHX_ a,b)
#endif
# if !defined(NV_PRESERVES_UV)
#ifdef PERL_CORE
Modified: trunk/perl/ext/B/t/f_sort.t
==============================================================================
--- trunk/perl/ext/B/t/f_sort.t (original)
+++ trunk/perl/ext/B/t/f_sort.t Fri Jun 24 08:59:43 2005
@@ -104,7 +104,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t5] KS
+# a <2> aassign[t3] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -178,7 +178,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t5] KS
+# a <2> aassign[t3] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -215,7 +215,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t5] KS
+# a <2> aassign[t3] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -252,7 +252,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t5] KS
+# a <2> aassign[t3] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -799,7 +799,7 @@ checkOptree(note => q{},
# d <0> pushmark s
# e <#> gv[*result] s
# f <1> rv2av[t2] lKRM*/1
-# g <2> aassign[t5] KS/COMMON
+# g <2> aassign[t3] KS/COMMON
# h <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 547 (eval 15):1) v
Modified: trunk/perl/ext/B/t/optree_samples.t
==============================================================================
--- trunk/perl/ext/B/t/optree_samples.t (original)
+++ trunk/perl/ext/B/t/optree_samples.t Fri Jun 24 08:59:43 2005
@@ -607,7 +607,7 @@ checkOptree ( name => 'map $_+42, 10..20
# 3 <$> const[AV ] s
# 4 <1> rv2av lKPM/1
# 5 <@> mapstart K
-# 6 <|> mapwhile(other->7)[t7] K
+# 6 <|> mapwhile(other->7)[t5] K
# 7 <#> gvsv[*_] s
# 8 <$> const[IV 42] s
# 9 <2> add[t2] sK/2
Modified: trunk/perl/gv.c
==============================================================================
--- trunk/perl/gv.c (original)
+++ trunk/perl/gv.c Fri Jun 24 08:59:43 2005
@@ -127,7 +127,9 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, co
GvCVGEN(gv) = 0;
GvEGV(gv) = gv;
sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
- GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
+ GvSTASH(gv) = stash;
+ if (stash)
+ Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
if (multi || doproto) /* doproto means it _was_ mentioned */
Modified: trunk/perl/mg.c
==============================================================================
--- trunk/perl/mg.c (original)
+++ trunk/perl/mg.c Fri Jun 24 08:59:43 2005
@@ -1970,22 +1970,37 @@ Perl_vivify_defelem(pTHX_ SV *sv)
int
Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
{
- AV *av = (AV*)mg->mg_obj;
+ AV *const av = (AV*)mg->mg_obj;
SV **svp = AvARRAY(av);
- I32 i = AvFILLp(av);
(void)sv;
- while (i >= 0) {
- if (svp[i]) {
- if (!SvWEAKREF(svp[i]))
- Perl_croak(aTHX_ "panic: magic_killbackrefs");
- /* XXX Should we check that it hasn't changed? */
- SvRV_set(svp[i], 0);
- SvOK_off(svp[i]);
- SvWEAKREF_off(svp[i]);
- svp[i] = Nullsv;
- }
- i--;
+ if (svp) {
+ SV *const *const last = svp + AvFILLp(av);
+
+ while (svp <= last) {
+ if (*svp) {
+ SV *const referrer = *svp;
+ if (SvWEAKREF(referrer)) {
+ /* XXX Should we check that it hasn't changed? */
+ SvRV_set(referrer, 0);
+ SvOK_off(referrer);
+ SvWEAKREF_off(referrer);
+ } else if (SvTYPE(referrer) == SVt_PVGV ||
+ SvTYPE(referrer) == SVt_PVLV) {
+ /* You lookin' at me? */
+ assert(GvSTASH(referrer));
+ assert(GvSTASH(referrer) == (HV*)sv);
+ GvSTASH(referrer) = 0;
+ } else {
+ Perl_croak(aTHX_
+ "panic: magic_killbackrefs (flags=%"UVxf")",
+ SvFLAGS(referrer));
+ }
+
+ *svp = Nullsv;
+ }
+ svp++;
+ }
}
SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
return 0;
Modified: trunk/perl/pad.c
==============================================================================
--- trunk/perl/pad.c (original)
+++ trunk/perl/pad.c Fri Jun 24 08:59:43 2005
@@ -344,7 +344,8 @@ Perl_pad_add_name(pTHX_ const char *name
}
if (ourstash) {
SvPADOUR_on(namesv);
- GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
+ GvSTASH(namesv) = ourstash;
+ Perl_sv_add_backref(aTHX_ (SV*)ourstash, namesv);
}
av_store(PL_comppad_name, offset, namesv);
@@ -1059,8 +1060,15 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool
if (refadjust)
SvREFCNT_dec(PL_curpad[po]);
+
+ /* if pad tmps aren't shared between ops, then there's no need to
+ * create a new tmp when an existing op is freed */
+#ifdef USE_BROKEN_PAD_RESET
PL_curpad[po] = NEWSV(1107,0);
SvPADTMP_on(PL_curpad[po]);
+#else
+ PL_curpad[po] = &PL_sv_undef;
+#endif
if ((I32)po < PL_padix)
PL_padix = po - 1;
}
Modified: trunk/perl/perl.c
==============================================================================
--- trunk/perl/perl.c (original)
+++ trunk/perl/perl.c Fri Jun 24 08:59:43 2005
@@ -640,6 +640,11 @@ perl_destruct(pTHXx)
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
+ /* Do this now, because destroying ops can cause new SVs to be generated
+ in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
+ PL_curcop to point to a valid op from which the filename structure
+ member is copied. */
+ PL_curcop = &PL_compiling;
if (PL_main_root) {
/* ensure comppad/curpad to refer to main's pad */
if (CvPADLIST(PL_main_cv)) {
@@ -648,7 +653,6 @@ perl_destruct(pTHXx)
op_free(PL_main_root);
PL_main_root = Nullop;
}
- PL_curcop = &PL_compiling;
PL_main_start = Nullop;
SvREFCNT_dec(PL_main_cv);
PL_main_cv = Nullcv;
Modified: trunk/perl/proto.h
==============================================================================
--- trunk/perl/proto.h (original)
+++ trunk/perl/proto.h Fri Jun 24 08:59:43 2005
@@ -1120,13 +1120,16 @@ STATIC void S_debprof(pTHX_ const OP *o)
STATIC SV* S_save_scalar_at(pTHX_ SV **sptr);
#endif
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+PERL_CALLCONV void Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv);
+#endif
+
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
STATIC IV S_asIV(pTHX_ SV* sv);
STATIC UV S_asUV(pTHX_ SV* sv);
STATIC void S_not_a_number(pTHX_ SV *sv);
STATIC I32 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask);
-STATIC void S_sv_add_backref(pTHX_ SV *tsv, SV *sv);
-PERL_CALLCONV void Perl_sv_del_backref(pTHX_ SV *sv);
+PERL_CALLCONV void Perl_sv_del_backref(pTHX_ SV *target, SV *ref);
# if !defined(NV_PRESERVES_UV)
STATIC int S_sv_2iuv_non_preserve(pTHX_ SV *sv, I32 numtype);
# endif
Modified: trunk/perl/sv.c
==============================================================================
--- trunk/perl/sv.c (original)
+++ trunk/perl/sv.c Fri Jun 24 08:59:43 2005
@@ -294,20 +294,20 @@ Perl_sv_report_used(pTHX)
/* called by sv_clean_objs() for each live SV */
static void
-do_clean_objs(pTHX_ SV *sv)
+do_clean_objs(pTHX_ SV *ref)
{
- SV* rv;
+ SV* target;
- if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
- if (SvWEAKREF(sv)) {
- sv_del_backref(sv);
- SvWEAKREF_off(sv);
- SvRV_set(sv, NULL);
+ if (SvROK(ref) && SvOBJECT(target = SvRV(ref))) {
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
+ if (SvWEAKREF(ref)) {
+ sv_del_backref(target, ref);
+ SvWEAKREF_off(ref);
+ SvRV_set(ref, NULL);
} else {
- SvROK_off(sv);
- SvRV_set(sv, NULL);
- SvREFCNT_dec(rv);
+ SvROK_off(ref);
+ SvRV_set(ref, NULL);
+ SvREFCNT_dec(target);
}
}
@@ -3252,7 +3252,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, regi
if (dtype != SVt_PVLV)
sv_upgrade(dstr, SVt_PVGV);
sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
- GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
+ GvSTASH(dstr) = GvSTASH(sstr);
+ if (GvSTASH(dstr))
+ Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
GvNAME(dstr) = savepvn(name, len);
GvNAMELEN(dstr) = len;
SvFAKE_on(dstr); /* can coerce to non-glob */
@@ -4628,7 +4630,7 @@ Perl_sv_rvweaken(pTHX_ SV *sv)
return sv;
}
tsv = SvRV(sv);
- sv_add_backref(tsv, sv);
+ Perl_sv_add_backref(aTHX_ tsv, sv);
SvWEAKREF_on(sv);
SvREFCNT_dec(tsv);
return sv;
@@ -4638,8 +4640,8 @@ Perl_sv_rvweaken(pTHX_ SV *sv)
* back-reference to sv onto the array associated with the backref magic.
*/
-STATIC void
-S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
+void
+Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
{
AV *av;
MAGIC *mg;
@@ -4670,13 +4672,16 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
*/
void
-Perl_sv_del_backref(pTHX_ SV *sv)
+Perl_sv_del_backref(pTHX_ SV *tsv, SV *sv)
{
AV *av;
SV **svp;
I32 i;
- SV *tsv = SvRV(sv);
MAGIC *mg = NULL;
+ if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
+ if (PL_in_clean_all)
+ return;
+ }
if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
@@ -7478,24 +7483,24 @@ See C<SvROK_off>.
*/
void
-Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
+Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
{
- SV* rv = SvRV(sv);
+ SV* target = SvRV(ref);
- if (SvWEAKREF(sv)) {
- sv_del_backref(sv);
- SvWEAKREF_off(sv);
- SvRV_set(sv, NULL);
+ if (SvWEAKREF(ref)) {
+ sv_del_backref(target, ref);
+ SvWEAKREF_off(ref);
+ SvRV_set(ref, NULL);
return;
}
- SvRV_set(sv, NULL);
- SvROK_off(sv);
- /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
+ SvRV_set(ref, NULL);
+ SvROK_off(ref);
+ /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
assigned to as BEGIN {$a = \"Foo"} will fail. */
- if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
- SvREFCNT_dec(rv);
+ if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
+ SvREFCNT_dec(target);
else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
- sv_2mortal(rv); /* Schedule for freeing later */
+ sv_2mortal(target); /* Schedule for freeing later */
}
/*
@@ -9636,7 +9641,9 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
GvNAMELEN(dstr) = GvNAMELEN(sstr);
GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
- GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
+ GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
+ /* Don't call sv_add_backref here as it's going to be created
+ as part of the magic cloning of the symbol table. */
GvFLAGS(dstr) = GvFLAGS(sstr);
GvGP(dstr) = gp_dup(GvGP(sstr), param);
(void)GpREFCNT_inc(GvGP(dstr));
Modified: trunk/perl/t/op/gv.t
==============================================================================
--- trunk/perl/t/op/gv.t (original)
+++ trunk/perl/t/op/gv.t Fri Jun 24 08:59:43 2005
@@ -7,46 +7,44 @@
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
-}
+}
use warnings;
-print "1..52\n";
+require './test.pl';
+plan( tests => 68 );
# type coersion on assignment
$foo = 'foo';
$bar = *main::foo;
$bar = $foo;
-print ref(\$bar) eq 'SCALAR' ? "ok 1\n" : "not ok 1\n";
+is(ref(\$bar), 'SCALAR');
$foo = *main::bar;
# type coersion (not) on misc ops
-if ($foo) {
- print ref(\$foo) eq 'GLOB' ? "ok 2\n" : "not ok 2\n";
-}
+ok($foo);
+is(ref(\$foo), 'GLOB');
-unless ($foo =~ /abcd/) {
- print ref(\$foo) eq 'GLOB' ? "ok 3\n" : "not ok 3\n";
-}
+unlike ($foo, qr/abcd/);
+is(ref(\$foo), 'GLOB');
-if ($foo eq '*main::bar') {
- print ref(\$foo) eq 'GLOB' ? "ok 4\n" : "not ok 4\n";
-}
+is($foo, '*main::bar');
+is(ref(\$foo), 'GLOB');
# type coersion on substitutions that match
$a = *main::foo;
$b = $a;
$a =~ s/^X//;
-print ref(\$a) eq 'GLOB' ? "ok 5\n" : "not ok 5\n";
+is(ref(\$a), 'GLOB');
$a =~ s/^\*//;
-print $a eq 'main::foo' ? "ok 6\n" : "not ok 6\n";
-print ref(\$b) eq 'GLOB' ? "ok 7\n" : "not ok 7\n";
+is($a, 'main::foo');
+is(ref(\$b), 'GLOB');
# typeglobs as lvalues
substr($foo, 0, 1) = "XXX";
-print ref(\$foo) eq 'SCALAR' ? "ok 8\n" : "not ok 8\n";
-print $foo eq 'XXXmain::bar' ? "ok 9\n" : "not ok 9\n";
+is(ref(\$foo), 'SCALAR');
+is($foo, 'XXXmain::bar');
# returning glob values
sub foo {
@@ -56,13 +54,12 @@ sub foo {
}
($fuu, $baa) = foo();
-if (defined $fuu) {
- print ref(\$fuu) eq 'GLOB' ? "ok 10\n" : "not ok 10\n";
-}
+ok(defined $fuu);
+is(ref(\$fuu), 'GLOB');
-if (defined $baa) {
- print ref(\$baa) eq 'GLOB' ? "ok 11\n" : "not ok 11\n";
-}
+
+ok(defined $baa);
+is(ref(\$baa), 'GLOB');
# nested package globs
# NOTE: It's probably OK if these semantics change, because the
@@ -70,127 +67,131 @@ if (defined $baa) {
# (I hope.)
{ package Foo::Bar; no warnings 'once'; $test=1; }
-print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n";
-print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n";
+ok(exists $Foo::{'Bar::'});
+is($Foo::{'Bar::'}, '*Foo::Bar::');
+
# test undef operator clearing out entire glob
$foo = 'stuff';
@foo = qw(more stuff);
%foo = qw(even more random stuff);
undef *foo;
-print +($foo || @foo || %foo) ? "not ok" : "ok", " 14\n";
+is ($foo, undef);
+is (scalar @foo, 0);
+is (scalar %foo, 0);
-# test warnings from assignment of undef to glob
{
- my $msg;
+ # test warnings from assignment of undef to glob
+ my $msg = '';
local $SIG{__WARN__} = sub { $msg = $_[0] };
use warnings;
*foo = 'bar';
- print $msg ? "not ok" : "ok", " 15\n";
+ is($msg, '');
*foo = undef;
- print $msg ? "ok" : "not ok", " 16\n";
+ like($msg, qr/Undefined value assigned to typeglob/);
}
+my $test = curr_test();
# test *glob{THING} syntax
-$x = "ok 17\n";
-@x = ("ok 18\n");
-%x = ("ok 19" => "\n");
-sub x { "ok 20\n" }
+$x = "ok $test\n";
+++$test;
+@x = ("ok $test\n");
+++$test;
+%x = ("ok $test" => "\n");
+++$test;
+sub x { "ok $test\n" }
print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
+# This needs to go here, after the print, as sub x will return the current
+# value of test
+++$test;
format x =
-ok 21
+XXX This text isn't used. Should it be?
.
-print ref *x{FORMAT} eq "FORMAT" ? "ok 21\n" : "not ok 21\n";
+curr_test($test);
+
+is (ref *x{FORMAT}, "FORMAT");
*x = *STDOUT;
-print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 22\n" : "not ok 22\n";
-print {*x{IO}} "ok 23\n";
+is (*{*x{GLOB}}, "*main::STDOUT");
{
- my $warn;
- local $SIG{__WARN__} = sub {
- $warn .= $_[0];
- };
- my $val = *x{FILEHANDLE};
- print {*x{IO}} ($warn =~ /is deprecated/ ? "ok 24\n" : "not ok 24\n");
-
+ my $test = curr_test();
+
+ print {*x{IO}} "ok $test\n";
+ ++$test;
+
+ my $warn;
+ local $SIG{__WARN__} = sub {
+ $warn .= $_[0];
+ };
+ my $val = *x{FILEHANDLE};
+ print {*x{IO}} ($warn =~ /is deprecated/
+ ? "ok $test\n" : "not ok $test\n");
+ curr_test(++$test);
}
-# test if defined() doesn't create any new symbols
{
- my $test = 24;
+ # test if defined() doesn't create any new symbols
my $a = "SYM000";
- print "not " if defined *{$a};
- ++$test; print "ok $test\n";
-
- print "not " if defined @{$a} or defined *{$a};
- ++$test; print "ok $test\n";
-
- print "not " if defined %{$a} or defined *{$a};
- ++$test; print "ok $test\n";
+ ok(!defined *{$a});
- print "not " if defined ${$a} or defined *{$a};
- ++$test; print "ok $test\n";
+ ok(!defined @{$a});
+ ok(!defined *{$a});
- print "not " if defined &{$a} or defined *{$a};
- ++$test; print "ok $test\n";
+ ok(!defined %{$a});
+ ok(!defined *{$a});
- *{$a} = sub { print "ok $test\n" };
- print "not " unless defined &{$a} and defined *{$a};
- ++$test; &{$a};
+ ok(!defined ${$a});
+ ok(!defined *{$a});
+
+ ok(!defined &{$a});
+ ok(!defined *{$a});
+
+ my $state = "not";
+ *{$a} = sub { $state = "ok" };
+ ok(defined &{$a});
+ ok(defined *{$a});
+ &{$a};
+ is ($state, 'ok');
}
-# although it *should* if you're talking about magicals
-
{
- my $test = 30;
+ # although it *should* if you're talking about magicals
my $a = "]";
- print "not " unless defined ${$a};
- ++$test; print "ok $test\n";
- print "not " unless defined *{$a};
- ++$test; print "ok $test\n";
+ ok(defined ${$a});
+ ok(defined *{$a});
$a = "1";
"o" =~ /(o)/;
- print "not " unless ${$a};
- ++$test; print "ok $test\n";
- print "not " unless defined *{$a};
- ++$test; print "ok $test\n";
+ ok(${$a});
+ ok(defined *{$a});
$a = "2";
- print "not " if ${$a};
- ++$test; print "ok $test\n";
- print "not " unless defined *{$a};
- ++$test; print "ok $test\n";
+ ok(!${$a});
+ ok(defined *{$a});
$a = "1x";
- print "not " if defined ${$a};
- ++$test; print "ok $test\n";
- print "not " if defined *{$a};
- ++$test; print "ok $test\n";
+ ok(!defined ${$a});
+ ok(!defined *{$a});
$a = "11";
"o" =~ /(((((((((((o)))))))))))/;
- print "not " unless ${$a};
- ++$test; print "ok $test\n";
- print "not " unless defined *{$a};
- ++$test; print "ok $test\n";
+ ok(${$a});
+ ok(defined *{$a});
}
-
# [ID 20010526.001] localized glob loses value when assigned to
$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
-print $j == 1 ? "ok 41\n" : "not ok 41\n";
-print $j{a} == 1 ? "ok 42\n" : "not ok 42\n";
-print $j[0] == 1 ? "ok 43\n" : "not ok 43\n";
-
-# does pp_readline() handle glob-ness correctly?
+is($j, 1);
+is($j{a}, 1);
+is($j[0], 1);
{
+ # does pp_readline() handle glob-ness correctly?
my $g = *foo;
$g = <DATA>;
- print $g;
+ is ($g, "Perl\n");
}
{
@@ -198,14 +199,14 @@ print $j[0] == 1 ? "ok 43\n" : "not ok 4
$SIG{__WARN__} = sub { $w = $_[0] };
sub abc1 ();
local *abc1 = sub { };
- print $w eq '' ? "ok 45\n" : "not ok 45\n# $w";
+ is ($w, '');
sub abc2 ();
local *abc2;
*abc2 = sub { };
- print $w eq '' ? "ok 46\n" : "not ok 46\n# $w";
+ is ($w, '');
sub abc3 ();
*abc3 = sub { };
- print $w =~ /Prototype mismatch/ ? "ok 47\n" : "not ok 47\n# $w";
+ like ($w, qr/Prototype mismatch/);
}
{
@@ -214,7 +215,7 @@ print $j[0] == 1 ? "ok 43\n" : "not ok 4
my $x = "not ";
$x = undef;
$x .= <DATA>;
- print $x;
+ is ($x, "Rules\n");
}
{
@@ -224,26 +225,45 @@ print $j[0] == 1 ? "ok 43\n" : "not ok 4
my $v;
sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
f($v);
- print $v eq '*main::DATA' ? "ok 49\n" : "not ok 49\n# $e";
+ is ($v, '*main::DATA');
my $x = <$v>;
- print $x || "not ok 50\n";
+ is ($x, "perl\n");
}
-{
+{
+ $e = '';
# GLOB assignment to tied element
local $SIG{__DIE__} = sub { $e = $_[0] };
- sub T::TIEARRAY { bless [] => "T" }
- sub T::STORE { $_[0]->[ $_[1] ] = $_[2] }
- sub T::FETCH { $_[0]->[ $_[1] ] }
+ sub T::TIEARRAY { bless [] => "T" }
+ sub T::STORE { $_[0]->[ $_[1] ] = $_[2] }
+ sub T::FETCH { $_[0]->[ $_[1] ] }
+ sub T::FETCHSIZE { @{$_[0]} }
tie my @ary => "T";
$ary[0] = *DATA;
- print $ary[0] eq '*main::DATA' ? "ok 51\n" : "not ok 51\n# $e";
+ is ($ary[0], '*main::DATA');
+ is ($e, '');
my $x = readline $ary[0];
- print $x || "not ok 52\n";
+ is($x, "rocks\n");
}
+{
+ # Need some sort of die or warn to get the global destruction text if the
+ # bug is still present
+ my $output = runperl(prog => <<'EOPROG');
+package M;
+$| = 1;
+sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
+package main;
+
+bless \$A::B, 'M';
+*A:: = \*B::;
+EOPROG
+ like($output, qr/^Farewell M=SCALAR/, "DESTROY was called");
+ unlike($output, qr/global destruction/,
+ "unreferenced symbol tables should be cleaned up immediately");
+}
__END__
-ok 44
-ok 48
-ok 50
-ok 52
+Perl
+Rules
+perl
+rocks
Modified: trunk/src/pmc/perl5cargo_cult.pmc
==============================================================================
--- trunk/src/pmc/perl5cargo_cult.pmc (original)
+++ trunk/src/pmc/perl5cargo_cult.pmc Fri Jun 24 08:59:43 2005
@@ -25,10 +25,11 @@ void Ponie_freescalar_common(SV *sv) {
misreading the IVX. */
SvOOK_off(sv);
if (SvROK(sv)) {
- if (SvWEAKREF(sv))
- Perl_sv_del_backref(sv);
- else
- SvREFCNT_dec(SvRV(sv));
+ SV *target = SvRV(sv);
+ if (SvWEAKREF(sv))
+ Perl_sv_del_backref(aTHX_ target, sv);
+ else
+ SvREFCNT_dec(target);
}
else if (SvANY(sv)) {
if (SvPVX(sv) && SvLEN(sv))
Modified: trunk/src/pmc/perl5pvgv.pmc
==============================================================================
--- trunk/src/pmc/perl5pvgv.pmc (original)
+++ trunk/src/pmc/perl5pvgv.pmc Fri Jun 24 08:59:43 2005
@@ -86,7 +86,7 @@ pmclass Perl5PVGV extends Perl5PVMG dynp
if (GvGP(sv))
gp_free((GV*)sv);
if (GvSTASH(sv)) {
- SvREFCNT_dec(GvSTASH(sv));
+ Perl_sv_del_backref(aTHX_ (SV*)GvSTASH(sv), sv);
GvSTASH(sv) = Nullhv;
}
sv_unmagic(sv, PERL_MAGIC_glob);
@@ -143,7 +143,7 @@ pmclass Perl5PVGV extends Perl5PVMG dynp
/* decrease refcount of the stash that owns this GV, if any */
if (stash)
- SvREFCNT_dec(stash);
+ Perl_sv_del_backref(aTHX_ (SV*)stash, sv);
break;
}
default:
Modified: trunk/src/pmc/perl5rv.pmc
==============================================================================
--- trunk/src/pmc/perl5rv.pmc (original)
+++ trunk/src/pmc/perl5rv.pmc Fri Jun 24 08:59:43 2005
@@ -42,15 +42,14 @@ pmclass Perl5RV extends Perl5base dynpmc
case Ponie_P_CLEAR:
{
SV *sv = MUMBLE(SELF);
+ SV *target = SvRV(sv);
assert(SvANY(sv) == 0);
- if (SvROK(sv)) {
- if (SvWEAKREF(sv))
- Perl_sv_del_backref(sv);
- else
- SvREFCNT_dec(SvRV(sv));
- }
+ if (SvWEAKREF(sv))
+ Perl_sv_del_backref(aTHX_ target, sv);
+ else
+ SvREFCNT_dec(target);
Parrot_PMC_set_intval_intkey(PL_Parrot,SELF,
Ponie_I_SV_ZERO_FLAGS_SET_TYPEMASK_BREAK_DEAD,