Re: [PATCH] Re: [perl #37350] $#{@$aref} in debugger gives: Bizarre copy of ARRAY...

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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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";