diff options
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | embed.h | 4 | ||||
| -rw-r--r-- | global.sym | 2 | ||||
| -rw-r--r-- | op.c | 31 | ||||
| -rw-r--r-- | op.h | 3 | ||||
| -rw-r--r-- | proto.h | 5 | ||||
| -rwxr-xr-x | t/op/array.t | 30 |
7 files changed, 64 insertions, 14 deletions
@@ -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 @@ -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 27535f788a..fac84a0fb6 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 @@ -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) { @@ -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 @@ -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 6461a433bc..27565de702 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"; |