Change 29132 by nicholas@nicholas-saigo on 2006/10/29 19:16:37
Integrate:
[ 25808]
Subject: Re: [PATCH] Re: [perl #37350] $#{@$aref} in debugger gives: Bizarre copy of ARRAY in leave
From: Robin Houston <robin (AT) cpan (DOT) org>
Date: 14, 2005 1:54 AM
Message-ID: <20051013235457.GA23386 (AT) rpc142 (DOT) cs.man.ac.uk>
Affected files
//depot/maint-5.8/perl/embed.fnc#154 integrate
//depot/maint-5.8/perl/embed.h#116 integrate
//#48 integrate
//depot/maint-5.8/perl/mathoms.c#14 edit
//depot/maint-5.8/perl/op.c#139 edit
//depot/maint-5.8/perl/op.h#27 integrate
//depot/maint-5.8/perl/proto.h#143 integrate
//#8 edit
Differences
//depot/maint-5.8/perl/embed.fnc#154 (text)
Index: perl/embed.fnc
perl/embed.fnc#153~29013~2006-10-14 08:13:34.000000000 -0700
perl/embed.fnc2006-10-29 11:16:37.000000000 -0800
@@ -607,6 +607,7 @@
Apd|I32|call_pv|NN const char* sub_name|I32 flags
Apd|I32|call_sv|NN SV* sv|I32 flags
Ap|void|despatch_signals
+Ap|P *|doref|NN P *o|I32 type|bool set_op_ref
Apd|SV*|eval_pv|NN const char* p|I32 croak_on_error
Apd|I32|eval_sv|NN SV* sv|I32 flags
Apd|SV*|get_sv|NN const char* name|I32 create
@@ -634,7 +635,7 @@
p|P*|prepend_elem|I32 optype|NULLK P* head|NULLK P* tail
p|void|push_return|NULLK P* o
Ap|void|push_scope
-p|P*|ref|NULLK P* o|I32 type
+Amb|P*|ref|NULLK P* o|I32 type
p|P*|refkids|NULLK P* o|I32 type
Ap|void|regdump|NN regexp* r
Ap|SV*|regclass_swash|NN struct regnode *n|bool doinit|NULLK SV **listsvp|NULLK SV **altsvp
//depot/maint-5.8/perl/embed.h#116 (text+w)
Index: perl/embed.h
perl/embed.h#115~28199~2006-05-15 09:20:18.000000000 -0700
perl/embed.h2006-10-29 11:16:37.000000000 -0800
@@ -630,6 +630,7 @@
#define call_pvPerl_call_pv
#define call_svPerl_call_sv
#define despatch_signalsPerl_despatch_signals
+#define dorefPerl_doref
#define eval_pvPerl_eval_pv
#define eval_svPerl_eval_sv
#define get_svPerl_get_sv
@@ -663,7 +664,6 @@
#endif
#define push_scopePerl_push_scope
#ifdef PERL_CRE
-#define refPerl_ref
#define refkidsPerl_refkids
#endif
#define regdumpPerl_regdump
@@ -1639,11 +1639,6 @@
#ifdef PERL_CRE
#define my_swabnPerl_my_swabn
#endif
-#define gv_fetchpvn_flagsPerl_gv_fetchpvn_flags
-#define gv_fetchsvPerl_gv_fetchsv
-#ifdef PERL_CRE
-#define is_gv_magical_svPerl_is_gv_magical_sv
-#endif
#if defined(PERL_INP_C) || defined(PERL_DECL_PRT)
#define ck_anoncodePerl_ck_anoncode
#define ck_bitopPerl_ck_bitop
@@ -1702,6 +1697,11 @@
#ifdef PERL_CRE
#define my_clearenvPerl_my_clearenv
#endif
+#define gv_fetchpvn_flagsPerl_gv_fetchpvn_flags
+#define gv_fetchsvPerl_gv_fetchsv
+#ifdef PERL_CRE
+#define is_gv_magical_svPerl_is_gv_magical_sv
+#endif
#ifndef SPRINTF_RETURNS_STRLEN
#endif
#define ck_anoncodePerl_ck_anoncode
@@ -2674,6 +2674,7 @@
#define call_pv(a,b)Perl_call_pv(aTHX_ a,b)
#define call_sv(a,b)Perl_call_sv(aTHX_ a,b)
#define despatch_signals()Perl_despatch_signals(aTHX)
+#define doref(a,b,c)Perl_doref(aTHX_ a,b,c)
#define eval_pv(a,b)Perl_eval_pv(aTHX_ a,b)
#define eval_sv(a,b)Perl_eval_sv(aTHX_ a,b)
#define get_sv(a,b)Perl_get_sv(aTHX_ a,b)
@@ -2707,7 +2708,6 @@
#endif
#define push_scope()Perl_push_scope(aTHX)
#ifdef PERL_CRE
-#define ref(a,b)Perl_ref(aTHX_ a,b)
#define refkids(a,b)Perl_refkids(aTHX_ a,b)
#endif
#define regdump(a)Perl_regdump(aTHX_ a)
@@ -3678,11 +3678,6 @@
#ifdef PERL_CRE
#define my_swabnPerl_my_swabn
#endif
-#define gv_fetchpvn_flags(a,b,c,d)Perl_gv_fetchpvn_flags(aTHX_ a,b,c,d)
-#define gv_fetchsv(a,b,c)Perl_gv_fetchsv(aTHX_ a,b,c)
-#ifdef PERL_CRE
-#define is_gv_magical_sv(a,b)Perl_is_gv_magical_sv(aTHX_ a,b)
-#endif
#if defined(PERL_INP_C) || defined(PERL_DECL_PRT)
#define ck_anoncode(a)Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a)Perl_ck_bitop(aTHX_ a)
@@ -3741,6 +3736,11 @@
#ifdef PERL_CRE
#define my_clearenv()Perl_my_clearenv(aTHX)
#endif
+#define gv_fetchpvn_flags(a,b,c,d)Perl_gv_fetchpvn_flags(aTHX_ a,b,c,d)
+#define gv_fetchsv(a,b,c)Perl_gv_fetchsv(aTHX_ a,b,c)
+#ifdef PERL_CRE
+#define is_gv_magical_sv(a,b)Perl_is_gv_magical_sv(aTHX_ a,b)
+#endif
#ifndef SPRINTF_RETURNS_STRLEN
#endif
#define ck_anoncode(a)Perl_ck_anoncode(aTHX_ a)
//#48 (text+w)
Index: perl/global.sym
perl/global.sym#47~28158~2006-05-11 03:36:47.000000000 -0700
perl/global.sym2006-10-29 11:16:37.000000000 -0800
@@ -346,6 +346,7 @@
Perl_call_pv
Perl_call_sv
Perl_despatch_signals
+Perl_doref
Perl_eval_pv
Perl_eval_sv
Perl_get_sv
@@ -366,6 +367,7 @@
Perl_pmflag
Perl_pop_scope
Perl_push_scope
+Perl_ref
Perl_regdump
Perl_regclass_swash
Perl_pregexec
//depot/maint-5.8/perl/mathoms.c#14 (text)
Index: perl/mathoms.c
perl/mathoms.c#13~28128~2006-05-08 12:22:03.000000000 -0700
perl/mathoms.c2006-10-29 11:16:37.000000000 -0800
@@ -29,7 +29,6 @@
#define PERL_IN_MATHMS_C
#include "perl.h"
-#if 0
/* ref() is now a macro using Perl_doref;
* this version provided for binary compatibility only.
*/
@@ -38,7 +37,6 @@
{
return doref(o, type, TRUE);
}
-#endif
/*
=for apidoc sv_unref
//depot/maint-5.8/perl/op.c#139 (text)
Index: perl/op.c
perl/op.c#138~29021~2006-10-15 02:22:52.000000000 -0700
perl/op.c2006-10-29 11:16:37.000000000 -0800
@@ -1453,7 +1453,7 @@
}
P *
-Perl_ref(pTHX_ P *o, I32 type)
+Perl_doref(pTHX_ P *o, I32 type, bool set_op_ref)
{
P *kid;
@@ -1474,12 +1474,12 @@
case P_CND_EXPR:
for (kid = cUNPo->op_first->op_sibling; kid; kid = kid->op_sibling)
- ref(kid, type);
+ doref(kid, type, set_op_ref);
break;
case P_RV2SV:
if (type == P_DEFINED)
o->op_flags |= Pf_SPECIAL;/* don't create GV */
-ref(cUNPo->op_first, o->op_type);
+doref(cUNPo->op_first, o->op_type, set_op_ref);
/* FALL THRUGH */
case P_PADSV:
if (type == P_RV2SV || type == P_RV2AV || type == P_RV2HV) {
@@ -1496,28 +1496,30 @@
case P_RV2AV:
case P_RV2HV:
-o->op_flags |= Pf_REF;
+if (set_op_ref)
+ o->op_flags |= Pf_REF;
/* FALL THRUGH */
case P_RV2GV:
if (type == P_DEFINED)
o->op_flags |= Pf_SPECIAL;/* don't create GV */
-ref(cUNPo->op_first, o->op_type);
+doref(cUNPo->op_first, o->op_type, set_op_ref);
break;
case P_PADAV:
case P_PADHV:
-o->op_flags |= Pf_REF;
+if (set_op_ref)
+ o->op_flags |= Pf_REF;
break;
case P_SCALAR:
case P_NULL:
if (!(o->op_flags & Pf_KIDS))
break;
-ref(cBINPo->op_first, type);
+doref(cBINPo->op_first, type, set_op_ref);
break;
case P_AELEM:
case P_HELEM:
-ref(cBINPo->op_first, o->op_type);
+doref(cBINPo->op_first, o->op_type, set_op_ref);
if (type == P_RV2SV || type == P_RV2AV || type == P_RV2HV) {
o->op_private |= (type == P_RV2AV ? PpDEREF_AV
: type == P_RV2HV ? PpDEREF_HV
@@ -1528,11 +1530,13 @@
case P_SCPE:
case P_LEAVE:
+set_op_ref = FALSE;
+/* FALL THRUGH */
case P_ENTER:
case P_LIST:
if (!(o->op_flags & Pf_KIDS))
break;
-ref(cLISTPo->op_last, type);
+doref(cLISTPo->op_last, type, set_op_ref);
break;
default:
break;
//depot/maint-5.8/perl/op.h#27 (text)
Index: perl/op.h
perl/op.h#26~28775~2006-09-02 09:01:36.000000000 -0700
perl/op.h2006-10-29 11:16:37.000000000 -0800
@@ -497,6 +497,9 @@
#define PERL_LADMD_NIMPRT0x2
#define PERL_LADMD_IMPRTPS0x4
+/* used in perly.y */
+#define ref(o, type) doref(o, type, TRUE)
+
#ifdef USE_REENTRANT_API
#include "reentr.h"
#endif
//depot/maint-5.8/perl/proto.h#143 (text+w)
Index: perl/proto.h
perl/proto.h#142~29013~2006-10-14 08:13:34.000000000 -0700
perl/proto.h2006-10-29 11:16:37.000000000 -0800
@@ -1009,6 +1009,9 @@
PERL_CALLCNV I32Perl_call_pv(pTHX_ const char* sub_name, I32 flags);
PERL_CALLCNV I32Perl_call_sv(pTHX_ SV* sv, I32 flags);
PERL_CALLCNV voidPerl_despatch_signals(pTHX);
+PERL_CALLCNV P *Perl_doref(pTHX_ P *o, I32 type, bool set_op_ref)
+__attribute__nonnull__(pTHX_1);
+
PERL_CALLCNV SV*Perl_eval_pv(pTHX_ const char* p, I32 croak_on_error);
PERL_CALLCNV I32Perl_eval_sv(pTHX_ SV* sv, I32 flags);
PERL_CALLCNV SV*Perl_get_sv(pTHX_ const char* name, I32 create);
@@ -1035,7 +1038,7 @@
PERL_CALLCNV P*Perl_prepend_elem(pTHX_ I32 optype, P* head, P* tail);
PERL_CALLCNV voidPerl_push_return(pTHX_ P* o);
PERL_CALLCNV voidPerl_push_scope(pTHX);
-PERL_CALLCNV P*Perl_ref(pTHX_ P* o, I32 type);
+/* PERL_CALLCNV P*ref(pTHX_ P* o, I32 type); */
PERL_CALLCNV P*Perl_refkids(pTHX_ P* o, I32 type);
PERL_CALLCNV voidPerl_regdump(pTHX_ regexp* r);
PERL_CALLCNV SV*Perl_regclass_swash(pTHX_ struct regnode *n, bool doinit, SV **listsvp, SV **altsvp);
//#8 (xtext)
Index: perl/t/op/array.t
perl/t/op/array.t#7~26697~2006-01-07 05:18:30.000000000 -0800
perl/t/op/array.t2006-10-29 11:16:37.000000000 -0800
@@ -2,12 +2,12 @@
BEGIN {
chdir 't' if -d 't';
- @INC = '.', '/lib';
+ @INC = ('.', '/lib');
}
require 'test.pl';
-plan (91);
+plan (97);
#
# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
@@ -294,3 +294,33 @@
test_arylen ($a);
test_arylen (do {my @a; \$#a});
}
+
+{
+ # Bug #37350
+ my @array = (14);
+ $#{@array} = 7;
+ is ($#{4}, 7);
+
+ my $x;
+ $#{$x} = 3;
+ is(scalar @$x, 4);
+
+ push @{@array}, 23;
+ is ($4[8], 23);
+}
+{
+ # Bug #37350 -- once more with a global
+ use vars '@array';
+ @array = (14);
+ $#{@array} = 7;
+ is ($#{4}, 7);
+
+ my $x;
+ $#{$x} = 3;
+ is(scalar @$x, 4);
+
+ push @{@array}, 23;
+ is ($4[8], 23);
+}
+
+"We're included by lib/Tie/Array/std.t so we need to return something true";
End of Patch.