File Coverage

Alias.xs
Criterion Covered Total %
statement 1166 1331 87.6
branch 661 990 66.7
condition n/a
subroutine n/a
pod n/a
total 1827 2321 78.7


line stmt bran cond sub pod time code
1             /* Copyright (C) 2003, 2004, 2006, 2007 Matthijs van Duin
2             *
3             * Copyright (C) 2010, 2011, 2013, 2015, 2017
4             * Andrew Main (Zefram)
5             *
6             * Parts from perl, which is Copyright (C) 1991-2013 Larry Wall and others
7             *
8             * You may distribute under the same terms as perl itself, which is either
9             * the GNU General Public License or the Artistic License.
10             */
11              
12             #define PERL_CORE
13             #define PERL_NO_GET_CONTEXT
14             #include "EXTERN.h"
15             #include "config.h"
16             #undef USE_DTRACE
17             #include "perl.h"
18             #undef PERL_CORE
19             #include "XSUB.h"
20              
21              
22             #ifdef USE_5005THREADS
23             #error "5.005 threads not supported by Data::Alias"
24             #endif
25              
26              
27             #ifndef PERL_COMBI_VERSION
28             #define PERL_COMBI_VERSION (PERL_REVISION * 1000000 + PERL_VERSION * 1000 + \
29             PERL_SUBVERSION)
30             #endif
31              
32             #ifndef cBOOL
33             #define cBOOL(x) ((bool)!!(x))
34             #endif
35              
36             #if (PERL_COMBI_VERSION < 5037002)
37             #define KW_DO DO
38             #endif
39              
40             #ifndef G_LIST
41             #define G_LIST G_ARRAY
42             #endif
43              
44              
45             #ifndef RenewOpc
46             #if defined(PL_OP_SLAB_ALLOC) || (PERL_COMBI_VERSION >= 5017002)
47             #define RenewOpc(m,v,n,t,c) \
48             STMT_START { \
49             t *tMp_; \
50             NewOp(m,tMp_,n,t); \
51             Copy(v,tMp_,n,t); \
52             FreeOp(v); \
53             v = (c*) tMp_; \
54             } STMT_END
55             #else
56             #if (PERL_COMBI_VERSION >= 5009004)
57             #define RenewOpc(m,v,n,t,c) \
58             (v = (MEM_WRAP_CHECK_(n,t) \
59             (c*)PerlMemShared_realloc(v, (n)*sizeof(t))))
60             #else
61             #define RenewOpc(m,v,n,t,c) \
62             Renewc(v,n,t,c)
63             #endif
64             #endif
65             #endif
66              
67             #ifndef RenewOp
68             #define RenewOp(m,v,n,t) \
69             RenewOpc(m,v,n,t,t)
70             #endif
71              
72              
73             #ifdef avhv_keys
74             #define DA_FEATURE_AVHV 1
75             #endif
76              
77             #if (PERL_COMBI_VERSION >= 5009003)
78             #define PL_no_helem PL_no_helem_sv
79             #endif
80              
81             #ifndef SvPVX_const
82             #define SvPVX_const SvPVX
83             #endif
84              
85             #ifndef SvREFCNT_inc_NN
86             #define SvREFCNT_inc_NN SvREFCNT_inc
87             #endif
88             #ifndef SvREFCNT_inc_simple_NN
89             #define SvREFCNT_inc_simple_NN SvREFCNT_inc_NN
90             #endif
91             #ifndef SvREFCNT_inc_simple_void_NN
92             #define SvREFCNT_inc_simple_void_NN SvREFCNT_inc_simple_NN
93             #endif
94              
95             #ifndef GvGP_set
96             #define GvGP_set(gv, val) (GvGP(gv) = (val))
97             #endif
98             #ifndef GvCV_set
99             #define GvCV_set(gv, val) (GvCV(gv) = (val))
100             #endif
101              
102             #ifndef isGV_with_GP_on
103             #define isGV_with_GP_on(gv) SvSCREAM_on(gv)
104             #endif
105              
106             #if (PERL_COMBI_VERSION >= 5009003)
107             #define DA_FEATURE_MULTICALL 1
108             #endif
109              
110             #if (PERL_COMBI_VERSION >= 5009002)
111             #define DA_FEATURE_RETOP 1
112             #endif
113              
114             #define INT2SIZE(x) ((MEM_SIZE)(SSize_t)(x))
115             #define DA_ARRAY_MAXIDX ((IV) (INT2SIZE(-1) / (2 * sizeof(SV *))) )
116              
117             #ifndef Nullsv
118             #define Nullsv ((SV*)NULL)
119             #endif
120              
121             #ifndef Nullop
122             #define Nullop ((OP*)NULL)
123             #endif
124              
125             #ifndef lex_end
126             #define lex_end() ((void) 0)
127             #endif
128              
129             #ifndef op_lvalue
130             #define op_lvalue(o, t) mod(o, t)
131             #endif
132              
133             #define DA_HAVE_OP_AELEMFAST_LEX (PERL_COMBI_VERSION >= 5015000)
134             #define DA_HAVE_OP_PADRANGE (PERL_COMBI_VERSION >= 5017006)
135             #define DA_HAVE_OP_PADSV_STORE (PERL_COMBI_VERSION >= 5037003)
136             #define DA_HAVE_OP_AELEMFASTLEX_STORE (PERL_COMBI_VERSION >= 5037004)
137             #define DA_HAVE_OP_EMPTYAVHV (PERL_COMBI_VERSION >= 5037006)
138              
139             #if DA_HAVE_OP_PADRANGE
140             #define IS_PUSHMARK_OR_PADRANGE(op) \
141             ((op)->op_type == OP_PUSHMARK || (op)->op_type == OP_PADRANGE)
142             #else
143             #define IS_PUSHMARK_OR_PADRANGE(op) ((op)->op_type == OP_PUSHMARK)
144             #endif
145              
146             #if (PERL_COMBI_VERSION < 5010001)
147             typedef unsigned Optype;
148             #endif
149              
150             #ifndef OpMORESIB_set
151             #define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
152             #define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
153             #define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
154             #endif
155             #ifndef OpSIBLING
156             #define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling))
157             #define OpSIBLING(o) (0 + (o)->op_sibling)
158             #endif
159              
160             #if (PERL_COMBI_VERSION < 5009003)
161             typedef OP *(*Perl_check_t)(pTHX_ OP *);
162             #endif
163              
164             #ifndef wrap_op_checker
165             #define wrap_op_checker(c,n,o) THX_wrap_op_checker(aTHX_ c,n,o)
166             static void THX_wrap_op_checker(pTHX_ Optype opcode,
167             Perl_check_t new_checker, Perl_check_t *old_checker_p)
168             {
169             if(*old_checker_p) return;
170             OP_REFCNT_LOCK;
171             if(!*old_checker_p) {
172             *old_checker_p = PL_check[opcode];
173             PL_check[opcode] = new_checker;
174             }
175             OP_REFCNT_UNLOCK;
176             }
177             #endif
178              
179             #define DA_HAVE_LEX_KNOWNEXT (PERL_COMBI_VERSION < 5025001)
180              
181             #if (PERL_COMBI_VERSION >= 5011000) && !defined(SVt_RV)
182             #define SVt_RV SVt_IV
183             #endif
184              
185             #ifndef IS_PADGV
186             #ifdef USE_ITHREADS
187             #define IS_PADGV(v) ((v) && SvTYPE(v) == SVt_PVGV)
188             #else
189             #define IS_PADGV(v) 0
190             #endif
191             #endif
192              
193             #ifndef PadnamelistARRAY
194             #define PadnamelistARRAY(pnl) AvARRAY(pnl)
195             #endif
196              
197             #ifndef PadnameOUTER
198             #define PadnameOUTER(pn) (!!SvFAKE(pn))
199             #endif
200              
201             #if (PERL_COMBI_VERSION >= 5006000) && (PERL_COMBI_VERSION < 5011000)
202             #define case_OP_SETSTATE_ case OP_SETSTATE:
203             #else
204             #define case_OP_SETSTATE_
205             #endif
206              
207             #if (PERL_COMBI_VERSION >= 5011002)
208             static char const msg_no_symref[] =
209             "Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use";
210             #else
211             #define msg_no_symref PL_no_symref
212             #endif
213              
214             #if (PERL_COMBI_VERSION >= 5009005)
215             #ifdef PERL_MAD
216             #error "Data::Alias doesn't support Misc Attribute Decoration yet"
217             #endif
218             #if DA_HAVE_LEX_KNOWNEXT
219             #define PL_lex_defer (PL_parser->lex_defer)
220             #endif
221             #if (PERL_COMBI_VERSION < 5021004)
222             #define PL_lex_expect (PL_parser->lex_expect)
223             #endif
224             #define PL_linestr (PL_parser->linestr)
225             #define PL_expect (PL_parser->expect)
226             #define PL_bufptr (PL_parser->bufptr)
227             #define PL_oldbufptr (PL_parser->oldbufptr)
228             #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
229             #define PL_bufend (PL_parser->bufend)
230             #define PL_last_uni (PL_parser->last_uni)
231             #define PL_last_lop (PL_parser->last_lop)
232             #define PL_lex_state (PL_parser->lex_state)
233             #define PL_nexttoke (PL_parser->nexttoke)
234             #define PL_nexttype (PL_parser->nexttype)
235             #define PL_tokenbuf (PL_parser->tokenbuf)
236             #define PL_yylval (PL_parser->yylval)
237             #elif (PERL_COMBI_VERSION >= 5009001)
238             #define PL_yylval (*PL_yylvalp)
239             #endif
240              
241              
242             #define OPpALIASAV 1
243             #define OPpALIASHV 2
244             #define OPpALIAS (OPpALIASAV | OPpALIASHV)
245              
246             #define OPpUSEFUL OPpLVAL_INTRO
247              
248             #define MOD(op) op_lvalue((op), OP_GREPSTART)
249              
250             #ifndef OPpPAD_STATE
251             #define OPpPAD_STATE 0
252             #endif
253              
254             #ifndef SVs_PADBUSY
255             #define SVs_PADBUSY 0
256             #endif
257             #define SVs_PADFLAGS (SVs_PADBUSY|SVs_PADMY|SVs_PADTMP)
258              
259             #ifdef pp_dorassign
260             #define DA_HAVE_OP_DORASSIGN 1
261             #else
262             #define DA_HAVE_OP_DORASSIGN (PERL_COMBI_VERSION >= 5009000)
263             #endif
264              
265             #define DA_TIED_ERR "Can't %s alias %s tied %s"
266             #define DA_ODD_HASH_ERR "Odd number of elements in hash assignment"
267             #define DA_TARGET_ERR "Unsupported alias target"
268             #define DA_TARGET_ERR_AT "Unsupported alias target at %s line %"UVuf"\n"
269             #define DA_DEREF_ERR "Can't deref string (\"%.32s\")"
270             #define DA_OUTER_ERR "Aliasing of outer lexical variable has limited scope"
271              
272             #define _PUSHaa(a1,a2) PUSHs((SV*)(Size_t)(a1));PUSHs((SV*)(Size_t)(a2))
273             #define PUSHaa(a1,a2) STMT_START { _PUSHaa(a1,a2); } STMT_END
274             #define XPUSHaa(a1,a2) STMT_START { EXTEND(sp,2); _PUSHaa(a1,a2); } STMT_END
275              
276             #define DA_ALIAS_PAD ((Size_t) -1)
277             #define DA_ALIAS_RV ((Size_t) -2)
278             #define DA_ALIAS_GV ((Size_t) -3)
279             #define DA_ALIAS_AV ((Size_t) -4)
280             #define DA_ALIAS_HV ((Size_t) -5)
281              
282             static OP *(*da_old_ck_rv2cv)(pTHX_ OP *op);
283             static OP *(*da_old_ck_entersub)(pTHX_ OP *op);
284             #if (PERL_COMBI_VERSION >= 5021007)
285             static OP *(*da_old_ck_aelem)(pTHX_ OP *op);
286             static OP *(*da_old_ck_helem)(pTHX_ OP *op);
287             #endif
288              
289             #ifdef USE_ITHREADS
290              
291             #define DA_GLOBAL_KEY "Data::Alias::_global"
292             #define DA_FETCH(create) hv_fetch(PL_modglobal, DA_GLOBAL_KEY, \
293             sizeof(DA_GLOBAL_KEY) - 1, create)
294             #define DA_ACTIVE ((_dap = DA_FETCH(FALSE)) && (_da = *_dap))
295             #define DA_INIT STMT_START { _dap = DA_FETCH(TRUE); _da = *_dap; \
296             sv_upgrade(_da, SVt_PVLV); LvTYPE(_da) = 't'; } STMT_END
297              
298             #define dDA SV *_da, **_dap
299             #define dDAforce SV *_da = *DA_FETCH(FALSE)
300              
301             #define da_inside (*(I32 *) &SvIVX(_da))
302             #define da_iscope (*(PERL_CONTEXT **) &SvPVX(_da))
303             #define da_cv (*(CV **) &LvTARGOFF(_da))
304             #define da_cvc (*(CV **) &LvTARGLEN(_da))
305              
306             #else
307              
308             #define dDA dNOOP
309             #define dDAforce dNOOP
310             #define DA_ACTIVE 42
311             #define DA_INIT
312              
313             static CV *da_cv, *da_cvc;
314             static I32 da_inside;
315             static PERL_CONTEXT *da_iscope;
316              
317             #endif
318              
319             static void (*da_old_peepp)(pTHX_ OP *);
320              
321 0           static OP *da_tag_rv2cv(pTHX) { return NORMAL; }
322 0           static OP *da_tag_list(pTHX) { return NORMAL; }
323 0           static OP *da_tag_entersub(pTHX) { return NORMAL; }
324             #if (PERL_COMBI_VERSION >= 5031002)
325 0           static OP *da_tag_enter(pTHX) { return NORMAL; }
326             #endif
327              
328             static void da_peep(pTHX_ OP *o);
329             static void da_peep2(pTHX_ OP *o);
330              
331 33           static SV *da_fetch(pTHX_ SV *a1, SV *a2) {
332 33           switch ((Size_t) a1) {
333 8           case DA_ALIAS_PAD:
334 8           return PAD_SVl((Size_t) a2);
335 13           case DA_ALIAS_RV:
336 13 50         if (SvTYPE(a2) == SVt_PVGV)
337 13           a2 = GvSV(a2);
338 0 0         else if (!SvROK(a2) || !(a2 = SvRV(a2))
    0          
339 0 0         || (SvTYPE(a2) > SVt_PVLV && SvTYPE(a2) != SVt_PVGV))
    0          
340 0           Perl_croak(aTHX_ "Not a SCALAR reference");
341             case DA_ALIAS_GV:
342 13           return a2;
343 0           case DA_ALIAS_AV:
344             case DA_ALIAS_HV:
345 0           break;
346 12           default:
347 12           switch (SvTYPE(a1)) {
348             SV **svp;
349             HE *he;
350 8           case SVt_PVAV:
351 8           svp = av_fetch((AV *) a1, (Size_t) a2, FALSE);
352 8 50         return svp ? *svp : &PL_sv_undef;
353 4           case SVt_PVHV:
354 4           he = hv_fetch_ent((HV *) a1, a2, FALSE, 0);
355 4 50         return he ? HeVAL(he) : &PL_sv_undef;
356 0           default:
357             /* suppress warning */ ;
358             }
359             }
360 0           Perl_croak(aTHX_ DA_TARGET_ERR);
361             return NULL; /* suppress warning on win32 */
362             }
363              
364             #define PREP_ALIAS_INC(sV) \
365             STMT_START { \
366             if (SvPADTMP(sV) && !IS_PADGV(sV)) { \
367             sV = newSVsv(sV); \
368             SvREADONLY_on(sV); \
369             } else { \
370             switch (SvTYPE(sV)) { \
371             case SVt_PVLV: \
372             if (LvTYPE(sV) == 'y') { \
373             if (LvTARGLEN(sV)) \
374             vivify_defelem(sV); \
375             sV = LvTARG(sV); \
376             if (!sV) \
377             sV = &PL_sv_undef; \
378             } \
379             break; \
380             case SVt_PVAV: \
381             if (!AvREAL((AV *) sV) && AvREIFY((AV *) sV)) \
382             av_reify((AV *) sV); \
383             break; \
384             default: \
385             /* suppress warning */ ; \
386             } \
387             SvTEMP_off(sV); \
388             SvREFCNT_inc_simple_void_NN(sV); \
389             } \
390             } STMT_END
391              
392 1           static void da_restore_gvcv(pTHX_ void *gv_v) {
393 1           GV *gv = (GV*)gv_v;
394 1           CV *restcv = (CV *) SSPOPPTR;
395 1           CV *oldcv = GvCV(gv);
396 1           GvCV_set(gv, restcv);
397 1           SvREFCNT_dec(oldcv);
398 1           SvREFCNT_dec((SV *) gv);
399 1           }
400              
401 26           static void da_alias_pad(pTHX_ PADOFFSET index, SV *value) {
402 26           SV *old = PAD_SVl(index);
403 26 50         PREP_ALIAS_INC(value);
    50          
    50          
    50          
    100          
    50          
404 26           PAD_SVl(index) = value;
405 26           SvFLAGS(value) |= (SvFLAGS(old) & SVs_PADFLAGS);
406 26 100         if (old != &PL_sv_undef)
407 14           SvREFCNT_dec(old);
408 26           }
409              
410 174           static void da_alias(pTHX_ SV *a1, SV *a2, SV *value) {
411 174 100         if ((Size_t) a1 == DA_ALIAS_PAD)
412 25           return da_alias_pad(aTHX_ (PADOFFSET)(Size_t)a2, value);
413              
414 149 100         PREP_ALIAS_INC(value);
    0          
    0          
    0          
    50          
    0          
415 149           switch ((Size_t) a1) {
416             SV **svp;
417             GV *gv;
418 97           case DA_ALIAS_RV:
419 97 100         if (SvTYPE(a2) == SVt_PVGV) {
420 90           sv_2mortal(value);
421 90           goto globassign;
422             }
423 7           value = newRV_noinc(value);
424 7           goto refassign;
425 14           case DA_ALIAS_GV:
426 14 100         if (!SvROK(value)) {
427 5           refassign:
428 12 50         SvSetMagicSV(a2, value);
    50          
429 12           SvREFCNT_dec(value);
430 12           return;
431             }
432 9           value = SvRV(sv_2mortal(value));
433 99           globassign:
434 99           gv = (GV *) a2;
435             #ifdef GV_UNIQUE_CHECK
436             if (GvUNIQUE(gv))
437             Perl_croak(aTHX_ PL_no_modify);
438             #endif
439 99           switch (SvTYPE(value)) {
440             CV *oldcv;
441 1           case SVt_PVCV:
442 1           oldcv = GvCV(gv);
443 1 50         if (oldcv != (CV *) value) {
444 1 50         if (GvCVGEN(gv)) {
445 0           GvCV_set(gv, NULL);
446 0           GvCVGEN(gv) = 0;
447 0           SvREFCNT_dec((SV *) oldcv);
448 0           oldcv = NULL;
449             }
450 1           PL_sub_generation++;
451             }
452 1           GvMULTI_on(gv);
453 1 50         if (GvINTRO(gv)) {
454 1           SvREFCNT_inc_simple_void_NN((SV *) gv);
455 1           SvREFCNT_inc_simple_void_NN(value);
456 1           GvINTRO_off(gv);
457 1 50         SSCHECK(1);
458 1           SSPUSHPTR((SV *) oldcv);
459 1           SAVEDESTRUCTOR_X(da_restore_gvcv, (void*)gv);
460 1           GvCV_set(gv, (CV*)value);
461             } else {
462 0           SvREFCNT_inc_simple_void_NN(value);
463 0           GvCV_set(gv, (CV*)value);
464 0           SvREFCNT_dec((SV *) oldcv);
465             }
466 1           return;
467 10           case SVt_PVAV: svp = (SV **) &GvAV(gv); break;
468 10           case SVt_PVHV: svp = (SV **) &GvHV(gv); break;
469 1           case SVt_PVFM: svp = (SV **) &GvFORM(gv); break;
470 1           case SVt_PVIO: svp = (SV **) &GvIOp(gv); break;
471 76           default: svp = &GvSV(gv);
472             }
473 98           GvMULTI_on(gv);
474 98 100         if (GvINTRO(gv)) {
475 5           GvINTRO_off(gv);
476 5           SAVEGENERICSV(*svp);
477 5           *svp = SvREFCNT_inc_simple_NN(value);
478             } else {
479 93           SV *old = *svp;
480 93           *svp = SvREFCNT_inc_simple_NN(value);
481 93           SvREFCNT_dec(old);
482             }
483 98           return;
484 0           case DA_ALIAS_AV:
485             case DA_ALIAS_HV:
486 0           break;
487 38           default:
488 38           switch (SvTYPE(a1)) {
489 23           case SVt_PVAV:
490 23 50         if (!av_store((AV *) a1, (SSize_t) a2, value))
491 0           SvREFCNT_dec(value);
492 23           return;
493 15           case SVt_PVHV:
494 15 100         if (value == &PL_sv_undef) {
495 1           (void) hv_delete_ent((HV *) a1, a2,
496             G_DISCARD, 0);
497             } else {
498 14 50         if (!hv_store_ent((HV *) a1, a2, value, 0))
499 0           SvREFCNT_dec(value);
500             }
501 15           return;
502 0           default:
503             /* suppress warning */ ;
504             }
505             }
506 0           SvREFCNT_dec(value);
507 0           Perl_croak(aTHX_ DA_TARGET_ERR);
508             }
509              
510 14           static void da_unlocalize_gvar(pTHX_ void *gp_v) {
511 14           GP *gp = (GP*) gp_v;
512 14           SV *value = (SV *) SSPOPPTR;
513 14           SV **sptr = (SV **) SSPOPPTR;
514 14           SV *old = *sptr;
515 14           *sptr = value;
516 14           SvREFCNT_dec(old);
517              
518 14 100         if (gp->gp_refcnt > 1) {
519 11           --gp->gp_refcnt;
520             } else {
521 3           SV *gv = newSV(0);
522 3           sv_upgrade(gv, SVt_PVGV);
523 3           isGV_with_GP_on(gv);
524 3           GvGP_set(gv, gp);
525 3           sv_free(gv);
526             }
527 14           }
528              
529 14           static void da_localize_gvar(pTHX_ GP *gp, SV **sptr) {
530 14 50         SSCHECK(2);
531 14           SSPUSHPTR(sptr);
532 14           SSPUSHPTR(*sptr);
533 14           SAVEDESTRUCTOR_X(da_unlocalize_gvar, (void*)gp);
534 14           ++gp->gp_refcnt;
535 14           *sptr = Nullsv;
536 14           }
537              
538 84           static SV *da_refgen(pTHX_ SV *sv) {
539             SV *rv;
540 84 50         PREP_ALIAS_INC(sv);
    0          
    0          
    0          
    50          
    0          
541 84           rv = sv_newmortal();
542 84           sv_upgrade(rv, SVt_RV);
543 84           SvRV(rv) = sv;
544 84           SvROK_on(rv);
545 84           SvREADONLY_on(rv);
546 84           return rv;
547             }
548              
549 54           static OP *DataAlias_pp_srefgen(pTHX) {
550 54           dSP;
551 54           SETs(da_refgen(aTHX_ TOPs));
552 54           RETURN;
553             }
554              
555 4           static OP *DataAlias_pp_refgen(pTHX) {
556 4           dSP; dMARK;
557 4 50         if (GIMME_V != G_LIST) {
558 4           ++MARK;
559 4 50         *MARK = da_refgen(aTHX_ MARK <= SP ? TOPs : &PL_sv_undef);
560 4           SP = MARK;
561             } else {
562 0 0         EXTEND_MORTAL(SP - MARK);
563 0 0         while (++MARK <= SP)
564 0           *MARK = da_refgen(aTHX_ *MARK);
565             }
566 4           RETURN;
567             }
568              
569 13           static OP *DataAlias_pp_anonlist(pTHX) {
570 13           dSP; dMARK;
571 13           I32 i = SP - MARK;
572 13           AV *av = newAV();
573             SV **svp, *sv;
574 13           av_extend(av, i - 1);
575 13           AvFILLp(av) = i - 1;
576 13           svp = AvARRAY(av);
577 32 100         while (i--)
578 19           SvTEMP_off(svp[i] = SvREFCNT_inc_NN(POPs));
579 13 100         if (PL_op->op_flags & OPf_SPECIAL) {
580 9           sv = da_refgen(aTHX_ (SV *) av);
581 9           SvREFCNT_dec((SV *) av);
582             } else {
583 4           sv = sv_2mortal((SV *) av);
584             }
585 13 50         XPUSHs(sv);
586 13           RETURN;
587             }
588              
589 22           static OP *DataAlias_pp_anonhash(pTHX) {
590 22           dSP; dMARK; dORIGMARK;
591 22           HV *hv = (HV *) newHV();
592             SV *sv;
593 53 100         while (MARK < SP) {
594 32           SV *key = *++MARK;
595 32           SV *val = &PL_sv_undef;
596 32 100         if (MARK < SP)
597 30           SvTEMP_off(val = SvREFCNT_inc_NN(*++MARK));
598 2 100         else if (ckWARN(WARN_MISC))
599 1           Perl_warner(aTHX_ packWARN(WARN_MISC),
600             "Odd number of elements in anonymous hash");
601 31 100         if (val == &PL_sv_undef)
602 3           (void) hv_delete_ent(hv, key, G_DISCARD, 0);
603             else
604 28           (void) hv_store_ent(hv, key, val, 0);
605             }
606 21           SP = ORIGMARK;
607 21 100         if (PL_op->op_flags & OPf_SPECIAL) {
608 17           sv = da_refgen(aTHX_ (SV *) hv);
609 17           SvREFCNT_dec((SV *) hv);
610             } else {
611 4           sv = sv_2mortal((SV *) hv);
612             }
613 21 50         XPUSHs(sv);
614 21           RETURN;
615             }
616              
617 17           static OP *DataAlias_pp_aelemfast(pTHX) {
618 17           dSP;
619 17           AV *av =
620             #if DA_HAVE_OP_AELEMFAST_LEX
621 17           PL_op->op_type == OP_AELEMFAST_LEX ?
622             #else
623             (PL_op->op_flags & OPf_SPECIAL) ?
624             #endif
625 17 100         (AV *) PAD_SV(PL_op->op_targ) : GvAVn(cGVOP_gv);
    50          
626 17           IV index = PL_op->op_private;
627             #if (PERL_COMBI_VERSION >= 5019010)
628 17           index = (I8)index;
629             #endif
630 17 50         if (!av_fetch(av, index, TRUE))
631 0           DIE(aTHX_ PL_no_aelem, index);
632 17 50         XPUSHaa(av, index);
633 17           RETURN;
634             }
635              
636             #if DA_HAVE_OP_AELEMFASTLEX_STORE
637 0           static OP *DataAlias_pp_aelemfastlex_store(pTHX) {
638 0           dSP;
639 0           SV *value = TOPs;
640             /* inlined simplified DataAlias_pp_aelemfast */
641 0           AV *av = (AV *) PAD_SV(PL_op->op_targ);
642 0           IV index = (I8)PL_op->op_private;
643 0 0         if (!av_fetch(av, index, TRUE))
644 0           DIE(aTHX_ PL_no_aelem, index);
645             /* inlined simplified DataAlias_pp_sassign */
646 0 0         PREP_ALIAS_INC(value);
    0          
    0          
    0          
    0          
    0          
647 0 0         if (!av_store(av, index, value))
648 0           SvREFCNT_dec(value);
649 0           RETURN;
650             }
651             #endif
652              
653 6           static bool da_badmagic(pTHX_ SV *sv) {
654 6           MAGIC *mg = SvMAGIC(sv);
655 12 100         while (mg) {
656 6 50         if (isUPPER(mg->mg_type))
657 0           return TRUE;
658 6           mg = mg->mg_moremagic;
659             }
660 6           return FALSE;
661             }
662              
663 4           static OP *DataAlias_pp_aelem(pTHX) {
664 4           dSP;
665 4           SV *elem = POPs, **svp;
666 4           AV *av = (AV *) POPs;
667 4           IV index = SvIV(elem);
668 4 50         if (SvRMAGICAL(av) && da_badmagic(aTHX_ (SV *) av))
    0          
669 0           DIE(aTHX_ DA_TIED_ERR, "put", "into", "array");
670 4 50         if (SvROK(elem) && !SvGAMAGIC(elem) && ckWARN(WARN_MISC))
    0          
    0          
    0          
    0          
    0          
671 0           Perl_warner(aTHX_ packWARN(WARN_MISC),
672             "Use of reference \"%"SVf"\" as array index", elem);
673 4 50         if (SvTYPE(av) != SVt_PVAV)
674 0           RETPUSHUNDEF;
675 4 50         if (index > DA_ARRAY_MAXIDX || !(svp = av_fetch(av, index, TRUE)))
    50          
676 0           DIE(aTHX_ PL_no_aelem, index);
677 4 100         if (PL_op->op_private & OPpLVAL_INTRO)
678 2           save_aelem(av, index, svp);
679 4           PUSHaa(av, index);
680 4           RETURN;
681             }
682              
683             #if DA_FEATURE_AVHV
684             static I32 da_avhv_index(pTHX_ AV *av, SV *key) {
685             HV *keys = (HV *) SvRV(*AvARRAY(av));
686             HE *he = hv_fetch_ent(keys, key, FALSE, 0);
687             I32 index;
688             if (!he)
689             Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"",
690             SvPV_nolen(key));
691             if ((index = SvIV(HeVAL(he))) <= 0)
692             Perl_croak(aTHX_ "Bad index while coercing array into hash");
693             if (index > AvMAX(av)) {
694             I32 real = AvREAL(av);
695             AvREAL_on(av);
696             av_extend(av, index);
697             if (!real)
698             AvREAL_off(av);
699             }
700             return index;
701             }
702             #endif
703              
704             #ifndef save_hdelete
705             static void DataAlias_save_hdelete(pTHX_ HV *hv, SV *keysv) {
706             STRLEN len;
707             const char *key = SvPV_const(keysv, len);
708             save_delete(hv, savepvn(key, len), SvUTF8(keysv) ? -(I32)len : (I32)len);
709             }
710             #define save_hdelete(hv, keysv) DataAlias_save_hdelete(aTHX_ (hv), (keysv))
711             #endif
712              
713 11           static OP *DataAlias_pp_helem(pTHX) {
714 11           dSP;
715 11           SV *key = POPs;
716 11           HV *hv = (HV *) POPs;
717             HE *he;
718 11           bool const localizing = PL_op->op_private & OPpLVAL_INTRO;
719              
720 11 50         if (SvRMAGICAL(hv) && da_badmagic(aTHX_ (SV *) hv))
    0          
721 0           DIE(aTHX_ DA_TIED_ERR, "put", "into", "hash");
722              
723 11 50         if (SvTYPE(hv) == SVt_PVHV) {
724 11           bool existed = TRUE;
725 11 100         if (localizing)
726 2           existed = hv_exists_ent(hv, key, 0);
727 11 50         if (!(he = hv_fetch_ent(hv, key, TRUE, 0)))
728 0           DIE(aTHX_ PL_no_helem, SvPV_nolen(key));
729 11 100         if (localizing) {
730 2 100         if (!existed)
731 1           save_hdelete(hv, key);
732             else
733 1           save_helem(hv, key, &HeVAL(he));
734             }
735             }
736             #if DA_FEATURE_AVHV
737             else if (SvTYPE(hv) == SVt_PVAV && avhv_keys((AV *) hv)) {
738             I32 i = da_avhv_index(aTHX_ (AV *) hv, key);
739             if (localizing)
740             save_aelem((AV *) hv, i, &AvARRAY(hv)[i]);
741             key = (SV *) (Size_t) i;
742             }
743             #endif
744             else {
745 0           hv = (HV *) &PL_sv_undef;
746 0           key = NULL;
747             }
748 11           PUSHaa(hv, key);
749 11           RETURN;
750             }
751              
752 3           static OP *DataAlias_pp_aslice(pTHX) {
753 3           dSP; dMARK;
754 3           AV *av = (AV *) POPs;
755             IV max, count;
756             SV **src, **dst;
757 3           const U32 local = PL_op->op_private & OPpLVAL_INTRO;
758 3 50         if (SvTYPE(av) != SVt_PVAV)
759 0           DIE(aTHX_ "Not an array");
760 3 50         if (SvRMAGICAL(av) && da_badmagic(aTHX_ (SV *) av))
    0          
761 0           DIE(aTHX_ DA_TIED_ERR, "put", "into", "array");
762 3           count = SP - MARK;
763 3 50         EXTEND(sp, count);
    50          
764 3           src = SP;
765 3           dst = SP += count;
766 3           max = AvFILLp(av);
767 3           count = max + 1;
768 9 100         while (MARK < src) {
769 6           IV i = SvIVx(*src);
770 6 50         if (i > DA_ARRAY_MAXIDX || (i < 0 && (i += count) < 0))
    50          
    0          
771 0           DIE(aTHX_ PL_no_aelem, SvIVX(*src));
772 6 100         if (local)
773 2           save_aelem(av, i, av_fetch(av, i, TRUE));
774 6 100         if (i > max)
775 2           max = i;
776 6           *dst-- = (SV *) (Size_t) i;
777 6           *dst-- = (SV *) av;
778 6           --src;
779             }
780 3 100         if (max > AvMAX(av))
781 1           av_extend(av, max);
782 3           RETURN;
783             }
784              
785 3           static OP *DataAlias_pp_hslice(pTHX) {
786 3           dSP; dMARK;
787 3           HV *hv = (HV *) POPs;
788             SV *key;
789             HE *he;
790             SV **src, **dst;
791 3           IV i = SP - MARK;
792 3 50         if (SvRMAGICAL(hv) && da_badmagic(aTHX_ (SV *) hv))
    0          
793 0           DIE(aTHX_ DA_TIED_ERR, "put", "into", "hash");
794 3 50         EXTEND(sp, i);
    50          
795 3           src = SP;
796 3           dst = SP += i;
797 3 50         if (SvTYPE(hv) == SVt_PVHV) {
798 9 100         while (MARK < src) {
799 6 50         if (!(he = hv_fetch_ent(hv, key = *src--, TRUE, 0)))
800 0           DIE(aTHX_ PL_no_helem, SvPV_nolen(key));
801 6 100         if (PL_op->op_private & OPpLVAL_INTRO)
802 2           save_helem(hv, key, &HeVAL(he));
803 6           *dst-- = key;
804 6           *dst-- = (SV *) hv;
805             }
806             }
807             #if DA_FEATURE_AVHV
808             else if (SvTYPE(hv) == SVt_PVAV && avhv_keys((AV *) hv)) {
809             while (MARK < src) {
810             i = da_avhv_index(aTHX_ (AV *) hv, key = *src--);
811             if (PL_op->op_private & OPpLVAL_INTRO)
812             save_aelem((AV *) hv, i, &AvARRAY(hv)[i]);
813             *dst-- = (SV *) (Size_t) i;
814             *dst-- = (SV *) hv;
815             }
816             }
817             #endif
818             else {
819 0           DIE(aTHX_ "Not a hash");
820             }
821 3           RETURN;
822             }
823              
824             #if DA_HAVE_OP_PADRANGE
825              
826 7           static OP *DataAlias_pp_padrange_generic(pTHX_ bool is_single) {
827 7           dSP;
828 7           IV start = PL_op->op_targ;
829 7           IV count = PL_op->op_private & OPpPADRANGE_COUNTMASK;
830             IV index;
831 7 100         if (PL_op->op_flags & OPf_SPECIAL) {
832 5 50         AV *av = GvAVn(PL_defgv);
833 5 50         PUSHMARK(SP);
834 5 100         if (is_single) {
835 1 50         XPUSHs((SV*)av);
836             } else {
837 4 50         const I32 maxarg = AvFILL(av) + 1;
838 4 50         EXTEND(SP, maxarg);
    50          
839 4 50         if (SvRMAGICAL(av)) {
840             U32 i;
841 0 0         for (i=0; i < (U32)maxarg; i++) {
842             SV ** const svp =
843 0           av_fetch(av, i, FALSE);
844 0           SP[i+1] = svp ?
845 0           SvGMAGICAL(*svp) ?
846 0 0         (mg_get(*svp), *svp) :
847 0 0         *svp :
848             &PL_sv_undef;
849             }
850             } else {
851 4           Copy(AvARRAY(av), SP+1, maxarg, SV*);
852             }
853 4           SP += maxarg;
854             }
855             }
856 7 50         if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
857 7 50         PUSHMARK(SP);
858 7 50         EXTEND(SP, count << 1);
    50          
859             }
860 17 100         for(index = start; index != start+count; index++) {
861             Size_t da_type;
862 10 100         if (is_single) {
863 1           da_type = DA_ALIAS_PAD;
864             } else {
865 9           switch(SvTYPE(PAD_SVl(index))) {
866 3           case SVt_PVAV: da_type = DA_ALIAS_AV; break;
867 0           case SVt_PVHV: da_type = DA_ALIAS_HV; break;
868 6           default: da_type = DA_ALIAS_PAD; break;
869             }
870             }
871 10 50         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO) {
872 10 100         if (da_type == DA_ALIAS_PAD) {
873 7           SAVEGENERICSV(PAD_SVl(index));
874 7           PAD_SVl(index) = &PL_sv_undef;
875             } else {
876 3           SAVECLEARSV(PAD_SVl(index));
877             }
878             }
879 10 50         if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID)
880 10 100         PUSHaa(da_type, da_type == DA_ALIAS_PAD ?
881             (Size_t)index :
882             (Size_t)PAD_SVl(index));
883             }
884 7           RETURN;
885             }
886              
887 6           static OP *DataAlias_pp_padrange_list(pTHX) {
888 6           return DataAlias_pp_padrange_generic(aTHX_ 0);
889             }
890              
891 1           static OP *DataAlias_pp_padrange_single(pTHX) {
892 1           return DataAlias_pp_padrange_generic(aTHX_ 1);
893             }
894              
895             #endif
896              
897             #if DA_HAVE_OP_PADSV_STORE
898 1           static OP *DataAlias_pp_padsv_store(pTHX) {
899 1           dSP;
900 1           PADOFFSET index = PL_op->op_targ;
901 1 50         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO) {
902 0           SAVEGENERICSV(PAD_SVl(index));
903 0           PAD_SVl(index) = &PL_sv_undef;
904             }
905 1           da_alias_pad(aTHX_ index, TOPs);
906 1           RETURN;
907             }
908             #endif
909              
910 22           static OP *DataAlias_pp_padsv(pTHX) {
911 22           dSP;
912 22           PADOFFSET index = PL_op->op_targ;
913 22 100         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO) {
914 7           SAVEGENERICSV(PAD_SVl(index));
915 7           PAD_SVl(index) = &PL_sv_undef;
916             }
917 22 50         XPUSHaa(DA_ALIAS_PAD, index);
918 22           RETURN;
919             }
920              
921 1           static OP *DataAlias_pp_padav(pTHX) {
922 1           dSP; dTARGET;
923 1 50         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO)
924 1           SAVECLEARSV(PAD_SVl(PL_op->op_targ));
925 1 50         XPUSHaa(DA_ALIAS_AV, TARG);
926 1           RETURN;
927             }
928              
929 0           static OP *DataAlias_pp_padhv(pTHX) {
930 0           dSP; dTARGET;
931 0 0         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO)
932 0           SAVECLEARSV(PAD_SVl(PL_op->op_targ));
933 0 0         XPUSHaa(DA_ALIAS_HV, TARG);
934 0           RETURN;
935             }
936              
937 70           static OP *DataAlias_pp_gvsv(pTHX) {
938 70           dSP;
939 70           GV *gv = cGVOP_gv;
940 70 100         if (PL_op->op_private & OPpLVAL_INTRO) {
941 4           da_localize_gvar(aTHX_ GvGP(gv), &GvSV(gv));
942 4           GvSV(gv) = newSV(0);
943             }
944 70 50         XPUSHaa(DA_ALIAS_RV, gv);
945 70           RETURN;
946             }
947              
948 1           static OP *DataAlias_pp_gvsv_r(pTHX) {
949 1           dSP;
950 1           GV *gv = cGVOP_gv;
951 1 50         if (PL_op->op_private & OPpLVAL_INTRO) {
952 1           da_localize_gvar(aTHX_ GvGP(gv), &GvSV(gv));
953 1           GvSV(gv) = newSV(0);
954             }
955 1 50         XPUSHs(GvSV(gv));
956 1           RETURN;
957             }
958              
959 10           static GV *fixglob(pTHX_ GV *gv) {
960 10           SV **svp = hv_fetch(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE);
961             GV *egv;
962 10 50         if (!svp || !(egv = (GV *) *svp) || GvGP(egv) != GvGP(gv))
    50          
    50          
963 0           return gv;
964 10           GvEGV(gv) = egv;
965 10           return egv;
966             }
967              
968 39           static OP *DataAlias_pp_rv2sv(pTHX) {
969 39           dSP; dPOPss;
970 39 100         if (!SvROK(sv) && SvTYPE(sv) != SVt_PVGV) do {
    100          
971             const char *tname;
972             U32 type;
973 2           switch (PL_op->op_type) {
974 0           case OP_RV2AV: type = SVt_PVAV; tname = "an ARRAY"; break;
975 0           case OP_RV2HV: type = SVt_PVHV; tname = "a HASH"; break;
976 2           default: type = SVt_PV; tname = "a SCALAR";
977             }
978 2 50         if (SvGMAGICAL(sv)) {
979 0           mg_get(sv);
980 0 0         if (SvROK(sv))
981 0           break;
982             }
983 2 50         if (!SvOK(sv))
984 0           break;
985 2 100         if (PL_op->op_private & HINT_STRICT_REFS)
986 1           DIE(aTHX_ msg_no_symref, SvPV_nolen(sv), tname);
987 1           sv = (SV *) gv_fetchpv(SvPV_nolen(sv), TRUE, type);
988             } while (0);
989 38 100         if (SvTYPE(sv) == SVt_PVGV)
990 28 100         sv = (SV *) (GvEGV(sv) ? GvEGV(sv) : fixglob(aTHX_ (GV *) sv));
991 38 100         if (PL_op->op_private & OPpLVAL_INTRO) {
992 12 100         if (SvTYPE(sv) != SVt_PVGV || SvFAKE(sv))
    50          
993 3           DIE(aTHX_ "%s", PL_no_localize_ref);
994 9           switch (PL_op->op_type) {
995 4           case OP_RV2AV:
996 4           da_localize_gvar(aTHX_ GvGP(sv), (SV **) &GvAV(sv));
997 4           break;
998 4           case OP_RV2HV:
999 4           da_localize_gvar(aTHX_ GvGP(sv), (SV **) &GvHV(sv));
1000 4           break;
1001 1           default:
1002 1           da_localize_gvar(aTHX_ GvGP(sv), &GvSV(sv));
1003 1           GvSV(sv) = newSV(0);
1004             }
1005             }
1006 35 50         XPUSHaa(DA_ALIAS_RV, sv);
1007 35           RETURN;
1008             }
1009              
1010 2           static OP *DataAlias_pp_rv2sv_r(pTHX) {
1011             U8 savedflags;
1012 2           OP *op = PL_op, *ret;
1013              
1014 2           DataAlias_pp_rv2sv(aTHX);
1015 2           PL_stack_sp[-1] = PL_stack_sp[0];
1016 2           --PL_stack_sp;
1017              
1018 2           savedflags = op->op_private;
1019 2           op->op_private = savedflags & ~OPpLVAL_INTRO;
1020              
1021 2           ret = PL_ppaddr[op->op_type](aTHX);
1022              
1023 2           op->op_private = savedflags;
1024              
1025 2           return ret;
1026             }
1027              
1028 15           static OP *DataAlias_pp_rv2gv(pTHX) {
1029 15           dSP; dPOPss;
1030 15 100         if (SvROK(sv)) {
1031 2           wasref: sv = SvRV(sv);
1032 2 50         if (SvTYPE(sv) != SVt_PVGV)
1033 0           DIE(aTHX_ "Not a GLOB reference");
1034 13 100         } else if (SvTYPE(sv) != SVt_PVGV) {
1035 2 50         if (SvGMAGICAL(sv)) {
1036 0           mg_get(sv);
1037 0 0         if (SvROK(sv))
1038 0           goto wasref;
1039             }
1040 2 50         if (!SvOK(sv))
1041 0           DIE(aTHX_ PL_no_usym, "a symbol");
1042 2 100         if (PL_op->op_private & HINT_STRICT_REFS)
1043 1           DIE(aTHX_ msg_no_symref, SvPV_nolen(sv), "a symbol");
1044 1           sv = (SV *) gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVGV);
1045             }
1046 14 50         if (SvTYPE(sv) == SVt_PVGV)
1047 14 100         sv = (SV *) (GvEGV(sv) ? GvEGV(sv) : fixglob(aTHX_ (GV *) sv));
1048 14 100         if (PL_op->op_private & OPpLVAL_INTRO)
1049 11           save_gp((GV *) sv, !(PL_op->op_flags & OPf_SPECIAL));
1050 14 50         XPUSHaa(DA_ALIAS_GV, sv);
1051 14           RETURN;
1052             }
1053              
1054 5           static OP *DataAlias_pp_rv2av(pTHX) {
1055 5           OP *ret = PL_ppaddr[OP_RV2AV](aTHX);
1056 5           dSP;
1057 5           SV *av = POPs;
1058 5 50         XPUSHaa(DA_ALIAS_AV, av);
1059 5           PUTBACK;
1060 5           return ret;
1061             }
1062              
1063 10           static OP *DataAlias_pp_rv2hv(pTHX) {
1064 10           OP *ret = PL_ppaddr[OP_RV2HV](aTHX);
1065 10           dSP;
1066 10           SV *hv = POPs;
1067 10 50         XPUSHaa(DA_ALIAS_HV, hv);
1068 10           PUTBACK;
1069 10           return ret;
1070             }
1071              
1072 77           static OP *DataAlias_pp_sassign(pTHX) {
1073 77           dSP;
1074             SV *a1, *a2, *value;
1075 77 100         if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
1076 17           value = POPs, a2 = POPs, a1 = TOPs;
1077 17           SETs(value);
1078             } else {
1079 60           a2 = POPs, a1 = POPs, value = TOPs;
1080             }
1081 77           da_alias(aTHX_ a1, a2, value);
1082 77           RETURN;
1083             }
1084              
1085 72           static OP *DataAlias_pp_aassign(pTHX) {
1086 72           dSP;
1087             SV **left, **llast, **right, **rlast;
1088 72           I32 gimme = GIMME_V;
1089 72           I32 done = FALSE;
1090 72 50         EXTEND(sp, 1);
1091 72           left = POPMARK + PL_stack_base + 1;
1092 72           llast = SP;
1093 72           right = POPMARK + PL_stack_base + 1;
1094 72           rlast = left - 1;
1095 72 100         if (PL_op->op_private & OPpALIAS) {
1096 29           U32 hash = (PL_op->op_private & OPpALIASHV);
1097 29 100         U32 type = hash ? SVt_PVHV : SVt_PVAV;
1098 29           SV *a2 = POPs;
1099 29           SV *a1 = POPs;
1100             OPCODE savedop;
1101 29 50         if (SP != rlast)
1102 0           DIE(aTHX_ "Panic: unexpected number of lvalues");
1103 29           PUTBACK;
1104 29 100         if (right != rlast || SvTYPE(*right) != type) {
    100          
1105 8 50         PUSHMARK(right - 1);
1106 8 100         hash ? DataAlias_pp_anonhash(aTHX) : DataAlias_pp_anonlist(aTHX);
1107 8           SPAGAIN;
1108             }
1109 29           da_alias(aTHX_ a1, a2, TOPs);
1110 29           savedop = PL_op->op_type;
1111 29 100         PL_op->op_type = hash ? OP_RV2HV : OP_RV2AV;
1112 29           PL_ppaddr[PL_op->op_type](aTHX);
1113 29           PL_op->op_type = savedop;
1114 29           return NORMAL;
1115             }
1116 43           SP = right - 1;
1117 159 100         while (SP < rlast)
1118 116 100         if (!SvTEMP(*++SP))
1119 105           sv_2mortal(SvREFCNT_inc_NN(*SP));
1120 43           SP = right - 1;
1121 132 100         while (left <= llast) {
1122 90           SV *a1 = *left++, *a2;
1123 90 100         if (a1 == &PL_sv_undef) {
1124 3           right++;
1125 3           continue;
1126             }
1127 87           a2 = *left++;
1128 87           switch ((Size_t) a1) {
1129 9           case DA_ALIAS_AV: {
1130             SV **svp;
1131 9 50         if (SvRMAGICAL(a2) && da_badmagic(aTHX_ a2))
    0          
1132 0           DIE(aTHX_ DA_TIED_ERR, "put", "into", "array");
1133 9           av_clear((AV *) a2);
1134 9 50         if (done || right > rlast)
    100          
1135             break;
1136 7           av_extend((AV *) a2, rlast - right);
1137 7           AvFILLp((AV *) a2) = rlast - right;
1138 7           svp = AvARRAY((AV *) a2);
1139 27 100         while (right <= rlast)
1140 20           SvTEMP_off(*svp++ = SvREFCNT_inc_NN(*right++));
1141 7           break;
1142 10           } case DA_ALIAS_HV: {
1143 10           SV *tmp, *val, **svp = rlast;
1144 10           U32 dups = 0, nils = 0;
1145             HE *he;
1146             #if DA_FEATURE_AVHV
1147             if (SvTYPE(a2) == SVt_PVAV)
1148             goto phash;
1149             #endif
1150 10 100         if (SvRMAGICAL(a2) && da_badmagic(aTHX_ a2))
    50          
1151 0           DIE(aTHX_ DA_TIED_ERR, "put", "into", "hash");
1152 10           hv_clear((HV *) a2);
1153 10 50         if (done || right > rlast)
    100          
1154             break;
1155 8           done = TRUE;
1156 8           hv_ksplit((HV *) a2, (rlast - right + 2) >> 1);
1157 8 100         if (1 & ~(rlast - right)) {
    100          
1158 3 100         if (ckWARN(WARN_MISC))
1159 1           Perl_warner(aTHX_ packWARN(WARN_MISC),
1160             DA_ODD_HASH_ERR);
1161 2           *++svp = &PL_sv_undef;
1162             }
1163 27 100         while (svp > right) {
1164 20           val = *svp--; tmp = *svp--;
1165 20           he = hv_fetch_ent((HV *) a2, tmp, TRUE, 0);
1166 20 50         if (!he) /* is this possible? */
1167 0           DIE(aTHX_ PL_no_helem, SvPV_nolen(tmp));
1168 20           tmp = HeVAL(he);
1169 20 100         if (SvREFCNT(tmp) > 1) { /* existing element */
1170 6           svp[1] = svp[2] = NULL;
1171 6           dups += 2;
1172 6           continue;
1173             }
1174 14 100         if (val == &PL_sv_undef)
1175 5           nils++;
1176 14           SvREFCNT_dec(tmp);
1177 14           SvTEMP_off(HeVAL(he) =
1178             SvREFCNT_inc_simple_NN(val));
1179             }
1180 23 100         while (nils && (he = hv_iternext((HV *) a2))) {
    50          
1181 9 100         if (HeVAL(he) == &PL_sv_undef) {
1182 5           HeVAL(he) = &PL_sv_placeholder;
1183 5           HvPLACEHOLDERS(a2)++;
1184 5           nils--;
1185             }
1186             }
1187 7 100         if (gimme != G_LIST || !dups) {
    100          
1188 5           right = rlast - dups + 1;
1189 5           break;
1190             }
1191 15 100         while (svp++ < rlast) {
1192 13 100         if (*svp)
1193 7           *right++ = *svp;
1194             }
1195 2           break;
1196             }
1197             #if DA_FEATURE_AVHV
1198             phash: {
1199             SV *key, *val, **svp = rlast, **he;
1200             U32 dups = 0;
1201             I32 i;
1202             if (SvRMAGICAL(a2) && da_badmagic(aTHX_ a2))
1203             DIE(aTHX_ DA_TIED_ERR, "put", "into", "hash");
1204             avhv_keys((AV *) a2);
1205             av_fill((AV *) a2, 0);
1206             if (done || right > rlast)
1207             break;
1208             done = TRUE;
1209             if (1 & ~(rlast - right)) {
1210             if (ckWARN(WARN_MISC))
1211             Perl_warner(aTHX_ packWARN(WARN_MISC),
1212             DA_ODD_HASH_ERR);
1213             *++svp = &PL_sv_undef;
1214             }
1215             ENTER;
1216             while (svp > right) {
1217             val = *svp--; key = *svp--;
1218             i = da_avhv_index(aTHX_ (AV *) a2, key);
1219             he = &AvARRAY(a2)[i];
1220             if (*he != &PL_sv_undef) {
1221             svp[1] = svp[2] = NULL;
1222             dups += 2;
1223             continue;
1224             }
1225             SvREFCNT_dec(*he);
1226             if (val == &PL_sv_undef) {
1227             SAVESPTR(*he);
1228             *he = NULL;
1229             } else {
1230             if (i > AvFILLp(a2))
1231             AvFILLp(a2) = i;
1232             SvTEMP_off(*he =
1233             SvREFCNT_inc_simple_NN(val));
1234             }
1235             }
1236             LEAVE;
1237             if (gimme != G_LIST || !dups) {
1238             right = rlast - dups + 1;
1239             break;
1240             }
1241             while (svp++ < rlast) {
1242             if (*svp)
1243             *right++ = *svp;
1244             }
1245             break;
1246             }
1247             #endif
1248 68           default:
1249 68 100         if (right > rlast)
1250 14           da_alias(aTHX_ a1, a2, &PL_sv_undef);
1251 54 100         else if (done)
1252 4           da_alias(aTHX_ a1, a2, *right = &PL_sv_undef);
1253             else
1254 50           da_alias(aTHX_ a1, a2, *right);
1255 68           right++;
1256 68           break;
1257             }
1258             }
1259 42 100         if (gimme == G_LIST) {
1260 12           SP = right - 1;
1261 12 50         EXTEND(SP, 0);
1262 19 100         while (rlast < SP)
1263 7           *++rlast = &PL_sv_undef;
1264 12           RETURN;
1265 30 100         } else if (gimme == G_SCALAR) {
1266 12           dTARGET;
1267 12 50         XPUSHi(rlast - SP);
    50          
1268             }
1269 30           RETURN;
1270             }
1271              
1272 14           static OP *DataAlias_pp_andassign(pTHX) {
1273 14           dSP;
1274 14           SV *a2 = POPs;
1275 14           SV *sv = da_fetch(aTHX_ TOPs, a2);
1276 14 100         if (SvTRUE(sv)) {
1277             /* no PUTBACK */
1278 6           return cLOGOP->op_other;
1279             }
1280 8           SETs(sv);
1281 8           RETURN;
1282             }
1283              
1284 14           static OP *DataAlias_pp_orassign(pTHX) {
1285 14           dSP;
1286 14           SV *a2 = POPs;
1287 14           SV *sv = da_fetch(aTHX_ TOPs, a2);
1288 14 100         if (!SvTRUE(sv)) {
1289             /* no PUTBACK */
1290 8           return cLOGOP->op_other;
1291             }
1292 6           SETs(sv);
1293 6           RETURN;
1294             }
1295              
1296             #if DA_HAVE_OP_DORASSIGN
1297 5           static OP *DataAlias_pp_dorassign(pTHX) {
1298 5           dSP;
1299 5           SV *a2 = POPs;
1300 5           SV *sv = da_fetch(aTHX_ TOPs, a2);
1301 5 100         if (!SvOK(sv)) {
1302             /* no PUTBACK */
1303 3           return cLOGOP->op_other;
1304             }
1305 2           SETs(sv);
1306 2           RETURN;
1307             }
1308             #endif
1309              
1310 5           static OP *DataAlias_pp_push(pTHX) {
1311 5           dSP; dMARK; dORIGMARK; dTARGET;
1312 5           AV *av = (AV *) *++MARK;
1313             I32 i;
1314 5 100         if (SvRMAGICAL(av) && da_badmagic(aTHX_ (SV *) av))
    50          
1315 0           DIE(aTHX_ DA_TIED_ERR, "push", "onto", "array");
1316 5 100         i = AvFILL(av);
1317 5           av_extend(av, i + (SP - MARK));
1318 12 100         while (MARK < SP)
1319 7           av_store(av, ++i, SvREFCNT_inc_NN(*++MARK));
1320 5           SP = ORIGMARK;
1321 5 50         PUSHi(i + 1);
1322 5           RETURN;
1323             }
1324              
1325 4           static OP *DataAlias_pp_unshift(pTHX) {
1326 4           dSP; dMARK; dORIGMARK; dTARGET;
1327 4           AV *av = (AV *) *++MARK;
1328 4           I32 i = 0;
1329 4 50         if (SvRMAGICAL(av) && da_badmagic(aTHX_ (SV *) av))
    0          
1330 0           DIE(aTHX_ DA_TIED_ERR, "unshift", "onto", "array");
1331 4           av_unshift(av, SP - MARK);
1332 10 100         while (MARK < SP)
1333 6           av_store(av, i++, SvREFCNT_inc_NN(*++MARK));
1334 4           SP = ORIGMARK;
1335 4 50         PUSHi(AvFILL(av) + 1);
    50          
1336 4           RETURN;
1337             }
1338              
1339 15           static OP *DataAlias_pp_splice(pTHX) {
1340 15           dSP; dMARK; dORIGMARK;
1341 15           I32 ins = SP - MARK - 3;
1342 15           AV *av = (AV *) MARK[1];
1343             I32 off, del, count, i;
1344             SV **svp, *tmp;
1345 15 50         if (ins < 0) /* ?! */
1346 0           DIE(aTHX_ "Too few arguments for DataAlias_pp_splice");
1347 15 50         if (SvRMAGICAL(av) && da_badmagic(aTHX_ (SV *) av))
    0          
1348 0           DIE(aTHX_ DA_TIED_ERR, "splice", "onto", "array");
1349 15           count = AvFILLp(av) + 1;
1350 15           off = SvIV(MARK[2]);
1351 15 100         if (off < 0 && (off += count) < 0)
    50          
1352 0           DIE(aTHX_ PL_no_aelem, off - count);
1353 15           del = SvIV(ORIGMARK[3]);
1354 15 100         if (del < 0 && (del += count - off) < 0)
    100          
1355 1           del = 0;
1356 15 100         if (off > count) {
1357 2 100         if (ckWARN(WARN_MISC))
1358 1           Perl_warner(aTHX_ packWARN(WARN_MISC),
1359             "splice() offset past end of array");
1360 1           off = count;
1361             }
1362 14 100         if ((count -= off + del) < 0) /* count of trailing elems */
1363 1           del += count, count = 0;
1364 14           i = off + ins + count - 1;
1365 14 100         if (i > AvMAX(av))
1366 4           av_extend(av, i);
1367 14 50         if (!AvREAL(av) && AvREIFY(av))
    0          
1368 0           av_reify(av);
1369 14           AvFILLp(av) = i;
1370 14           MARK = ORIGMARK + 4;
1371 14           svp = AvARRAY(av) + off;
1372 35 100         for (i = 0; i < ins; i++)
1373 21           SvTEMP_off(SvREFCNT_inc_NN(MARK[i]));
1374 14 100         if (ins > del) {
1375 7 50         Move(svp+del, svp+ins, INT2SIZE(count), SV *);
1376 9 100         for (i = 0; i < del; i++)
1377 2           tmp = MARK[i], MARK[i-3] = svp[i], svp[i] = tmp;
1378 7 50         Copy(MARK+del, svp+del, INT2SIZE(ins-del), SV *);
1379             } else {
1380 16 100         for (i = 0; i < ins; i++)
1381 9           tmp = MARK[i], MARK[i-3] = svp[i], svp[i] = tmp;
1382 7 100         if (ins != del)
1383 3 50         Copy(svp+ins, MARK-3+ins, INT2SIZE(del-ins), SV *);
1384 7 50         Move(svp+del, svp+ins, INT2SIZE(count), SV *);
1385             }
1386 14           MARK -= 3;
1387 28 100         for (i = 0; i < del; i++)
1388 14           sv_2mortal(MARK[i]);
1389 14           SP = MARK + del - 1;
1390 14           RETURN;
1391             }
1392              
1393 58           static OP *DataAlias_pp_leave(pTHX) {
1394 58           dSP;
1395             SV **newsp;
1396             #ifdef POPBLOCK
1397             PMOP *newpm;
1398             #endif
1399             I32 gimme;
1400             PERL_CONTEXT *cx;
1401             SV *sv;
1402              
1403 58 100         if (PL_op->op_flags & OPf_SPECIAL)
1404 2           cxstack[cxstack_ix].blk_oldpm = PL_curpm;
1405              
1406             #ifdef POPBLOCK
1407             POPBLOCK(cx, newpm);
1408             gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1409             #else
1410 58           cx = CX_CUR();
1411             assert(CxTYPE(cx) == CXt_BLOCK);
1412 58           gimme = cx->blk_gimme;
1413 58           newsp = PL_stack_base + cx->blk_oldsp;
1414             #endif
1415              
1416 58 100         if (gimme == G_SCALAR) {
1417 18 50         if (newsp == SP) {
1418 0           *++newsp = &PL_sv_undef;
1419             } else {
1420 18           sv = SvREFCNT_inc_NN(TOPs);
1421 18 100         FREETMPS;
1422 18           *++newsp = sv_2mortal(sv);
1423             }
1424 40 100         } else if (gimme == G_LIST) {
1425 45 100         while (newsp < SP)
1426 27 100         if (!SvTEMP(sv = *++newsp))
1427 19           sv_2mortal(SvREFCNT_inc_simple_NN(sv));
1428             }
1429 58           PL_stack_sp = newsp;
1430             #ifdef POPBLOCK
1431             PL_curpm = newpm;
1432             LEAVE;
1433             #else
1434 58 100         CX_LEAVE_SCOPE(cx);
1435 58           cx_popblock(cx);
1436 58           CX_POP(cx);
1437             #endif
1438 58           return NORMAL;
1439             }
1440              
1441 37           static OP *DataAlias_pp_return(pTHX) {
1442 37           dSP; dMARK;
1443             I32 cxix;
1444             PERL_CONTEXT *cx;
1445 37           bool clearerr = FALSE;
1446             I32 gimme;
1447             SV **newsp;
1448             #ifdef POPBLOCK
1449             PMOP *newpm;
1450             #endif
1451 37           I32 optype = 0, type = 0;
1452 37 100         SV *sv = (MARK < SP) ? TOPs : &PL_sv_undef;
1453             OP *retop;
1454              
1455 37           cxix = cxstack_ix;
1456 38 50         while (cxix >= 0) {
1457 38           cx = &cxstack[cxix];
1458 38           type = CxTYPE(cx);
1459 38 100         if (type == CXt_EVAL || type == CXt_SUB || type == CXt_FORMAT)
    100          
    50          
1460             break;
1461 1           cxix--;
1462             }
1463              
1464             #if DA_FEATURE_MULTICALL
1465 37 50         if (cxix < 0) {
1466 0 0         if (CxMULTICALL(cxstack)) { /* sort block */
1467 0           dounwind(0);
1468 0           *(PL_stack_sp = PL_stack_base + 1) = sv;
1469 0           return 0;
1470             }
1471 0           DIE(aTHX_ "Can't return outside a subroutine");
1472             }
1473             #else
1474             if (PL_curstackinfo->si_type == PERLSI_SORT && cxix <= PL_sortcxix) {
1475             if (cxstack_ix > PL_sortcxix)
1476             dounwind(PL_sortcxix);
1477             *(PL_stack_sp = PL_stack_base + 1) = sv;
1478             return 0;
1479             }
1480             if (cxix < 0)
1481             DIE(aTHX_ "Can't return outside a subroutine");
1482             #endif
1483              
1484              
1485 37 100         if (cxix < cxstack_ix)
1486 1           dounwind(cxix);
1487              
1488             #if DA_FEATURE_MULTICALL
1489 37 50         if (CxMULTICALL(&cxstack[cxix])) {
1490 0           gimme = cxstack[cxix].blk_gimme;
1491 0 0         if (gimme == G_VOID)
1492 0           PL_stack_sp = PL_stack_base;
1493 0 0         else if (gimme == G_SCALAR)
1494 0           *(PL_stack_sp = PL_stack_base + 1) = sv;
1495 0           return 0;
1496             }
1497             #endif
1498              
1499             #ifdef POPBLOCK
1500             POPBLOCK(cx, newpm);
1501             #else
1502 37           cx = CX_CUR();
1503 37           gimme = cx->blk_gimme;
1504 37           newsp = PL_stack_base + cx->blk_oldsp;
1505             #endif
1506 37           switch (type) {
1507 25           case CXt_SUB:
1508             #if DA_FEATURE_RETOP
1509 25           retop = cx->blk_sub.retop;
1510             #endif
1511             #ifdef POPBLOCK
1512             cxstack_ix++; /* temporarily protect top context */
1513             #endif
1514 25           break;
1515 12           case CXt_EVAL:
1516 12           clearerr = !(PL_in_eval & EVAL_KEEPERR);
1517             #ifdef POPBLOCK
1518             POPEVAL(cx);
1519             #else
1520 12           cx_popeval(cx);
1521             #endif
1522             #if DA_FEATURE_RETOP
1523 12           retop = cx->blk_eval.retop;
1524             #endif
1525 12 100         if (CxTRYBLOCK(cx))
1526 5           break;
1527             lex_end();
1528 7 50         if (optype == OP_REQUIRE && !SvTRUE(sv)
    0          
1529 0 0         && (gimme == G_SCALAR || MARK == SP)) {
    0          
1530 0           sv = cx->blk_eval.old_namesv;
1531 0 0         (void) hv_delete(GvHVn(PL_incgv), SvPVX_const(sv),
1532             SvCUR(sv), G_DISCARD);
1533 0           DIE(aTHX_ "%"SVf" did not return a true value", sv);
1534             }
1535 7           break;
1536 0           case CXt_FORMAT:
1537             #ifdef POPBLOCK
1538             POPFORMAT(cx);
1539             #else
1540 0           cx_popformat(cx);
1541             #endif
1542             #if DA_FEATURE_RETOP
1543 0           retop = cx->blk_sub.retop;
1544             #endif
1545 0           break;
1546 0           default:
1547 0           DIE(aTHX_ "panic: return");
1548             retop = NULL; /* suppress "uninitialized" warning */
1549             }
1550              
1551 37           TAINT_NOT;
1552 37 100         if (gimme == G_SCALAR) {
1553 3 50         if (MARK == SP) {
1554 0           *++newsp = &PL_sv_undef;
1555             } else {
1556 3           sv = SvREFCNT_inc_NN(TOPs);
1557 3 50         FREETMPS;
1558 3           *++newsp = sv_2mortal(sv);
1559             }
1560 34 100         } else if (gimme == G_LIST) {
1561 67 100         while (MARK < SP) {
1562 43           *++newsp = sv = *++MARK;
1563 43 100         if (!SvTEMP(sv) && !(SvREADONLY(sv) && SvIMMORTAL(sv)))
    50          
    0          
    0          
    0          
1564 39           sv_2mortal(SvREFCNT_inc_simple_NN(sv));
1565 43           TAINT_NOT;
1566             }
1567             }
1568 37           PL_stack_sp = newsp;
1569             #ifdef POPBLOCK
1570             LEAVE;
1571             if (type == CXt_SUB) {
1572             cxstack_ix--;
1573             POPSUB(cx, sv);
1574             LEAVESUB(sv);
1575             }
1576             PL_curpm = newpm;
1577             #else
1578 37 100         if (type == CXt_SUB) {
1579 25           cx_popsub(cx);
1580             }
1581 37 100         CX_LEAVE_SCOPE(cx);
1582 37           cx_popblock(cx);
1583 37           CX_POP(cx);
1584             #endif
1585 37 100         if (clearerr)
1586 12 50         sv_setpvn(ERRSV, "", 0);
1587             #if (!DA_FEATURE_RETOP)
1588             retop = pop_return();
1589             #endif
1590 37           return retop;
1591             }
1592              
1593 28           static OP *DataAlias_pp_leavesub(pTHX) {
1594 28 50         if (++PL_markstack_ptr == PL_markstack_max)
1595 0           markstack_grow();
1596 28           *PL_markstack_ptr = cxstack[cxstack_ix].blk_oldsp;
1597 28           return DataAlias_pp_return(aTHX);
1598             }
1599              
1600 5           static OP *DataAlias_pp_entereval(pTHX) {
1601             dDAforce;
1602 5           PERL_CONTEXT *iscope = da_iscope;
1603 5           I32 inside = da_inside;
1604 5 50         I32 cxi = (cxstack_ix < cxstack_max) ? cxstack_ix + 1 : cxinc();
1605             OP *ret;
1606 5           da_iscope = &cxstack[cxi];
1607 5           da_inside = 1;
1608 5           ret = PL_ppaddr[OP_ENTEREVAL](aTHX);
1609 5           da_iscope = iscope;
1610 5           da_inside = inside;
1611 5           return ret;
1612             }
1613              
1614 15           static OP *DataAlias_pp_copy(pTHX) {
1615 15           dSP; dMARK;
1616             SV *sv;
1617 15           switch (GIMME_V) {
1618 2           case G_VOID:
1619 2           SP = MARK;
1620 2           break;
1621 7           case G_SCALAR:
1622 7 100         if (MARK == SP) {
1623 1           sv = sv_newmortal();
1624 1 50         EXTEND(SP, 1);
1625             } else {
1626 6           sv = TOPs;
1627 6 100         if (!SvTEMP(sv) || SvREFCNT(sv) != 1)
    50          
1628 5           sv = sv_mortalcopy(sv);
1629             }
1630 7           *(SP = MARK + 1) = sv;
1631 7           break;
1632 6           default:
1633 16 100         while (MARK < SP) {
1634 10 100         if (!SvTEMP(sv = *++MARK) || SvREFCNT(sv) != 1)
    50          
1635 8           *MARK = sv_mortalcopy(sv);
1636             }
1637             }
1638 15           RETURN;
1639             }
1640              
1641 550           static void da_lvalue(pTHX_ OP *op, int list) {
1642 550           switch (op->op_type) {
1643 24           case OP_PADSV: op->op_ppaddr = DataAlias_pp_padsv;
1644 24 100         if (PadnameOUTER(
1645             PadnamelistARRAY(PL_comppad_name)[op->op_targ])
1646 1 50         && ckWARN(WARN_CLOSURE))
1647 1           Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1648             DA_OUTER_ERR);
1649 23           break;
1650             #if DA_HAVE_OP_PADRANGE
1651 8           case OP_PADRANGE: {
1652 8           int start = op->op_targ;
1653 8           int count = op->op_private & OPpPADRANGE_COUNTMASK;
1654             int i;
1655 8 50         if (!list) goto bad;
1656 19 100         for(i = start; i != start+count; i++) {
1657 11 50         if (PadnameOUTER(
1658             PadnamelistARRAY(PL_comppad_name)[i])
1659 0 0         && ckWARN(WARN_CLOSURE))
1660 0           Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1661             DA_OUTER_ERR);
1662             }
1663 8 100         if (op->op_ppaddr != DataAlias_pp_padrange_single)
1664 7           op->op_ppaddr = DataAlias_pp_padrange_list;
1665 8           } break;
1666             #endif
1667 3           case OP_AELEM: op->op_ppaddr = DataAlias_pp_aelem; break;
1668             #if DA_HAVE_OP_AELEMFAST_LEX
1669 17           case OP_AELEMFAST_LEX:
1670             #endif
1671 17           case OP_AELEMFAST: op->op_ppaddr = DataAlias_pp_aelemfast; break;
1672 21           case OP_HELEM: op->op_ppaddr = DataAlias_pp_helem; break;
1673 3           case OP_ASLICE: op->op_ppaddr = DataAlias_pp_aslice; break;
1674 6           case OP_HSLICE: op->op_ppaddr = DataAlias_pp_hslice; break;
1675 88           case OP_GVSV: op->op_ppaddr = DataAlias_pp_gvsv; break;
1676 15           case OP_RV2SV: op->op_ppaddr = DataAlias_pp_rv2sv; break;
1677 15           case OP_RV2GV: op->op_ppaddr = DataAlias_pp_rv2gv; break;
1678 0           case OP_LIST:
1679 0 0         if (!list)
1680 0           goto bad;
1681             case OP_NULL:
1682 215 100         op = (op->op_flags & OPf_KIDS) ? cUNOPx(op)->op_first : NULL;
1683 571 100         while (op) {
1684 356           da_lvalue(aTHX_ op, list);
1685 356 100         op = OpSIBLING(op);
1686             }
1687 215           break;
1688 1           case OP_COND_EXPR:
1689 1           op = cUNOPx(op)->op_first;
1690 3 100         while ((op = OpSIBLING(op)))
    100          
1691 2           da_lvalue(aTHX_ op, list);
1692 1           break;
1693 0           case OP_SCOPE:
1694             case OP_LEAVE:
1695             case OP_LINESEQ:
1696 0 0         op = (op->op_flags & OPf_KIDS) ? cUNOPx(op)->op_first : NULL;
1697 0 0         while (OpHAS_SIBLING(op))
1698 0 0         op = OpSIBLING(op);
1699 0           da_lvalue(aTHX_ op, list);
1700 0           break;
1701 81           case OP_PUSHMARK:
1702 81 50         if (!list) goto bad;
1703 81           break;
1704 2           case OP_PADAV:
1705 2 50         if (!list) goto bad;
1706 2 50         if (op->op_ppaddr != DataAlias_pp_padsv)
1707 2           op->op_ppaddr = DataAlias_pp_padav;
1708 2           break;
1709 0           case OP_PADHV:
1710 0 0         if (!list) goto bad;
1711 0 0         if (op->op_ppaddr != DataAlias_pp_padsv)
1712 0           op->op_ppaddr = DataAlias_pp_padhv;
1713 0           break;
1714 16           case OP_RV2AV:
1715 16 50         if (!list) goto bad;
1716 16 100         if (op->op_ppaddr != DataAlias_pp_rv2sv)
1717 5           op->op_ppaddr = DataAlias_pp_rv2av;
1718 16           break;
1719 31           case OP_RV2HV:
1720 31 50         if (!list) goto bad;
1721 31 100         if (op->op_ppaddr != DataAlias_pp_rv2sv)
1722 20           op->op_ppaddr = DataAlias_pp_rv2hv;
1723 31           break;
1724 3           case OP_UNDEF:
1725 3 50         if (!list || (op->op_flags & OPf_KIDS))
    50          
1726 0           goto bad;
1727 3           break;
1728             default:
1729 1 50         bad: qerror(Perl_mess(aTHX_ DA_TARGET_ERR_AT, OutCopFILE(PL_curcop),
1730             (UV) CopLINE(PL_curcop)));
1731             }
1732 549           }
1733              
1734 89           static void da_aassign(OP *op, OP *right) {
1735             OP *left, *la, *ra;
1736 89           int hash = FALSE, pad;
1737              
1738             /* make sure it fits the model exactly */
1739 89 50         if (!right || !(left = OpSIBLING(right)) || OpHAS_SIBLING(left))
    50          
    50          
    50          
1740 0           return;
1741 89 50         if (left->op_type || !(left->op_flags & OPf_KIDS))
    50          
1742 0           return;
1743 89 50         if (!(left = cUNOPx(left)->op_first) || !IS_PUSHMARK_OR_PADRANGE(left))
    100          
    50          
1744 0           return;
1745 89 50         if (!(la = OpSIBLING(left)) || OpHAS_SIBLING(la))
    50          
    100          
1746 33           return;
1747 56 100         if (la->op_flags & OPf_PARENS)
1748 19           return;
1749 37           switch (la->op_type) {
1750 9           case OP_PADHV: hash = TRUE; case OP_PADAV: pad = TRUE; break;
1751 22           case OP_RV2HV: hash = TRUE; case OP_RV2AV: pad = FALSE; break;
1752 6           default: return;
1753             }
1754 31 50         if (right->op_type || !(right->op_flags & OPf_KIDS))
    50          
1755 0           return;
1756 31 50         if (!(right = cUNOPx(right)->op_first) ||
1757 31 100         !IS_PUSHMARK_OR_PADRANGE(right))
    50          
1758 0           return;
1759 31 100         op->op_private = hash ? OPpALIASHV : OPpALIASAV;
1760 31 100         la->op_ppaddr = pad ? DataAlias_pp_padsv : DataAlias_pp_rv2sv;
1761 31 100         if (pad) {
1762 9           la->op_type = OP_PADSV;
1763             #if DA_HAVE_OP_PADRANGE
1764 9 50         if (left->op_type == OP_PADRANGE)
1765 0           left->op_ppaddr = DataAlias_pp_padrange_single;
1766 9 100         else if (right->op_type == OP_PADRANGE &&
1767 1 50         (right->op_flags & OPf_SPECIAL))
1768 1           right->op_ppaddr = DataAlias_pp_padrange_single;
1769             #endif
1770             }
1771 31 50         if (!(ra = OpSIBLING(right)) || OpHAS_SIBLING(ra))
    50          
    100          
1772 1           return;
1773 30 100         if (ra->op_flags & OPf_PARENS)
1774 6           return;
1775 24 100         if (hash) {
1776 11 100         if (ra->op_type != OP_PADHV && ra->op_type != OP_RV2HV)
    50          
1777 0           return;
1778             } else {
1779 13 100         if (ra->op_type != OP_PADAV && ra->op_type != OP_RV2AV)
    100          
1780 1           return;
1781             }
1782 23           ra->op_flags &= -2;
1783 23           ra->op_flags |= OPf_REF;
1784             }
1785              
1786 974           static int da_transform(pTHX_ OP *op, int sib) {
1787 974           int hits = 0;
1788              
1789 4629 100         while (op) {
1790 3661           OP *kid = Nullop, *tmp;
1791 3661           int ksib = TRUE;
1792             OPCODE optype;
1793              
1794 3661 100         if (op->op_flags & OPf_KIDS)
1795 1801           kid = cUNOPx(op)->op_first;
1796              
1797 3661           ++hits;
1798 3661           switch ((optype = op->op_type)) {
1799 760           case OP_NULL:
1800 760           optype = (OPCODE) op->op_targ;
1801 2599           default:
1802 2599           --hits;
1803 2599           switch (optype) {
1804             case_OP_SETSTATE_
1805 133           case OP_NEXTSTATE:
1806             case OP_DBSTATE:
1807 133           PL_curcop = (COP *) op;
1808 133           break;
1809 241           case OP_LIST:
1810 241 100         if (op->op_ppaddr == da_tag_list) {
1811 5           da_peep2(aTHX_ op);
1812 5           return hits;
1813             }
1814 236           break;
1815             }
1816 2594           break;
1817 65           case OP_LEAVE:
1818 65 100         if (op->op_ppaddr != da_tag_entersub)
1819 62           op->op_ppaddr = DataAlias_pp_leave;
1820             else
1821 3           hits--;
1822 65           break;
1823 29           case OP_LEAVESUB:
1824             case OP_LEAVESUBLV:
1825             case OP_LEAVEEVAL:
1826             case OP_LEAVETRY:
1827 29           op->op_ppaddr = DataAlias_pp_leavesub;
1828 29           break;
1829 9           case OP_RETURN:
1830 9           op->op_ppaddr = DataAlias_pp_return;
1831 9           break;
1832 5           case OP_ENTEREVAL:
1833 5           op->op_ppaddr = DataAlias_pp_entereval;
1834 5           break;
1835 154           case OP_CONST:
1836 154           --hits;
1837             {
1838 154           SV *sv = cSVOPx_sv(op);
1839 154           SvPADTMP_off(sv);
1840 154           SvREADONLY_on(sv);
1841             }
1842 154           break;
1843 307           case OP_GVSV:
1844 307 100         if (op->op_private & OPpLVAL_INTRO)
1845 1           op->op_ppaddr = DataAlias_pp_gvsv_r;
1846             else
1847 306           hits--;
1848 307           break;
1849 137           case OP_RV2SV:
1850             case OP_RV2AV:
1851             case OP_RV2HV:
1852 137 100         if (op->op_private & OPpLVAL_INTRO)
1853 2           op->op_ppaddr = DataAlias_pp_rv2sv_r;
1854             else
1855 135           hits--;
1856 137           break;
1857 62           case OP_SREFGEN:
1858 62           op->op_ppaddr = DataAlias_pp_srefgen;
1859 62           break;
1860 4           case OP_REFGEN:
1861 4           op->op_ppaddr = DataAlias_pp_refgen;
1862 4           break;
1863             #if DA_HAVE_OP_PADSV_STORE
1864 1           case OP_PADSV_STORE:
1865 1           op->op_ppaddr = DataAlias_pp_padsv_store;
1866 1           MOD(kid);
1867 1           ksib = FALSE;
1868 1 50         if (PadnameOUTER(PadnamelistARRAY(PL_comppad_name)[op->op_targ])
1869 1 50         && ckWARN(WARN_CLOSURE))
1870 0           Perl_warner(aTHX_ packWARN(WARN_CLOSURE), DA_OUTER_ERR);
1871 1           break;
1872             #endif
1873             #if DA_HAVE_OP_AELEMFASTLEX_STORE
1874 0           case OP_AELEMFASTLEX_STORE:
1875 0           op->op_ppaddr = DataAlias_pp_aelemfastlex_store;
1876 0           MOD(kid);
1877 0           ksib = FALSE;
1878 0           break;
1879             #endif
1880 89           case OP_AASSIGN:
1881 89           op->op_ppaddr = DataAlias_pp_aassign;
1882 89           op->op_private = 0;
1883 89           da_aassign(op, kid);
1884 89           MOD(kid);
1885 89           ksib = FALSE;
1886             #if DA_HAVE_OP_PADRANGE
1887 178 100         for (tmp = kid; tmp->op_type == OP_NULL &&
1888 89 50         (tmp->op_flags & OPf_KIDS); )
1889 89           tmp = cUNOPx(tmp)->op_first;
1890 89 100         if (tmp->op_type == OP_PADRANGE &&
1891 7 100         (tmp->op_flags & OPf_SPECIAL))
1892 6           da_lvalue(aTHX_ tmp, TRUE);
1893             else
1894             #endif
1895 83 50         da_lvalue(aTHX_ OpSIBLING(kid), TRUE);
1896 89           break;
1897 103           case OP_SASSIGN:
1898              
1899 103           op->op_ppaddr = DataAlias_pp_sassign;
1900 103           MOD(kid);
1901 103           ksib = FALSE;
1902 103 100         if (!(op->op_private & OPpASSIGN_BACKWARDS))
1903 68 50         da_lvalue(aTHX_ OpSIBLING(kid), FALSE);
1904 102           break;
1905 15           case OP_ANDASSIGN:
1906 15           op->op_ppaddr = DataAlias_pp_andassign;
1907             if (0)
1908             case OP_ORASSIGN:
1909 15           op->op_ppaddr = DataAlias_pp_orassign;
1910             #if DA_HAVE_OP_DORASSIGN
1911             if (0)
1912             case OP_DORASSIGN:
1913 5           op->op_ppaddr = DataAlias_pp_dorassign;
1914             #endif
1915 35           da_lvalue(aTHX_ kid, FALSE);
1916 35 50         kid = OpSIBLING(kid);
1917 35           break;
1918 6           case OP_UNSHIFT:
1919 6 50         if (!(tmp = OpSIBLING(kid))) break; /* array */
    50          
1920 6 100         if (!(tmp = OpSIBLING(tmp))) break; /* first elem */
    100          
1921 4           op->op_ppaddr = DataAlias_pp_unshift;
1922 4           goto mod;
1923 7           case OP_PUSH:
1924 7 50         if (!(tmp = OpSIBLING(kid))) break; /* array */
    50          
1925 7 100         if (!(tmp = OpSIBLING(tmp))) break; /* first elem */
    100          
1926 5           op->op_ppaddr = DataAlias_pp_push;
1927 5           goto mod;
1928 21           case OP_SPLICE:
1929 21 50         if (!(tmp = OpSIBLING(kid))) break; /* array */
    50          
1930 21 100         if (!(tmp = OpSIBLING(tmp))) break; /* offset */
    100          
1931 20 100         if (!(tmp = OpSIBLING(tmp))) break; /* length */
    100          
1932 19 100         if (!(tmp = OpSIBLING(tmp))) break; /* first elem */
    100          
1933 15           op->op_ppaddr = DataAlias_pp_splice;
1934 15           goto mod;
1935 7           case OP_ANONLIST:
1936 7 50         if (!(tmp = OpSIBLING(kid))) break; /* first elem */
    50          
1937 7           op->op_ppaddr = DataAlias_pp_anonlist;
1938 7           goto mod;
1939 16           case OP_ANONHASH:
1940 16 50         if (!(tmp = OpSIBLING(kid))) break; /* first elem */
    50          
1941 16           op->op_ppaddr = DataAlias_pp_anonhash;
1942 96 100         mod: do MOD(tmp); while ((tmp = OpSIBLING(tmp)));
    100          
1943 47           break;
1944             #if DA_HAVE_OP_EMPTYAVHV
1945 5           case OP_EMPTYAVHV:
1946 5           break;
1947             #endif
1948             }
1949              
1950 3655 100         if (sib && OpHAS_SIBLING(op)) {
    100          
1951 1519 100         if (kid)
1952 627           hits += da_transform(aTHX_ kid, ksib);
1953 1519 50         op = OpSIBLING(op);
1954             } else {
1955 2136           op = kid;
1956 2136           sib = ksib;
1957             }
1958             }
1959              
1960 968           return hits;
1961             }
1962              
1963 218518           static void da_peep2(pTHX_ OP *o) {
1964             OP *k, *lsop, *pmop, *argop, *cvop, *esop;
1965             int useful;
1966 218518           while (o->op_ppaddr != da_tag_list
1967             #if (PERL_COMBI_VERSION >= 5031002)
1968 516985 100         && o->op_ppaddr != da_tag_enter
    100          
1969             #endif
1970             ) {
1971 1110796 100         while (OpHAS_SIBLING(o)) {
1972 594148 100         if ((o->op_flags & OPf_KIDS) && (k = cUNOPo->op_first)){
    50          
1973 196643           da_peep2(aTHX_ k);
1974 397505 100         } else switch (o->op_type ? o->op_type : o->op_targ) {
    100          
1975             case_OP_SETSTATE_
1976 112171           case OP_NEXTSTATE:
1977             case OP_DBSTATE:
1978 112171           PL_curcop = (COP *) o;
1979             }
1980 594146 50         o = OpSIBLING(o);
1981             }
1982 516648 100         if (!(o->op_flags & OPf_KIDS) || !(o = cUNOPo->op_first))
    50          
1983 218181           return;
1984             }
1985             #if (PERL_COMBI_VERSION >= 5031002)
1986 335 100         if (o->op_ppaddr == da_tag_enter) {
1987 10 50         o = OpSIBLING(o);
1988             assert(o);
1989             }
1990             #endif
1991 335           lsop = o;
1992 335           useful = lsop->op_private & OPpUSEFUL;
1993 335           op_null(lsop);
1994 335           lsop->op_ppaddr = PL_ppaddr[OP_NULL];
1995 335           pmop = cLISTOPx(lsop)->op_first;
1996 335           argop = cLISTOPx(lsop)->op_last;
1997 335 50         if (!(cvop = cUNOPx(pmop)->op_first) ||
1998 335 50         cvop->op_ppaddr != da_tag_rv2cv) {
1999 0           Perl_warn(aTHX_ "da peep weirdness 1");
2000 0           return;
2001             }
2002 335           OpMORESIB_set(argop, cvop);
2003 335           OpLASTSIB_set(cvop, lsop);
2004 335           cLISTOPx(lsop)->op_last = cvop;
2005 335 50         if (!(esop = cvop->op_next) || esop->op_ppaddr != da_tag_entersub) {
    50          
2006 0           Perl_warn(aTHX_ "da peep weirdness 2");
2007 0           return;
2008             }
2009 335           esop->op_type = OP_ENTERSUB;
2010             #if (PERL_COMBI_VERSION >= 5031002)
2011 335 100         if (cLISTOPx(esop)->op_first->op_ppaddr == da_tag_enter) {
2012             /* the first is a dummy op we inserted to satisfy Perl_scalar/list.
2013             we can't remove it since an op_next points at it, so null it out.
2014             */
2015 13           OP *nullop = cLISTOPx(esop)->op_first;
2016             assert(nullop->op_type == OP_ENTER);
2017             assert(OpSIBLING(nullop));
2018 13           nullop->op_type = OP_NULL;
2019 13           nullop->op_ppaddr = PL_ppaddr[OP_NULL];
2020             }
2021             #endif
2022 335 100         if (cvop->op_flags & OPf_SPECIAL) {
2023 13           esop->op_ppaddr = DataAlias_pp_copy;
2024 13           da_peep2(aTHX_ pmop);
2025 322 100         } else if (!da_transform(aTHX_ pmop, TRUE)
2026 30 100         && !useful && ckWARN(WARN_VOID)) {
    100          
2027 1           Perl_warner(aTHX_ packWARN(WARN_VOID),
2028             "Useless use of alias");
2029             }
2030             }
2031              
2032 21882           static void da_peep(pTHX_ OP *o) {
2033             dDAforce;
2034 21882           da_old_peepp(aTHX_ o);
2035 21882           ENTER;
2036 21882           SAVEVPTR(PL_curcop);
2037 21882 50         if (da_inside < 0)
2038 0           Perl_croak(aTHX_ "Data::Alias confused in da_peep (da_inside < 0)");
2039 21907 100         if (da_inside && da_iscope == &cxstack[cxstack_ix]) {
    100          
2040             OP *tmp;
2041 141 100         while ((tmp = o->op_next))
2042 116           o = tmp;
2043 25 50         if (da_transform(aTHX_ o, FALSE))
2044 25           da_inside = 2;
2045             } else {
2046 21857           da_peep2(aTHX_ o);
2047             }
2048 21880           LEAVE;
2049 21880           }
2050              
2051             #define LEX_NORMAL 10
2052             #define LEX_INTERPNORMAL 9
2053             #if DA_HAVE_LEX_KNOWNEXT
2054             #define LEX_KNOWNEXT 0
2055             #endif
2056              
2057 48015           static OP *da_ck_rv2cv(pTHX_ OP *o) {
2058             dDA;
2059             SV **sp, *gvsv;
2060             OP *kid;
2061             char *s, *start_s;
2062             CV *cv;
2063             I32 inside;
2064 48015           o = da_old_ck_rv2cv(aTHX_ o);
2065             #if (PERL_COMBI_VERSION >= 5009005)
2066 48015 50         if (!PL_parser)
2067 0           return o;
2068             #endif
2069 48015 50         if (PL_lex_state != LEX_NORMAL && PL_lex_state != LEX_INTERPNORMAL)
    0          
2070 0           return o; /* not lexing? */
2071 48015           kid = cUNOPo->op_first;
2072 48015 100         if (kid->op_type != OP_GV || !DA_ACTIVE)
2073 3895           return o;
2074 44120           gvsv = (SV*)kGVOP_gv;
2075             #if (PERL_COMBI_VERSION >= 5021004)
2076 44120 100         cv = SvROK(gvsv) ? (CV*)SvRV(gvsv) : GvCV((GV*)gvsv);
2077             #else
2078             cv = GvCV((GV*)gvsv);
2079             #endif
2080 44120 100         if (cv == da_cv) /* Data::Alias::alias */
2081 461           inside = 1;
2082 43659 100         else if (cv == da_cvc) /* Data::Alias::copy */
2083 17           inside = 0;
2084             else
2085 43642           return o;
2086 478 100         if (o->op_private & OPpENTERSUB_AMPER)
2087 2           return o;
2088              
2089             /* make sure the temporary ($) prototype for the parser hack is removed */
2090 476           SvPOK_off(cv);
2091              
2092             /* tag the op for later recognition */
2093 476           o->op_ppaddr = da_tag_rv2cv;
2094 476 100         if (inside)
2095 459           o->op_flags &= ~OPf_SPECIAL;
2096             else
2097 17           o->op_flags |= OPf_SPECIAL;
2098              
2099 476           start_s = s = PL_oldbufptr;
2100 524 50         while (s < PL_bufend && isSPACE(*s)) s++;
    100          
2101              
2102 476 50         if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf))) {
2103 476           s += strlen(PL_tokenbuf);
2104 476 100         if (PL_bufptr > s) s = PL_bufptr;
2105             #if (PERL_COMBI_VERSION >= 5011002)
2106             {
2107 476           char *old_buf = SvPVX(PL_linestr);
2108 476           char *old_bufptr = PL_bufptr;
2109 476           PL_bufptr = s;
2110 476           lex_read_space(LEX_KEEP_PREVIOUS);
2111 476 50         if (SvPVX(PL_linestr) != old_buf)
2112 0           Perl_croak(aTHX_ "Data::Alias can't handle "
2113             "lexer buffer reallocation");
2114 476           s = PL_bufptr;
2115 476           PL_bufptr = old_bufptr;
2116             }
2117             #else
2118             while (s < PL_bufend && isSPACE(*s)) s++;
2119             #endif
2120             } else {
2121 0           s = "";
2122             }
2123              
2124             /* if not already done, localize da_inside to this compilation scope. */
2125             /* this ensures it will get restored if we bail out with a compile error. */
2126 476 100         if (da_iscope != &cxstack[cxstack_ix]) {
2127 38           SAVEVPTR(da_iscope);
2128 38           SAVEI32(da_inside);
2129 38           da_iscope = &cxstack[cxstack_ix];
2130             }
2131              
2132             #if (PERL_COMBI_VERSION >= 5011002)
2133             /* since perl 5.11.2, when a sub is called with parenthesized argument the */
2134             /* initial rv2cv op gets destroyed and a new one is created. deal with that. */
2135 476 100         if (da_inside < 0) {
2136 141 50         if (*s != '(' || da_inside != ~inside)
    50          
2137 0           Perl_croak(aTHX_ "Data::Alias confused in da_ck_rv2cv");
2138             } else
2139             #endif
2140             {
2141             /* save da_inside on stack, restored in da_ck_entersub */
2142 335           SPAGAIN;
2143 335 50         XPUSHs(da_inside ? &PL_sv_yes : &PL_sv_no);
    100          
2144 335           PUTBACK;
2145             }
2146             #if (PERL_COMBI_VERSION >= 5011002)
2147 476 100         if (*s == '(' && da_inside >= 0) {
    100          
2148 141           da_inside = ~inside; /* first rv2cv op (will be discarded) */
2149 141           return o;
2150             }
2151             #endif
2152 335           da_inside = inside;
2153              
2154 335 100         if (*s == '{') { /* disgusting parser hack for alias BLOCK (and copy BLOCK) */
2155             I32 shift;
2156             int tok;
2157 73           YYSTYPE yylval = PL_yylval;
2158 73           PL_bufptr = s;
2159 73           PL_expect = XSTATE;
2160 73           tok = yylex();
2161 73           PL_nexttype[PL_nexttoke++] = tok;
2162 73 50         if (tok == '{'
2163             #if PERL_COMBI_VERSION >= 5033006
2164 73 100         || tok == PERLY_BRACE_OPEN
2165             #endif
2166             ) {
2167 61           PL_nexttype[PL_nexttoke++] = KW_DO;
2168 61           sv_setpv((SV *) cv, "$");
2169             if ((PERL_COMBI_VERSION >= 5021004) ||
2170             (PERL_COMBI_VERSION >= 5011002 &&
2171             *PL_bufptr == '(')) {
2172             /*
2173             * On 5.21.4+, PL_expect can't be
2174             * directly set as we'd like, and ends
2175             * up wrong for parsing the interior of
2176             * the block. Rectify it by injecting
2177             * a semicolon, lexing of which sets
2178             * PL_expect appropriately. On 5.11.2+,
2179             * a paren here triggers special lexer
2180             * behaviour for a parenthesised argument
2181             * list, which screws up the normal
2182             * parsing that we want to continue.
2183             * Suppress it by injecting a semicolon.
2184             * Either way, apart from this tweaking of
2185             * the lexer the semicolon is a no-op,
2186             * coming as it does just after the
2187             * opening brace of a block.
2188             */
2189 61           Move(PL_bufptr, PL_bufptr+1,
2190             PL_bufend+1-PL_bufptr, char);
2191 61           *PL_bufptr = ';';
2192 61           PL_bufend++;
2193 61           SvCUR_set(PL_linestr, SvCUR(PL_linestr)+1);
2194             }
2195             }
2196             #if DA_HAVE_LEX_KNOWNEXT
2197             if(PL_lex_state != LEX_KNOWNEXT) {
2198             PL_lex_defer = PL_lex_state;
2199             #if (PERL_COMBI_VERSION < 5021004)
2200             PL_lex_expect = PL_expect;
2201             #endif
2202             PL_lex_state = LEX_KNOWNEXT;
2203             }
2204             #endif
2205 73           PL_yylval = yylval;
2206 73 50         if ((shift = s - PL_bufptr)) { /* here comes deeper magic */
2207 73           s = SvPVX(PL_linestr);
2208 73           PL_bufptr += shift;
2209 73 50         if ((PL_oldbufptr += shift) < s)
2210 0           PL_oldbufptr = s;
2211 73 100         if ((PL_oldoldbufptr += shift) < s)
2212 27           PL_oldbufptr = s;
2213 73 100         if (PL_last_uni && (PL_last_uni += shift) < s)
    50          
2214 0           PL_last_uni = s;
2215 73 100         if (PL_last_lop && (PL_last_lop += shift) < s)
    100          
2216 36           PL_last_lop = s;
2217 73 50         if (shift > 0) {
2218 0           STRLEN len = SvCUR(PL_linestr) + 1;
2219 0 0         if (len + shift > SvLEN(PL_linestr))
2220 0           len = SvLEN(PL_linestr) - shift;
2221 0           Move(s, s + shift, len, char);
2222 0           SvCUR_set(PL_linestr, len + shift - 1);
2223             } else {
2224 73           STRLEN len = SvCUR(PL_linestr) + shift + 1;
2225 73           Move(s - shift, s, len, char);
2226 73           SvCUR_set(PL_linestr, SvCUR(PL_linestr) + shift);
2227             }
2228 73           *(PL_bufend = s + SvCUR(PL_linestr)) = '\0';
2229 73 50         if (start_s < PL_bufptr)
2230 73           memset(start_s, ' ', PL_bufptr-start_s);
2231             }
2232             }
2233 335           return o;
2234             }
2235              
2236 45280           static OP *da_ck_entersub(pTHX_ OP *esop) {
2237             dDA;
2238             OP *lsop, *cvop, *pmop, *argop;
2239             I32 inside;
2240 45280 50         if (!(esop->op_flags & OPf_KIDS))
2241 0           return da_old_ck_entersub(aTHX_ esop);
2242 45280           lsop = cUNOPx(esop)->op_first;
2243 45280 50         if (!(lsop->op_type == OP_LIST ||
2244 45280 100         (lsop->op_type == OP_NULL && lsop->op_targ == OP_LIST))
    50          
2245 30875 50         || OpHAS_SIBLING(lsop) || !(lsop->op_flags & OPf_KIDS))
    50          
2246 14405           return da_old_ck_entersub(aTHX_ esop);
2247 30875           cvop = cLISTOPx(lsop)->op_last;
2248 30875 100         if (!DA_ACTIVE || cvop->op_ppaddr != da_tag_rv2cv)
2249 30540           return da_old_ck_entersub(aTHX_ esop);
2250 335           inside = da_inside;
2251 335 50         if (inside < 0)
2252 0           Perl_croak(aTHX_ "Data::Alias confused in da_ck_entersub (da_inside < 0)");
2253 335           da_inside = SvIVX(*PL_stack_sp--);
2254 335 100         SvPOK_off(inside ? da_cv : da_cvc);
    100          
2255 335           op_clear(esop);
2256 335           RenewOpc(0, esop, 1, LISTOP, OP);
2257 335           OpLASTSIB_set(lsop, esop);
2258 335 100         esop->op_type = inside ? OP_SCOPE : OP_LEAVE;
2259 335           esop->op_ppaddr = da_tag_entersub;
2260             #if (PERL_COMBI_VERSION >= 5031002)
2261 335 100         if (!inside && !OpHAS_SIBLING(lsop)) {
    50          
2262             /* esop is now a leave, and Perl_scalar/Perl_list expects at least two children.
2263             we insert it in the middle (and null it later) since Perl_scalar()
2264             tries to find the last non-(null/state) op *after* the expected enter.
2265             */
2266             OP *enterop;
2267 13           NewOp(0, enterop, 1, OP);
2268 13           enterop->op_type = OP_ENTER;
2269 13           enterop->op_ppaddr = da_tag_enter;
2270 13           cLISTOPx(esop)->op_first = enterop;
2271 13           OpMORESIB_set(enterop, lsop);
2272 13           OpLASTSIB_set(lsop, esop);
2273             }
2274             #endif
2275 335           cLISTOPx(esop)->op_last = lsop;
2276 335           lsop->op_type = OP_LIST;
2277 335           lsop->op_targ = 0;
2278 335           lsop->op_ppaddr = da_tag_list;
2279 335 100         if (inside > 1)
2280 20           lsop->op_private |= OPpUSEFUL;
2281             else
2282 315           lsop->op_private &= ~OPpUSEFUL;
2283 335           pmop = cLISTOPx(lsop)->op_first;
2284 335 100         if (inside)
2285 322           op_null(pmop);
2286 335           RenewOpc(0, pmop, 1, UNOP, OP);
2287 335           cLISTOPx(lsop)->op_first = pmop;
2288             #if (PERL_COMBI_VERSION >= 5021006)
2289 335           pmop->op_type = OP_CUSTOM;
2290             #endif
2291 335           pmop->op_next = pmop;
2292 335           cUNOPx(pmop)->op_first = cvop;
2293 335           OpLASTSIB_set(cvop, pmop);
2294 335           argop = pmop;
2295 676 50         while (OpSIBLING(argop) != cvop)
    100          
2296 341 50         argop = OpSIBLING(argop);
2297 335           cLISTOPx(lsop)->op_last = argop;
2298 335           OpLASTSIB_set(argop, lsop);
2299 335 100         if (argop->op_type == OP_NULL && inside)
    100          
2300 94           argop->op_flags &= ~OPf_SPECIAL;
2301 335           cvop->op_next = esop;
2302 335           return esop;
2303             }
2304              
2305             #if (PERL_COMBI_VERSION >= 5021007)
2306 13215           static OP *da_ck_aelem(pTHX_ OP *o) { return da_old_ck_aelem(aTHX_ o); }
2307 23070           static OP *da_ck_helem(pTHX_ OP *o) { return da_old_ck_helem(aTHX_ o); }
2308             #endif
2309              
2310             MODULE = Data::Alias PACKAGE = Data::Alias
2311              
2312             PROTOTYPES: DISABLE
2313              
2314             BOOT:
2315             {
2316             dDA;
2317             DA_INIT;
2318 30           da_cv = get_cv("Data::Alias::alias", TRUE);
2319 30           da_cvc = get_cv("Data::Alias::copy", TRUE);
2320 30           wrap_op_checker(OP_RV2CV, da_ck_rv2cv, &da_old_ck_rv2cv);
2321 30           wrap_op_checker(OP_ENTERSUB, da_ck_entersub, &da_old_ck_entersub);
2322             #if (PERL_COMBI_VERSION >= 5021007)
2323             {
2324             /*
2325             * The multideref peep-time optimisation, introduced in
2326             * Perl 5.21.7, is liable to incorporate into a multideref
2327             * op aelem/helem ops that we need to modify. Because our
2328             * modification of those ops gets applied late at peep
2329             * time, after the main peeper, the specialness of the
2330             * ops doesn't get a chance to inhibit incorporation
2331             * into a multideref. As an ugly hack, we disable the
2332             * multideref optimisation entirely for these op types
2333             * by hooking their checking (and not actually doing
2334             * anything in the checker).
2335             *
2336             * The multideref peep-time code has no logical
2337             * reason to look at whether the op checking is in a
2338             * non-default state. It deals with already-checked ops,
2339             * so a check hook cannot make any difference to the
2340             * future behaviour of those ops. Rather, it should,
2341             * but currently (5.23.4) doesn't, check that op_ppaddr
2342             * of the op to be incorporated has the standard value.
2343             * If the superfluous PL_check[] check goes away, this
2344             * hack will break.
2345             *
2346             * The proper fix for this problem would be to move our op
2347             * munging from peep time to op check time. When ops are
2348             * placed into an alias() wrapper they should be walked,
2349             * and the contained assignments and lvalues modified.
2350             * The modified lvalue aelem/helem ops would thereby be
2351             * made visibly non-standard in plenty of time for the
2352             * multideref peep-time code to avoid replacing them.
2353             * If the multideref code is changed to look at op_ppaddr
2354             * then that change alone will be sufficient; failing
2355             * that the op_type can be changed to OP_CUSTOM.
2356             */
2357 30           wrap_op_checker(OP_AELEM, da_ck_aelem, &da_old_ck_aelem);
2358 30           wrap_op_checker(OP_HELEM, da_ck_helem, &da_old_ck_helem);
2359             }
2360             #endif
2361 30           CvLVALUE_on(get_cv("Data::Alias::deref", TRUE));
2362 30           da_old_peepp = PL_peepp;
2363 30           PL_peepp = da_peep;
2364             }
2365              
2366             void
2367             deref(...)
2368             PREINIT:
2369 13           I32 i, n = 0;
2370             SV *sv;
2371             PPCODE:
2372 35 100         for (i = 0; i < items; i++) {
2373 27 100         if (!SvROK(ST(i))) {
2374             STRLEN z;
2375 3 100         if (SvOK(ST(i)))
2376 1           Perl_croak(aTHX_ DA_DEREF_ERR, SvPV(ST(i), z));
2377 2 100         if (ckWARN(WARN_UNINITIALIZED))
2378 1           Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED),
2379             "Use of uninitialized value in deref");
2380 1           continue;
2381             }
2382 24           sv = SvRV(ST(i));
2383 24           switch (SvTYPE(sv)) {
2384             I32 x;
2385 4           case SVt_PVAV:
2386 4 100         if (!(x = av_len((AV *) sv) + 1))
2387 1           continue;
2388 3           SP += x;
2389 3           break;
2390 3           case SVt_PVHV:
2391 3 50         if (!(x = HvKEYS(sv)))
    100          
2392 1           continue;
2393 2           SP += x * 2;
2394 2           break;
2395 1           case SVt_PVCV:
2396 1           Perl_croak(aTHX_ "Can't deref subroutine reference");
2397 1           case SVt_PVFM:
2398 1           Perl_croak(aTHX_ "Can't deref format reference");
2399 1           case SVt_PVIO:
2400 1           Perl_croak(aTHX_ "Can't deref filehandle reference");
2401 14           default:
2402 14           SP++;
2403             }
2404 19           ST(n++) = ST(i);
2405             }
2406 8 50         EXTEND(SP, 0);
2407 27 100         for (i = 0; n--; ) {
2408 19           SV *sv = SvRV(ST(n));
2409 19           I32 x = SvTYPE(sv);
2410 19 100         if (x == SVt_PVAV) {
2411 3 50         i -= x = AvFILL((AV *) sv) + 1;
2412 3 50         Copy(AvARRAY((AV *) sv), SP + i + 1, INT2SIZE(x), SV *);
2413 16 100         } else if (x == SVt_PVHV) {
2414             HE *entry;
2415 2           HV *hv = (HV *) sv;
2416 2           i -= x = hv_iterinit(hv) * 2;
2417 2           PUTBACK;
2418 6 100         while ((entry = hv_iternext(hv))) {
2419 4           sv = hv_iterkeysv(entry);
2420 4           SvREADONLY_on(sv);
2421 4           SPAGAIN;
2422 4           SP[++i] = sv;
2423 4           sv = hv_iterval(hv, entry);
2424 4           SPAGAIN;
2425 4           SP[++i] = sv;
2426             }
2427 2           i -= x;
2428             } else {
2429 14           SP[i--] = sv;
2430             }
2431             }