From: Robin Houston <robin@cpan.org>
Date: Fri, 14 Oct 2005 01:54:00 +0000 (+0000)
Subject: Re: [PATCH] Re: [perl #37350] $#{@$aref} in debugger gives: Bizarre copy of ARRAY... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e4c5ccf3177be837114b952c25e52a6812f35eb5;p=p5sagit%2Fp5-mst-13.2.git

Re: [PATCH] Re: [perl #37350] $#{@$aref} in debugger gives: Bizarre copy of ARRAY in leave
Message-ID: <20051013235457.GA23386@rpc142.cs.man.ac.uk>

p4raw-id: //depot/perl@25808
---

diff --git a/embed.fnc b/embed.fnc
index a63fda8..6491bce 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -590,6 +590,7 @@ Apd	|I32	|call_method	|NN const char* methname|I32 flags
 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	|OP *	|doref		|NN OP *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
@@ -615,7 +616,7 @@ p	|OP*	|pmtrans	|NN OP* o|NN OP* expr|NN OP* repl
 Ap	|void	|pop_scope
 p	|OP*	|prepend_elem	|I32 optype|NULLOK OP* head|NULLOK OP* tail
 Ap	|void	|push_scope
-p	|OP*	|ref		|NULLOK OP* o|I32 type
+Amb	|OP*	|ref		|NULLOK OP* o|I32 type
 p	|OP*	|refkids	|NULLOK OP* o|I32 type
 Ap	|void	|regdump	|NN regexp* r
 Ap	|SV*	|regclass_swash	|NN const struct regnode *n|bool doinit|NULLOK SV **listsvp|NULLOK SV **altsvp
diff --git a/embed.h b/embed.h
index adcf1fd..9ccf80d 100644
--- a/embed.h
+++ b/embed.h
@@ -614,6 +614,7 @@
 #define call_pv			Perl_call_pv
 #define call_sv			Perl_call_sv
 #define despatch_signals	Perl_despatch_signals
+#define doref			Perl_doref
 #define eval_pv			Perl_eval_pv
 #define eval_sv			Perl_eval_sv
 #define get_sv			Perl_get_sv
@@ -645,7 +646,6 @@
 #endif
 #define push_scope		Perl_push_scope
 #ifdef PERL_CORE
-#define ref			Perl_ref
 #define refkids			Perl_refkids
 #endif
 #define regdump			Perl_regdump
@@ -2608,6 +2608,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)
@@ -2639,7 +2640,6 @@
 #endif
 #define push_scope()		Perl_push_scope(aTHX)
 #ifdef PERL_CORE
-#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)
diff --git a/global.sym b/global.sym
index 27535f7..fac84a0 100644
--- a/global.sym
+++ b/global.sym
@@ -348,6 +348,7 @@ Perl_call_method
 Perl_call_pv
 Perl_call_sv
 Perl_despatch_signals
+Perl_doref
 Perl_eval_pv
 Perl_eval_sv
 Perl_get_sv
@@ -368,6 +369,7 @@ Perl_packlist
 Perl_pmflag
 Perl_pop_scope
 Perl_push_scope
+Perl_ref
 Perl_regdump
 Perl_regclass_swash
 Perl_pregexec
diff --git a/op.c b/op.c
index 5d593f8..19eb99c 100644
--- a/op.c
+++ b/op.c
@@ -1422,7 +1422,7 @@ Perl_refkids(pTHX_ OP *o, I32 type)
 }
 
 OP *
-Perl_ref(pTHX_ OP *o, I32 type)
+Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
 {
     dVAR;
     OP *kid;
@@ -1444,12 +1444,12 @@ Perl_ref(pTHX_ OP *o, I32 type)
 
     case OP_COND_EXPR:
 	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
-	    ref(kid, type);
+	    doref(kid, type, set_op_ref);
 	break;
     case OP_RV2SV:
 	if (type == OP_DEFINED)
 	    o->op_flags |= OPf_SPECIAL;		/* don't create GV */
-	ref(cUNOPo->op_first, o->op_type);
+	doref(cUNOPo->op_first, o->op_type, set_op_ref);
 	/* FALL THROUGH */
     case OP_PADSV:
 	if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
@@ -1466,28 +1466,30 @@ Perl_ref(pTHX_ OP *o, I32 type)
 
     case OP_RV2AV:
     case OP_RV2HV:
-	o->op_flags |= OPf_REF;
+	if (set_op_ref)
+	    o->op_flags |= OPf_REF;
 	/* FALL THROUGH */
     case OP_RV2GV:
 	if (type == OP_DEFINED)
 	    o->op_flags |= OPf_SPECIAL;		/* don't create GV */
-	ref(cUNOPo->op_first, o->op_type);
+	doref(cUNOPo->op_first, o->op_type, set_op_ref);
 	break;
 
     case OP_PADAV:
     case OP_PADHV:
-	o->op_flags |= OPf_REF;
+	if (set_op_ref)
+	    o->op_flags |= OPf_REF;
 	break;
 
     case OP_SCALAR:
     case OP_NULL:
 	if (!(o->op_flags & OPf_KIDS))
 	    break;
-	ref(cBINOPo->op_first, type);
+	doref(cBINOPo->op_first, type, set_op_ref);
 	break;
     case OP_AELEM:
     case OP_HELEM:
-	ref(cBINOPo->op_first, o->op_type);
+	doref(cBINOPo->op_first, o->op_type, set_op_ref);
 	if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
 	    o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
 			      : type == OP_RV2HV ? OPpDEREF_HV
@@ -1498,11 +1500,13 @@ Perl_ref(pTHX_ OP *o, I32 type)
 
     case OP_SCOPE:
     case OP_LEAVE:
+	set_op_ref = FALSE;
+	/* FALL THROUGH */
     case OP_ENTER:
     case OP_LIST:
 	if (!(o->op_flags & OPf_KIDS))
 	    break;
-	ref(cLISTOPo->op_last, type);
+	doref(cLISTOPo->op_last, type, set_op_ref);
 	break;
     default:
 	break;
@@ -1511,6 +1515,15 @@ Perl_ref(pTHX_ OP *o, I32 type)
 
 }
 
+/* ref() is now a macro using Perl_doref;
+ * this version provided for binary compatibility only.
+ */
+OP *
+Perl_ref(pTHX_ OP *o, I32 type)
+{
+    return doref(o, type, TRUE);
+}
+
 STATIC OP *
 S_dup_attrlist(pTHX_ OP *o)
 {
diff --git a/op.h b/op.h
index 6482d20..0f54a67 100644
--- a/op.h
+++ b/op.h
@@ -507,6 +507,9 @@ struct loop {
 #define PERL_LOADMOD_NOIMPORT		0x2
 #define PERL_LOADMOD_IMPORT_OPS		0x4
 
+/* used in perly.y */
+#define ref(o, type) doref(o, type, TRUE)
+
 #ifdef USE_REENTRANT_API
 #include "reentr.h"
 #endif
diff --git a/proto.h b/proto.h
index 191f596..416e1c4 100644
--- a/proto.h
+++ b/proto.h
@@ -1673,6 +1673,9 @@ PERL_CALLCONV I32	Perl_call_sv(pTHX_ SV* sv, I32 flags)
 			__attribute__nonnull__(pTHX_1);
 
 PERL_CALLCONV void	Perl_despatch_signals(pTHX);
+PERL_CALLCONV OP *	Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
+			__attribute__nonnull__(pTHX_1);
+
 PERL_CALLCONV SV*	Perl_eval_pv(pTHX_ const char* p, I32 croak_on_error)
 			__attribute__nonnull__(pTHX_1);
 
@@ -1735,7 +1738,7 @@ PERL_CALLCONV OP*	Perl_pmtrans(pTHX_ OP* o, OP* expr, OP* repl)
 PERL_CALLCONV void	Perl_pop_scope(pTHX);
 PERL_CALLCONV OP*	Perl_prepend_elem(pTHX_ I32 optype, OP* head, OP* tail);
 PERL_CALLCONV void	Perl_push_scope(pTHX);
-PERL_CALLCONV OP*	Perl_ref(pTHX_ OP* o, I32 type);
+/* PERL_CALLCONV OP*	ref(pTHX_ OP* o, I32 type); */
 PERL_CALLCONV OP*	Perl_refkids(pTHX_ OP* o, I32 type);
 PERL_CALLCONV void	Perl_regdump(pTHX_ regexp* r)
 			__attribute__nonnull__(pTHX_1);
diff --git a/t/op/array.t b/t/op/array.t
index 6461a43..27565de 100755
--- a/t/op/array.t
+++ b/t/op/array.t
@@ -7,7 +7,7 @@ BEGIN {
 
 require 'test.pl';
 
-plan (111);
+plan (117);
 
 #
 # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
@@ -356,4 +356,32 @@ sub test_arylen {
     }
 }
 
+{
+    # Bug #37350
+    my @array = (1..4);
+    $#{@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 = (1..4);
+    $#{@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";