1 /* pp_hot.c
2 *
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11 /*
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
13 * shaking the air.
14 *
15 * Awake! Awake! Fear, Fire, Foes! Awake!
16 * Fire, Foes! Awake!
17 *
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
19 */
20
21 /* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
26 *
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
31 * performance.
32 */
33
34 #include "EXTERN.h"
35 #define PERL_IN_PP_HOT_C
36 #include "perl.h"
37 #include "regcomp.h"
38 #include "feature.h"
39
40 /* Hot code. */
41
42
43 #ifdef PERL_RC_STACK
44
45 /* common code for pp_wrap() and xs_wrap():
46 * free any original arguments, and bump and shift down any return
47 * args
48 */
49
50 STATIC void
S_pp_xs_wrap_return(pTHX_ I32 nargs,I32 old_sp)51 S_pp_xs_wrap_return(pTHX_ I32 nargs, I32 old_sp)
52 {
53 I32 nret = (I32)(PL_stack_sp - PL_stack_base) - old_sp;
54 assert(nret >= 0);
55
56 /* bump any returned values */
57 if (nret) {
58 SV **svp = PL_stack_sp - nret + 1;
59 while (svp <= PL_stack_sp) {
60 SvREFCNT_inc(*svp);
61 svp++;
62 }
63 }
64
65 PL_curstackinfo->si_stack_nonrc_base = 0;
66
67 /* free the original args and shift the returned valued down */
68 if (nargs) {
69 SV **svp = PL_stack_sp - nret;
70 I32 i = nargs;
71 while (i--) {
72 SvREFCNT_dec(*svp);
73 *svp = NULL;
74 svp--;
75 }
76
77 if (nret) {
78 Move(PL_stack_sp - nret + 1,
79 PL_stack_sp - nret - nargs + 1,
80 nret, SV*);
81 }
82 PL_stack_sp -= nargs;
83 }
84 }
85
86 /* pp_wrap():
87 * wrapper function for pp() functions to turn them into functions
88 * that can operate on a reference-counted stack, by taking a non-
89 * reference-counted copy of the current stack frame, calling the real
90 * pp() function, then incrementing the reference count of any returned
91 * args.
92 *
93 * nargs or nlists indicate the number of stack arguments or the
94 * number of stack lists (delimited by MARKs) which the function expects.
95 */
96 OP*
Perl_pp_wrap(pTHX_ Perl_ppaddr_t real_pp_fn,I32 nargs,int nlists)97 Perl_pp_wrap(pTHX_ Perl_ppaddr_t real_pp_fn, I32 nargs, int nlists)
98 {
99 PERL_ARGS_ASSERT_PP_WRAP;
100
101 if (!rpp_stack_is_rc())
102 /* stack-already non-RC; nothing needing wrapping */
103 return real_pp_fn(aTHX);
104
105 OP *next_op;
106 I32 old_sp = (I32)(PL_stack_sp - PL_stack_base);
107
108 assert(nargs >= 0);
109 assert(nlists >= 0);
110 assert(AvREAL(PL_curstack));
111
112 PL_curstackinfo->si_stack_nonrc_base = PL_stack_sp - PL_stack_base + 1;
113
114 if (nlists) {
115 assert(nargs == 0);
116 I32 mark = PL_markstack_ptr[-nlists+1];
117 nargs = (PL_stack_sp - PL_stack_base) - mark;
118 assert(nlists <= 2); /* if ever more, make below a loop */
119 PL_markstack_ptr[0] += nargs;
120 if (nlists == 2)
121 PL_markstack_ptr[-1] += nargs;
122 }
123
124 if (nargs) {
125 /* duplicate all the arg pointers further up the stack */
126 rpp_extend(nargs);
127 Copy(PL_stack_sp - nargs + 1, PL_stack_sp + 1, nargs, SV*);
128 PL_stack_sp += nargs;
129 }
130
131 next_op = real_pp_fn(aTHX);
132
133 /* we should still be a split stack */
134 assert(AvREAL(PL_curstack));
135 assert(PL_curstackinfo->si_stack_nonrc_base);
136
137 S_pp_xs_wrap_return(aTHX_ nargs, old_sp);
138
139 return next_op;
140 }
141
142
143 /* xs_wrap():
144 * similar in concept to pp_wrap: make a non-referenced-counted copy of
145 * a (not refcount aware) XS sub's args, call the XS subs, then bump any
146 * return values and free the original args */
147
148 void
Perl_xs_wrap(pTHX_ XSUBADDR_t xsub,CV * cv)149 Perl_xs_wrap(pTHX_ XSUBADDR_t xsub, CV *cv)
150 {
151 PERL_ARGS_ASSERT_XS_WRAP;
152
153 I32 old_sp = (I32)(PL_stack_sp - PL_stack_base);
154 I32 mark = PL_markstack_ptr[0];
155 I32 nargs = (PL_stack_sp - PL_stack_base) - mark;
156
157 /* we should be a fully refcounted stack */
158 assert(AvREAL(PL_curstack));
159 assert(!PL_curstackinfo->si_stack_nonrc_base);
160
161 PL_curstackinfo->si_stack_nonrc_base = PL_stack_sp - PL_stack_base + 1;
162
163
164 if (nargs) {
165 /* duplicate all the arg pointers further up the stack */
166 rpp_extend(nargs);
167 Copy(PL_stack_sp - nargs + 1, PL_stack_sp + 1, nargs, SV*);
168 PL_stack_sp += nargs;
169 PL_markstack_ptr[0] += nargs;
170 }
171
172 xsub(aTHX_ cv);
173
174 S_pp_xs_wrap_return(aTHX_ nargs, old_sp);
175 }
176
177 #endif
178
179
180
181 /* Private helper function for Perl_rpp_replace_2_1_COMMON()
182 * and rpp_popfree_2_NN().
183 * Free the two passed SVs, whose original ref counts are rc1 and rc2.
184 * Assumes the stack initially looked like
185 * .... sv1 sv2
186 * and is now:
187 * .... X
188 * but where sv2 is still on the slot above the current PL_stack_sp.
189 */
190
191 void
Perl_rpp_free_2_(pTHX_ SV * const sv1,SV * const sv2,const U32 rc1,const U32 rc2)192 Perl_rpp_free_2_(pTHX_ SV *const sv1, SV *const sv2,
193 const U32 rc1, const U32 rc2)
194 {
195
196 PERL_ARGS_ASSERT_RPP_FREE_2_;
197
198 #ifdef PERL_RC_STACK
199 if (rc1 > 1)
200 SvREFCNT(sv1) = rc1 - 1;
201 else {
202 /* temporarily reclaim sv2 on stack in case we die while freeing sv1 */
203 assert(PL_stack_sp[1] == sv2);
204 PL_stack_sp++;
205 Perl_sv_free2(aTHX_ sv1, rc1);
206 PL_stack_sp--;
207 }
208 if (rc2 > 1)
209 SvREFCNT(sv2) = rc2 - 1;
210 else
211 Perl_sv_free2(aTHX_ sv2, rc2);
212 #else
213 PERL_UNUSED_VAR(sv1);
214 PERL_UNUSED_VAR(sv2);
215 PERL_UNUSED_VAR(rc1);
216 PERL_UNUSED_VAR(rc2);
217 #endif
218 }
219
220
221
222 /* ----------------------------------------------------------- */
223
224
PP(pp_const)225 PP(pp_const)
226 {
227 rpp_xpush_1(cSVOP_sv);
228 return NORMAL;
229 }
230
PP(pp_nextstate)231 PP(pp_nextstate)
232 {
233 PL_curcop = (COP*)PL_op;
234 TAINT_NOT; /* Each statement is presumed innocent */
235 rpp_popfree_to_NN(PL_stack_base + CX_CUR()->blk_oldsp);
236 FREETMPS;
237 PERL_ASYNC_CHECK();
238 return NORMAL;
239 }
240
PP(pp_gvsv)241 PP(pp_gvsv)
242 {
243 assert(SvTYPE(cGVOP_gv) == SVt_PVGV);
244 rpp_xpush_1(
245 UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)
246 ? save_scalar(cGVOP_gv)
247 : GvSVn(cGVOP_gv));
248 return NORMAL;
249 }
250
251
252 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
253
PP(pp_null)254 PP(pp_null)
255 {
256 return NORMAL;
257 }
258
259 /* This is sometimes called directly by pp_coreargs, pp_grepstart and
260 amagic_call. */
PP(pp_pushmark)261 PP(pp_pushmark)
262 {
263 PUSHMARK(PL_stack_sp);
264 return NORMAL;
265 }
266
PP(pp_stringify)267 PP(pp_stringify)
268 {
269 dTARGET;
270 sv_copypv(TARG, *PL_stack_sp);
271 SvSETMAGIC(TARG);
272 rpp_replace_1_1_NN(TARG);
273 return NORMAL;
274 }
275
PP(pp_gv)276 PP(pp_gv)
277 {
278 /* cGVOP_gv might be a real GV or might be an RV to a CV */
279 assert(SvTYPE(cGVOP_gv) == SVt_PVGV ||
280 (SvTYPE(cGVOP_gv) <= SVt_PVMG && SvROK(cGVOP_gv) && SvTYPE(SvRV(cGVOP_gv)) == SVt_PVCV));
281 rpp_xpush_1(MUTABLE_SV(cGVOP_gv));
282 return NORMAL;
283 }
284
285
286 /* also used for: pp_andassign() */
287
PP(pp_and)288 PP(pp_and)
289 {
290 PERL_ASYNC_CHECK();
291 {
292 SV * const sv = *PL_stack_sp;
293 if (!SvTRUE_NN(sv))
294 return NORMAL;
295 else {
296 if (PL_op->op_type == OP_AND)
297 rpp_popfree_1_NN();
298 return cLOGOP->op_other;
299 }
300 }
301 }
302
303 /*
304 * Mashup of simple padsv + sassign OPs
305 * Doesn't support the following lengthy and unlikely sassign case:
306 * (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV))
307 * These cases have a separate optimization, so are not handled here:
308 * (PL_op->op_private & OPpASSIGN_BACKWARDS) {or,and,dor}assign
309 */
310
PP(pp_padsv_store)311 PP(pp_padsv_store)
312 {
313 OP * const op = PL_op;
314 SV** const padentry = &PAD_SVl(op->op_targ);
315 SV* targ = *padentry; /* lvalue to assign into */
316 SV* const val = *PL_stack_sp; /* RHS value to assign */
317
318 /* !OPf_STACKED is not handled by this OP */
319 assert(op->op_flags & OPf_STACKED);
320
321 /* Inlined, simplified pp_padsv here */
322 if ((op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO) {
323 save_clearsv(padentry);
324 }
325
326 /* Inlined, simplified pp_sassign from here */
327 assert(TAINTING_get || !TAINT_get);
328 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
329 TAINT_NOT;
330
331 if (
332 UNLIKELY(SvTEMP(targ)) && !SvSMAGICAL(targ) && SvREFCNT(targ) == 1 &&
333 (!isGV_with_GP(targ) || SvFAKE(targ)) && ckWARN(WARN_MISC)
334 )
335 Perl_warner(aTHX_
336 packWARN(WARN_MISC), "Useless assignment to a temporary"
337 );
338 SvSetMagicSV(targ, val);
339
340 rpp_replace_1_1_NN(targ);
341 return NORMAL;
342 }
343
344
345 /* A mashup of simplified AELEMFAST_LEX + SASSIGN OPs */
346
PP(pp_aelemfastlex_store)347 PP(pp_aelemfastlex_store)
348 {
349 OP * const op = PL_op;
350 SV* const val = *PL_stack_sp; /* RHS value to assign */
351 AV * const av = MUTABLE_AV(PAD_SV(op->op_targ));
352 const I8 key = (I8)PL_op->op_private;
353 SV * targ = NULL;
354
355 /* !OPf_STACKED is not handled by this OP */
356 assert(op->op_flags & OPf_STACKED);
357
358 /* Inlined, simplified pp_aelemfast here */
359 assert(SvTYPE(av) == SVt_PVAV);
360
361 /* inlined av_fetch() for simple cases ... */
362 if (!SvRMAGICAL(av) && key >=0 && key <= AvFILLp(av)) {
363 targ = AvARRAY(av)[key];
364 }
365 /* ... else do it the hard way */
366 if (!targ) {
367 SV **svp = av_fetch(av, key, 1);
368
369 if (svp)
370 targ = *svp;
371 else
372 DIE(aTHX_ PL_no_aelem, (int)key);
373 }
374
375 /* Inlined, simplified pp_sassign from here */
376 assert(TAINTING_get || !TAINT_get);
377 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
378 TAINT_NOT;
379
380 /* This assertion is a deviation from pp_sassign, which uses an if()
381 * condition to check for "Useless assignment to a temporary" and
382 * warns if the condition is true. Here, the condition should NEVER
383 * be true when the LHS is the result of an array fetch. The
384 * assertion is here as a final check that this remains the case.
385 */
386 assert(!(SvTEMP(targ) && SvREFCNT(targ) == 1 && !SvSMAGICAL(targ)));
387
388 SvSetMagicSV(targ, val);
389
390 assert(GIMME_V == G_VOID);
391 rpp_popfree_1_NN();
392 return NORMAL;
393 }
394
PP(pp_sassign)395 PP(pp_sassign)
396 {
397 /* sassign keeps its args in the optree traditionally backwards.
398 So we pop them differently.
399 */
400 SV *left = PL_stack_sp[0];
401 SV *right = PL_stack_sp[-1];
402
403 if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
404 SV * const temp = left;
405 left = right; right = temp;
406 PL_stack_sp[0] = left;
407 PL_stack_sp[-1] = right;
408 }
409 assert(TAINTING_get || !TAINT_get);
410 if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
411 TAINT_NOT;
412
413 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
414 /* *foo =\&bar */
415 SV * const cv = SvRV(right);
416 const U32 cv_type = SvTYPE(cv);
417 const bool is_gv = isGV_with_GP(left);
418 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
419
420 if (!got_coderef) {
421 assert(SvROK(cv));
422 }
423
424 /* Can do the optimisation if left (LVALUE) is not a typeglob,
425 right (RVALUE) is a reference to something, and we're in void
426 context. */
427 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
428 /* Is the target symbol table currently empty? */
429 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
430 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
431 /* Good. Create a new proxy constant subroutine in the target.
432 The gv becomes a(nother) reference to the constant. */
433 SV *const value = SvRV(cv);
434
435 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
436 SvPCS_IMPORTED_on(gv);
437 SvRV_set(gv, value);
438 SvREFCNT_inc_simple_void(value);
439 rpp_replace_2_1_NN(left);
440 return NORMAL;
441 }
442 }
443
444 /* Need to fix things up. */
445 if (!is_gv) {
446 /* Need to fix GV. */
447 SV *sv = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
448 rpp_replace_1_1_NN(sv);
449 left = sv;
450 }
451
452 if (!got_coderef) {
453 /* We've been returned a constant rather than a full subroutine,
454 but they expect a subroutine reference to apply. */
455 if (SvROK(cv)) {
456 ENTER_with_name("sassign_coderef");
457 SvREFCNT_inc_void(SvRV(cv));
458 /* newCONSTSUB takes a reference count on the passed in SV
459 from us. We set the name to NULL, otherwise we get into
460 all sorts of fun as the reference to our new sub is
461 donated to the GV that we're about to assign to.
462 */
463 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
464 SvRV(cv))));
465 SvREFCNT_dec_NN(cv);
466 LEAVE_with_name("sassign_coderef");
467 } else {
468 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
469 is that
470 First: ops for \&{"BONK"}; return us the constant in the
471 symbol table
472 Second: ops for *{"BONK"} cause that symbol table entry
473 (and our reference to it) to be upgraded from RV
474 to typeblob)
475 Thirdly: We get here. cv is actually PVGV now, and its
476 GvCV() is actually the subroutine we're looking for
477
478 So change the reference so that it points to the subroutine
479 of that typeglob, as that's what they were after all along.
480 */
481 GV *const upgraded = MUTABLE_GV(cv);
482 CV *const source = GvCV(upgraded);
483
484 assert(source);
485 assert(CvFLAGS(source) & CVf_CONST);
486
487 SvREFCNT_inc_simple_void_NN(source);
488 SvREFCNT_dec_NN(upgraded);
489 SvRV_set(right, MUTABLE_SV(source));
490 }
491 }
492
493 }
494 if (
495 rpp_is_lone(left) && !SvSMAGICAL(left) &&
496 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
497 )
498 Perl_warner(aTHX_
499 packWARN(WARN_MISC), "Useless assignment to a temporary"
500 );
501 SvSetMagicSV(left, right);
502 if (LIKELY(GIMME_V == G_VOID))
503 rpp_popfree_2_NN(); /* pop left and right */
504 else {
505 /* pop right, leave left on the stack */
506 assert(PL_stack_sp[-1] == right);
507 assert(PL_stack_sp[0] == left);
508 *--PL_stack_sp = left;
509 #ifdef PERL_RC_STACK
510 SvREFCNT_dec_NN(right);
511 #endif
512 }
513
514 return NORMAL;
515 }
516
PP(pp_cond_expr)517 PP(pp_cond_expr)
518 {
519 PERL_ASYNC_CHECK();
520 bool ok = SvTRUE_NN(*PL_stack_sp);
521 rpp_popfree_1_NN();
522 return (ok ? cLOGOP->op_other : cLOGOP->op_next);
523 }
524
PP(pp_unstack)525 PP(pp_unstack)
526 {
527 PERL_CONTEXT *cx;
528 PERL_ASYNC_CHECK();
529 TAINT_NOT; /* Each statement is presumed innocent */
530 cx = CX_CUR();
531 rpp_popfree_to_NN(PL_stack_base + CX_CUR()->blk_oldsp);
532 FREETMPS;
533 if (!(PL_op->op_flags & OPf_SPECIAL)) {
534 assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
535 CX_LEAVE_SCOPE(cx);
536 }
537 return NORMAL;
538 }
539
540
541 /* The main body of pp_concat, not including the magic/overload and
542 * stack handling.
543 * It does targ = left . right.
544 * Moved into a separate function so that pp_multiconcat() can use it
545 * too.
546 */
547
548 PERL_STATIC_INLINE void
S_do_concat(pTHX_ SV * left,SV * right,SV * targ,U8 targmy)549 S_do_concat(pTHX_ SV *left, SV *right, SV *targ, U8 targmy)
550 {
551 bool lbyte;
552 STRLEN rlen;
553 const char *rpv = NULL;
554 bool rbyte = FALSE;
555 bool rcopied = FALSE;
556
557 if (TARG == right && right != left) { /* $r = $l.$r */
558 rpv = SvPV_nomg_const(right, rlen);
559 rbyte = !DO_UTF8(right);
560 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
561 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
562 rcopied = TRUE;
563 }
564
565 if (TARG != left) { /* not $l .= $r */
566 STRLEN llen;
567 const char* const lpv = SvPV_nomg_const(left, llen);
568 lbyte = !DO_UTF8(left);
569 sv_setpvn(TARG, lpv, llen);
570 if (!lbyte)
571 SvUTF8_on(TARG);
572 else
573 SvUTF8_off(TARG);
574 }
575 else { /* $l .= $r and left == TARG */
576 if (!SvOK(left)) {
577 if ((left == right /* $l .= $l */
578 || targmy) /* $l = $l . $r */
579 && ckWARN(WARN_UNINITIALIZED)
580 )
581 report_uninit(left);
582 SvPVCLEAR(left);
583 }
584 else {
585 SvPV_force_nomg_nolen(left);
586 }
587 lbyte = !DO_UTF8(left);
588 if (IN_BYTES)
589 SvUTF8_off(left);
590 }
591
592 if (!rcopied) {
593 rpv = SvPV_nomg_const(right, rlen);
594 rbyte = !DO_UTF8(right);
595 }
596 if (lbyte != rbyte) {
597 if (lbyte)
598 sv_utf8_upgrade_nomg(TARG);
599 else {
600 if (!rcopied)
601 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
602 sv_utf8_upgrade_nomg(right);
603 rpv = SvPV_nomg_const(right, rlen);
604 }
605 }
606 sv_catpvn_nomg(TARG, rpv, rlen);
607 SvSETMAGIC(TARG);
608 }
609
610
PP(pp_concat)611 PP(pp_concat)
612 {
613 SV *targ = (PL_op->op_flags & OPf_STACKED)
614 ? PL_stack_sp[-1]
615 : PAD_SV(PL_op->op_targ);
616
617 if (rpp_try_AMAGIC_2(concat_amg, AMGf_assign))
618 return NORMAL;
619
620 SV *right = PL_stack_sp[0];
621 SV *left = PL_stack_sp[-1];
622 S_do_concat(aTHX_ left, right, targ, PL_op->op_private & OPpTARGET_MY);
623 rpp_replace_2_1_NN(targ);
624 return NORMAL;
625 }
626
627
628 /* pp_multiconcat()
629
630 Concatenate one or more args, possibly interleaved with constant string
631 segments. The result may be assigned to, or appended to, a variable or
632 expression.
633
634 Several op_flags and/or op_private bits indicate what the target is, and
635 whether it's appended to. Valid permutations are:
636
637 - (PADTMP) = (A.B.C....)
638 OPpTARGET_MY $lex = (A.B.C....)
639 OPpTARGET_MY,OPpLVAL_INTRO my $lex = (A.B.C....)
640 OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex .= (A.B.C....)
641 OPf_STACKED expr = (A.B.C....)
642 OPf_STACKED,OPpMULTICONCAT_APPEND expr .= (A.B.C....)
643
644 Other combinations like (A.B).(C.D) are not optimised into a multiconcat
645 op, as it's too hard to get the correct ordering of ties, overload etc.
646
647 In addition:
648
649 OPpMULTICONCAT_FAKE: not a real concat, instead an optimised
650 sprintf "...%s...". Don't call '.'
651 overloading: only use '""' overloading.
652
653 OPpMULTICONCAT_STRINGIFY: the RHS was of the form
654 "...$a...$b..." rather than
655 "..." . $a . "..." . $b . "..."
656
657 An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are
658 defined with PERL_MULTICONCAT_IX_FOO constants, where:
659
660
661 FOO index description
662 -------- ----- ----------------------------------
663 NARGS 0 number of arguments
664 PLAIN_PV 1 non-utf8 constant string
665 PLAIN_LEN 2 non-utf8 constant string length
666 UTF8_PV 3 utf8 constant string
667 UTF8_LEN 4 utf8 constant string length
668 LENGTHS 5 first of nargs+1 const segment lengths
669
670 The idea is that a general string concatenation will have a fixed (known
671 at compile time) number of variable args, interspersed with constant
672 strings, e.g. "a=$a b=$b\n"
673
674 All the constant string segments "a=", " b=" and "\n" are stored as a
675 single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along
676 with a series of segment lengths: e.g. 2,3,1. In the case where the
677 constant string is plain but has a different utf8 representation, both
678 variants are stored, and two sets of (nargs+1) segments lengths are stored
679 in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS.
680
681 A segment length of -1 indicates that there is no constant string at that
682 point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which
683 have differing overloading behaviour.
684
685 */
686
PP(pp_multiconcat)687 PP(pp_multiconcat)
688 {
689 SV *targ; /* The SV to be assigned or appended to */
690 char *targ_pv; /* where within SvPVX(targ) we're writing to */
691 STRLEN targ_len; /* SvCUR(targ) */
692 SV **toparg; /* the highest arg position on the stack */
693 UNOP_AUX_item *aux; /* PL_op->op_aux buffer */
694 UNOP_AUX_item *const_lens; /* the segment length array part of aux */
695 const char *const_pv; /* the current segment of the const string buf */
696 SSize_t nargs; /* how many args were expected */
697 SSize_t stack_adj; /* how much to adjust PL_stack_sp on return */
698 STRLEN grow; /* final size of destination string (targ) */
699 UV targ_count; /* how many times targ has appeared on the RHS */
700 bool is_append; /* OPpMULTICONCAT_APPEND flag is set */
701 bool slow_concat; /* args too complex for quick concat */
702 U32 dst_utf8; /* the result will be utf8 (indicate this with
703 SVf_UTF8 in a U32, rather than using bool,
704 for ease of testing and setting) */
705 /* for each arg, holds the result of an SvPV() call */
706 struct multiconcat_svpv {
707 const char *pv;
708 SSize_t len;
709 }
710 *targ_chain, /* chain of slots where targ has appeared on RHS */
711 *svpv_p, /* ptr for looping through svpv_buf */
712 *svpv_base, /* first slot (may be greater than svpv_buf), */
713 *svpv_end, /* and slot after highest result so far, of: */
714 svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */
715
716 aux = cUNOP_AUXx(PL_op)->op_aux;
717 stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
718 is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND);
719
720 /* get targ from the stack or pad */
721
722 toparg = PL_stack_sp;
723 if (PL_op->op_flags & OPf_STACKED) {
724 stack_adj++;
725 if (is_append) {
726 /* for 'expr .= ...', expr is the bottom item on the stack */
727 targ = PL_stack_sp[-nargs];
728 }
729 else {
730 /* for 'expr = ...', expr is the top item on the stack */
731 targ = *PL_stack_sp;
732 toparg--;
733 }
734 }
735 else {
736 SV **svp = &(PAD_SVl(PL_op->op_targ));
737 targ = *svp;
738 if (PL_op->op_private & OPpLVAL_INTRO) {
739 assert(PL_op->op_private & OPpTARGET_MY);
740 save_clearsv(svp);
741 }
742 if (!nargs)
743 /* $lex .= "const" doesn't cause anything to be pushed */
744 rpp_extend(1);
745 }
746
747 grow = 1; /* allow for '\0' at minimum */
748 targ_count = 0;
749 targ_chain = NULL;
750 targ_len = 0;
751 svpv_end = svpv_buf;
752 /* only utf8 variants of the const strings? */
753 dst_utf8 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8;
754
755
756 /* --------------------------------------------------------------
757 * Phase 1:
758 *
759 * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8
760 * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths.
761 *
762 * utf8 is indicated by storing a negative length.
763 *
764 * Where an arg is actually targ, the stringification is deferred:
765 * the length is set to 0, and the slot is added to targ_chain.
766 *
767 * If a magic, overloaded, or otherwise weird arg is found, which
768 * might have side effects when stringified, the loop is abandoned and
769 * we goto a code block where a more basic 'emulate calling
770 * pp_cpncat() on each arg in turn' is done.
771 */
772
773 for (SV **svp = toparg - (nargs - 1); svp <= toparg; svp++, svpv_end++) {
774 U32 utf8;
775 STRLEN len;
776 SV *sv;
777
778 assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
779
780 sv = *svp;
781
782 /* this if/else chain is arranged so that common/simple cases
783 * take few conditionals */
784
785 if (LIKELY((SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK)) {
786 /* common case: sv is a simple non-magical PV */
787 if (targ == sv) {
788 /* targ appears on RHS.
789 * Delay storing PV pointer; instead, add slot to targ_chain
790 * so it can be populated later, after targ has been grown and
791 * we know its final SvPVX() address.
792 */
793 targ_on_rhs:
794 svpv_end->len = 0; /* zerojng here means we can skip
795 updating later if targ_len == 0 */
796 svpv_end->pv = (char*)targ_chain;
797 targ_chain = svpv_end;
798 targ_count++;
799 continue;
800 }
801
802 len = SvCUR(sv);
803 svpv_end->pv = SvPVX(sv);
804 }
805 else if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK)))
806 /* may have side effects: tie, overload etc.
807 * Abandon 'stringify everything first' and handle
808 * args in strict order. Note that already-stringified args
809 * will be reprocessed, which is safe because the each first
810 * stringification would have been idempotent.
811 */
812 goto do_magical;
813 else if (SvNIOK(sv)) {
814 if (targ == sv)
815 goto targ_on_rhs;
816 /* stringify general valid scalar */
817 svpv_end->pv = sv_2pv_flags(sv, &len, 0);
818 }
819 else if (!SvOK(sv)) {
820 if (ckWARN(WARN_UNINITIALIZED))
821 /* an undef value in the presence of warnings may trigger
822 * side affects */
823 goto do_magical;
824 svpv_end->pv = "";
825 len = 0;
826 }
827 else
828 goto do_magical; /* something weird */
829
830 utf8 = (SvFLAGS(sv) & SVf_UTF8);
831 dst_utf8 |= utf8;
832 ASSUME(len < SSize_t_MAX);
833 svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len;
834 grow += len;
835 }
836
837 /* --------------------------------------------------------------
838 * Phase 2:
839 *
840 * Stringify targ:
841 *
842 * if targ appears on the RHS or is appended to, force stringify it;
843 * otherwise set it to "". Then set targ_len.
844 */
845
846 if (is_append) {
847 /* abandon quick route if using targ might have side effects */
848 if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK)))
849 goto do_magical;
850
851 if (SvOK(targ)) {
852 U32 targ_utf8;
853 stringify_targ:
854 SvPV_force_nomg_nolen(targ);
855 targ_utf8 = SvFLAGS(targ) & SVf_UTF8;
856 if (UNLIKELY(dst_utf8 & ~targ_utf8)) {
857 if (LIKELY(!IN_BYTES))
858 sv_utf8_upgrade_nomg(targ);
859 }
860 else
861 dst_utf8 |= targ_utf8;
862
863 targ_len = SvCUR(targ);
864 grow += targ_len * (targ_count + is_append);
865 goto phase3;
866 }
867 else if (ckWARN(WARN_UNINITIALIZED))
868 /* warning might have side effects */
869 goto do_magical;
870 /* the undef targ will be silently SvPVCLEAR()ed below */
871 }
872 else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) {
873 /* Assigning to some weird LHS type. Don't force the LHS to be an
874 * empty string; instead, do things 'long hand' by using the
875 * overload code path, which concats to a TEMP sv and does
876 * sv_catsv() calls rather than COPY()s. This ensures that even
877 * bizarre code like this doesn't break or crash:
878 * *F = *F . *F.
879 * (which makes the 'F' typeglob an alias to the
880 * '*main::F*main::F' typeglob).
881 */
882 goto do_magical;
883 }
884 else if (targ_chain)
885 /* targ was found on RHS.
886 * Force stringify it, using the same code as the append branch
887 * above, except that we don't need the magic/overload/undef
888 * checks as these will already have been done in the phase 1
889 * loop.
890 */
891 goto stringify_targ;
892
893 /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
894 * those will be done later. */
895 SV_CHECK_THINKFIRST_COW_DROP(targ);
896 SvUPGRADE(targ, SVt_PV);
897 SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
898 SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8);
899
900 phase3:
901
902 /* --------------------------------------------------------------
903 * Phase 3:
904 *
905 * UTF-8 tweaks and grow targ:
906 *
907 * Now that we know the length and utf8-ness of both the targ and
908 * args, grow targ to the size needed to accumulate all the args, based
909 * on whether targ appears on the RHS, whether we're appending, and
910 * whether any non-utf8 args expand in size if converted to utf8.
911 *
912 * For the latter, if dst_utf8 we scan non-utf8 args looking for
913 * variant chars, and adjust the svpv->len value of those args to the
914 * utf8 size and negate it to flag them. At the same time we un-negate
915 * the lens of any utf8 args since after this phase we no longer care
916 * whether an arg is utf8 or not.
917 *
918 * Finally, initialise const_lens and const_pv based on utf8ness.
919 * Note that there are 3 permutations:
920 *
921 * * If the constant string is invariant whether utf8 or not (e.g. "abc"),
922 * then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as
923 * aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of
924 * segment lengths.
925 *
926 * * If the string is fully utf8, e.g. "\x{100}", then
927 * aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is
928 * one set of segment lengths.
929 *
930 * * If the string has different plain and utf8 representations
931 * (e.g. "\x80"), then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
932 * holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
933 * holds the utf8 rep, and there are 2 sets of segment lengths,
934 * with the utf8 set following after the plain set.
935 *
936 * On entry to this section the (pv,len) pairs in svpv_buf have the
937 * following meanings:
938 * (pv, len) a plain string
939 * (pv, -len) a utf8 string
940 * (NULL, 0) left-most targ \ linked together R-to-L
941 * (next, 0) other targ / in targ_chain
942 */
943
944 /* turn off utf8 handling if 'use bytes' is in scope */
945 if (UNLIKELY(dst_utf8 && IN_BYTES)) {
946 dst_utf8 = 0;
947 SvUTF8_off(targ);
948 /* undo all the negative lengths which flag utf8-ness */
949 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
950 SSize_t len = svpv_p->len;
951 if (len < 0)
952 svpv_p->len = -len;
953 }
954 }
955
956 /* grow += total of lengths of constant string segments */
957 {
958 SSize_t len;
959 len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN
960 : PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
961 slow_concat = cBOOL(len);
962 grow += len;
963 }
964
965 const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
966
967 if (dst_utf8) {
968 const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
969 if ( aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv
970 && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv)
971 /* separate sets of lengths for plain and utf8 */
972 const_lens += nargs + 1;
973
974 /* If the result is utf8 but some of the args aren't,
975 * calculate how much extra growth is needed for all the chars
976 * which will expand to two utf8 bytes.
977 * Also, if the growth is non-zero, negate the length to indicate
978 * that this is a variant string. Conversely, un-negate the
979 * length on utf8 args (which was only needed to flag non-utf8
980 * args in this loop */
981 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
982 SSize_t len, extra;
983
984 len = svpv_p->len;
985 if (len <= 0) {
986 svpv_p->len = -len;
987 continue;
988 }
989
990 extra = variant_under_utf8_count((U8 *) svpv_p->pv,
991 (U8 *) svpv_p->pv + len);
992 if (UNLIKELY(extra)) {
993 grow += extra;
994 /* -ve len indicates special handling */
995 svpv_p->len = -(len + extra);
996 slow_concat = TRUE;
997 }
998 }
999 }
1000 else
1001 const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1002
1003 /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
1004 * already have been dropped */
1005 assert(!SvIsCOW(targ));
1006 targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ));
1007
1008
1009 /* --------------------------------------------------------------
1010 * Phase 4:
1011 *
1012 * Now that targ has been grown, we know the final address of the targ
1013 * PVX, if needed. Preserve / move targ contents if appending or if
1014 * targ appears on RHS.
1015 *
1016 * Also update svpv_buf slots in targ_chain.
1017 *
1018 * Don't bother with any of this if the target length is zero:
1019 * targ_len is set to zero unless we're appending or targ appears on
1020 * RHS. And even if it is, we can optimise by skipping this chunk of
1021 * code for zero targ_len. In the latter case, we don't need to update
1022 * the slots in targ_chain with the (zero length) target string, since
1023 * we set the len in such slots to 0 earlier, and since the Copy() is
1024 * skipped on zero length, it doesn't matter what svpv_p->pv contains.
1025 *
1026 * On entry to this section the (pv,len) pairs in svpv_buf have the
1027 * following meanings:
1028 * (pv, len) a pure-plain or utf8 string
1029 * (pv, -(len+extra)) a plain string which will expand by 'extra'
1030 * bytes when converted to utf8
1031 * (NULL, 0) left-most targ \ linked together R-to-L
1032 * (next, 0) other targ / in targ_chain
1033 *
1034 * On exit, the targ contents will have been moved to the
1035 * earliest place they are needed (e.g. $x = "abc$x" will shift them
1036 * 3 bytes, while $x .= ... will leave them at the beginning);
1037 * and dst_pv will point to the location within SvPVX(targ) where the
1038 * next arg should be copied.
1039 */
1040
1041 svpv_base = svpv_buf;
1042
1043 if (targ_len) {
1044 struct multiconcat_svpv *tc_stop;
1045 char *targ_buf = targ_pv; /* ptr to original targ string */
1046
1047 assert(is_append || targ_count);
1048
1049 if (is_append) {
1050 targ_pv += targ_len;
1051 tc_stop = NULL;
1052 }
1053 else {
1054 /* The targ appears on RHS, e.g. '$t = $a . $t . $t'.
1055 * Move the current contents of targ to the first
1056 * position where it's needed, and use that as the src buffer
1057 * for any further uses (such as the second RHS $t above).
1058 * In calculating the first position, we need to sum the
1059 * lengths of all consts and args before that.
1060 */
1061
1062 UNOP_AUX_item *lens = const_lens;
1063 /* length of first const string segment */
1064 STRLEN offset = lens->ssize > 0 ? lens->ssize : 0;
1065
1066 assert(targ_chain);
1067 svpv_p = svpv_base;
1068
1069 for (;;) {
1070 SSize_t len;
1071 if (!svpv_p->pv)
1072 break; /* the first targ argument */
1073 /* add lengths of the next arg and const string segment */
1074 len = svpv_p->len;
1075 if (len < 0) /* variant args have this */
1076 len = -len;
1077 offset += (STRLEN)len;
1078 len = (++lens)->ssize;
1079 offset += (len >= 0) ? (STRLEN)len : 0;
1080 if (!offset) {
1081 /* all args and consts so far are empty; update
1082 * the start position for the concat later */
1083 svpv_base++;
1084 const_lens++;
1085 }
1086 svpv_p++;
1087 assert(svpv_p < svpv_end);
1088 }
1089
1090 if (offset) {
1091 targ_buf += offset;
1092 Move(targ_pv, targ_buf, targ_len, char);
1093 /* a negative length implies don't Copy(), but do increment */
1094 svpv_p->len = -((SSize_t)targ_len);
1095 slow_concat = TRUE;
1096 }
1097 else {
1098 /* skip the first targ copy */
1099 svpv_base++;
1100 const_lens++;
1101 targ_pv += targ_len;
1102 }
1103
1104 /* Don't populate the first targ slot in the loop below; it's
1105 * either not used because we advanced svpv_base beyond it, or
1106 * we already stored the special -targ_len value in it
1107 */
1108 tc_stop = svpv_p;
1109 }
1110
1111 /* populate slots in svpv_buf representing targ on RHS */
1112 while (targ_chain != tc_stop) {
1113 struct multiconcat_svpv *p = targ_chain;
1114 targ_chain = (struct multiconcat_svpv *)(p->pv);
1115 p->pv = targ_buf;
1116 p->len = (SSize_t)targ_len;
1117 }
1118 }
1119
1120
1121 /* --------------------------------------------------------------
1122 * Phase 5:
1123 *
1124 * Append all the args in svpv_buf, plus the const strings, to targ.
1125 *
1126 * On entry to this section the (pv,len) pairs in svpv_buf have the
1127 * following meanings:
1128 * (pv, len) a pure-plain or utf8 string (which may be targ)
1129 * (pv, -(len+extra)) a plain string which will expand by 'extra'
1130 * bytes when converted to utf8
1131 * (0, -len) left-most targ, whose content has already
1132 * been copied. Just advance targ_pv by len.
1133 */
1134
1135 /* If there are no constant strings and no special case args
1136 * (svpv_p->len < 0), use a simpler, more efficient concat loop
1137 */
1138 if (!slow_concat) {
1139 for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) {
1140 SSize_t len = svpv_p->len;
1141 if (!len)
1142 continue;
1143 Copy(svpv_p->pv, targ_pv, len, char);
1144 targ_pv += len;
1145 }
1146 const_lens += (svpv_end - svpv_base + 1);
1147 }
1148 else {
1149 /* Note that we iterate the loop nargs+1 times: to append nargs
1150 * arguments and nargs+1 constant strings. For example, "-$a-$b-"
1151 */
1152 svpv_p = svpv_base;
1153
1154 for (;;) {
1155 SSize_t len = (const_lens++)->ssize;
1156
1157 /* append next const string segment */
1158 if (len > 0) {
1159 Copy(const_pv, targ_pv, len, char);
1160 targ_pv += len;
1161 const_pv += len;
1162 }
1163
1164 if (svpv_p == svpv_end)
1165 break;
1166
1167 /* append next arg */
1168 len = svpv_p->len;
1169
1170 if (LIKELY(len > 0)) {
1171 Copy(svpv_p->pv, targ_pv, len, char);
1172 targ_pv += len;
1173 }
1174 else if (UNLIKELY(len < 0)) {
1175 /* negative length indicates two special cases */
1176 const char *p = svpv_p->pv;
1177 len = -len;
1178 if (UNLIKELY(p)) {
1179 /* copy plain-but-variant pv to a utf8 targ */
1180 char * end_pv = targ_pv + len;
1181 assert(dst_utf8);
1182 while (targ_pv < end_pv) {
1183 U8 c = (U8) *p++;
1184 append_utf8_from_native_byte(c, (U8**)&targ_pv);
1185 }
1186 }
1187 else
1188 /* arg is already-copied targ */
1189 targ_pv += len;
1190 }
1191
1192 ++svpv_p;
1193 }
1194 }
1195
1196 *targ_pv = '\0';
1197 SvCUR_set(targ, targ_pv - SvPVX(targ));
1198 assert(grow >= SvCUR(targ) + 1);
1199 assert(SvLEN(targ) >= SvCUR(targ) + 1);
1200
1201 /* --------------------------------------------------------------
1202 * Phase 6:
1203 *
1204 * return result
1205 */
1206
1207 rpp_popfree_to_NN(PL_stack_sp - stack_adj);
1208 SvTAINT(targ);
1209 SvSETMAGIC(targ);
1210 rpp_push_1(targ);
1211 return NORMAL;
1212
1213 /* --------------------------------------------------------------
1214 * Phase 7:
1215 *
1216 * We only get here if any of the args (or targ too in the case of
1217 * append) have something which might cause side effects, such
1218 * as magic, overload, or an undef value in the presence of warnings.
1219 * In that case, any earlier attempt to stringify the args will have
1220 * been abandoned, and we come here instead.
1221 *
1222 * Here, we concat each arg in turn the old-fashioned way: essentially
1223 * emulating pp_concat() in a loop. This means that all the weird edge
1224 * cases will be handled correctly, if not necessarily speedily.
1225 *
1226 * Note that some args may already have been stringified - those are
1227 * processed again, which is safe, since only args without side-effects
1228 * were stringified earlier.
1229 */
1230
1231 do_magical:
1232 {
1233 SSize_t i, n;
1234 SV *left = NULL;
1235 SV *right;
1236 SV* nexttarg;
1237 bool nextappend;
1238 U32 utf8 = 0;
1239 SV **svp;
1240 const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1241 SV *csv = NULL; /* SV which will hold cpv */
1242 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
1243 Size_t arg_count = 0; /* how many args have been processed */
1244
1245 if (!cpv) {
1246 cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1247 utf8 = SVf_UTF8;
1248 }
1249
1250 svp = toparg - nargs + 1;
1251
1252 /* iterate for:
1253 * nargs arguments,
1254 * plus possible nargs+1 consts,
1255 * plus, if appending, a final targ in an extra last iteration
1256 */
1257
1258 n = nargs *2 + 1;
1259 for (i = 0; i <= n; i++) {
1260 SSize_t len;
1261
1262 /* if necessary, stringify the final RHS result in
1263 * something like $targ .= "$a$b$c" - simulating
1264 * pp_stringify
1265 */
1266 if ( i == n
1267 && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY)
1268 && !(SvPOK(left))
1269 /* extra conditions for backwards compatibility:
1270 * probably incorrect, but keep the existing behaviour
1271 * for now. The rules are:
1272 * $x = "$ov" single arg: stringify;
1273 * $x = "$ov$y" multiple args: don't stringify,
1274 * $lex = "$ov$y$z" except TARGMY with at least 2 concats
1275 */
1276 && ( arg_count == 1
1277 || ( arg_count >= 3
1278 && !is_append
1279 && (PL_op->op_private & OPpTARGET_MY)
1280 && !(PL_op->op_private & OPpLVAL_INTRO)
1281 )
1282 )
1283 )
1284 {
1285 assert(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset);
1286 SV *tmp = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset);
1287 sv_copypv(tmp, left);
1288 SvSETMAGIC(tmp);
1289 left = tmp;
1290 }
1291
1292 /* do one extra iteration to handle $targ in $targ .= ... */
1293 if (i == n && !is_append)
1294 break;
1295
1296 /* get the next arg SV or regen the next const SV */
1297 len = lens[i >> 1].ssize;
1298 if (i == n) {
1299 /* handle the final targ .= (....) */
1300 right = left;
1301 left = targ;
1302 }
1303 else if (i & 1)
1304 right = svp[(i >> 1)];
1305 else if (len < 0)
1306 continue; /* no const in this position */
1307 else {
1308 /* Use one of our PADTMPs to fake up the SV which would
1309 * have been returned by an OP_CONST. Try to reuse it if
1310 * possible. If the refcount has gone up, something like
1311 * overload code has taken a reference to it, so abandon
1312 * it */
1313 if (!csv || SvREFCNT(csv) > 1 || SvLEN(csv) != 0) {
1314 if (csv)
1315 csv = newSV_type_mortal(SVt_PV);
1316 else {
1317 assert(aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset);
1318 csv = PAD_SV(
1319 aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset);
1320 SvUPGRADE(csv, SVt_PV);
1321 }
1322
1323 if (utf8)
1324 SvUTF8_on(csv);
1325 SvREADONLY_on(csv);
1326 SvPOK_on(csv);
1327 }
1328 /* use the const string buffer directly with the
1329 * SvLEN==0 trick */
1330
1331 /* cast away constness because we think we know it's safe
1332 * (SvREADONLY) */
1333 SvPV_set(csv, (char *)cpv);
1334 SvLEN_set(csv, 0);
1335 SvCUR_set(csv, len);
1336
1337 right = csv;
1338 cpv += len;
1339 }
1340
1341 arg_count++;
1342
1343 if (arg_count <= 1) {
1344 left = right;
1345 continue; /* need at least two SVs to concat together */
1346 }
1347
1348 if (arg_count == 2 && i < n) {
1349 /* for the first concat, use one of the PADTMPs to emulate
1350 * the PADTMP from OP_CONST. In later iterations this will
1351 * be appended to */
1352 nexttarg = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP0].pad_offset);
1353 nextappend = FALSE;
1354 }
1355 else {
1356 nexttarg = left;
1357 nextappend = TRUE;
1358 }
1359
1360 /* Handle possible overloading.
1361 * This is basically an unrolled
1362 * tryAMAGICbin_MG(concat_amg, AMGf_assign);
1363 * and
1364 * Perl_try_amagic_bin()
1365 * call, but using left and right rather than
1366 * PL_stack_sp[-1], PL_stack_sp[0],
1367 * and not relying on OPf_STACKED implying .=
1368 */
1369
1370 if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) {
1371 SvGETMAGIC(left);
1372 if (left != right)
1373 SvGETMAGIC(right);
1374
1375 if ((SvAMAGIC(left) || SvAMAGIC(right))
1376 /* sprintf doesn't do concat overloading,
1377 * but allow for $x .= sprintf(...)
1378 */
1379 && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE)
1380 || i == n)
1381 )
1382 {
1383 SV * const tmpsv = amagic_call(left, right, concat_amg,
1384 (nextappend ? AMGf_assign: 0));
1385 if (tmpsv) {
1386 /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test
1387 * here, which isn't needed as any implicit
1388 * assign done under OPpTARGET_MY is done after
1389 * this loop */
1390 if (nextappend) {
1391 sv_setsv(left, tmpsv);
1392 SvSETMAGIC(left);
1393 }
1394 else
1395 left = tmpsv;
1396 continue;
1397 }
1398 }
1399
1400 /* if both args are the same magical value, make one a copy */
1401 if (left == right && SvGMAGICAL(left)) {
1402 SV * targetsv = right;
1403 /* Print the uninitialized warning now, so it includes the
1404 * variable name. */
1405 if (!SvOK(right)) {
1406 if (ckWARN(WARN_UNINITIALIZED))
1407 report_uninit(right);
1408 targetsv = &PL_sv_no;
1409 }
1410 left = sv_mortalcopy_flags(targetsv, 0);
1411 SvGETMAGIC(right);
1412 }
1413 }
1414
1415 /* nexttarg = left . right */
1416 S_do_concat(aTHX_ left, right, nexttarg, 0);
1417 left = nexttarg;
1418 }
1419
1420 /* Return the result of all RHS concats, unless this op includes
1421 * an assign ($lex = x.y.z or expr = x.y.z), in which case copy
1422 * to target (which will be $lex or expr).
1423 * If we are appending, targ will already have been appended to in
1424 * the loop */
1425 if ( !is_append
1426 && ( (PL_op->op_flags & OPf_STACKED)
1427 || (PL_op->op_private & OPpTARGET_MY))
1428 ) {
1429 sv_setsv(targ, left);
1430 SvSETMAGIC(targ);
1431 }
1432 else
1433 targ = left;
1434
1435 rpp_popfree_to_NN(PL_stack_sp - stack_adj);
1436 rpp_push_1(targ);
1437 return NORMAL;
1438 }
1439 }
1440
1441
1442 /* push the elements of av onto the stack.
1443 * Returns PL_op->op_next to allow tail-call optimisation of its callers */
1444
1445 STATIC OP*
S_pushav(pTHX_ AV * const av)1446 S_pushav(pTHX_ AV* const av)
1447 {
1448 const SSize_t maxarg = AvFILL(av) + 1;
1449 rpp_extend(maxarg);
1450 if (UNLIKELY(SvRMAGICAL(av))) {
1451 PADOFFSET i;
1452 for (i=0; i < (PADOFFSET)maxarg; i++) {
1453 SV ** const svp = av_fetch(av, i, FALSE);
1454 rpp_push_1(LIKELY(svp)
1455 ? *svp
1456 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1457 ? av_nonelem(av,i)
1458 : &PL_sv_undef
1459 );
1460 }
1461 }
1462 else {
1463 PADOFFSET i;
1464 for (i=0; i < (PADOFFSET)maxarg; i++) {
1465 SV *sv = AvARRAY(av)[i];
1466 rpp_push_1(LIKELY(sv)
1467 ? sv
1468 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1469 ? av_nonelem(av,i)
1470 : &PL_sv_undef
1471 );
1472 }
1473 }
1474 return NORMAL;
1475 }
1476
1477
1478 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
1479
PP(pp_padrange)1480 PP(pp_padrange)
1481 {
1482 PADOFFSET base = PL_op->op_targ;
1483 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
1484 if (PL_op->op_flags & OPf_SPECIAL) {
1485 /* fake the RHS of my ($x,$y,..) = @_ */
1486 PUSHMARK(PL_stack_sp);
1487 (void)S_pushav(aTHX_ GvAVn(PL_defgv));
1488 }
1489
1490 /* note, this is only skipped for compile-time-known void cxt */
1491 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
1492 int i;
1493
1494 rpp_extend(count);
1495 PUSHMARK(PL_stack_sp);
1496 for (i = 0; i <count; i++)
1497 rpp_push_1(PAD_SV(base+i));
1498 }
1499
1500 if (PL_op->op_private & OPpLVAL_INTRO) {
1501 SV **svp = &(PAD_SVl(base));
1502 const UV payload = (UV)(
1503 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1504 | (count << SAVE_TIGHT_SHIFT)
1505 | SAVEt_CLEARPADRANGE);
1506 int i;
1507
1508 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
1509 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1510 == (Size_t)base);
1511 {
1512 dSS_ADD;
1513 SS_ADD_UV(payload);
1514 SS_ADD_END(1);
1515 }
1516
1517 for (i = 0; i <count; i++)
1518 SvPADSTALE_off(*svp++); /* mark lexical as active */
1519 }
1520 return NORMAL;
1521 }
1522
1523
PP(pp_padsv)1524 PP(pp_padsv)
1525 {
1526 {
1527 OP * const op = PL_op;
1528 /* access PL_curpad once */
1529 SV ** const padentry = &(PAD_SVl(op->op_targ));
1530 {
1531 dTARG;
1532 TARG = *padentry;
1533 rpp_xpush_1(TARG);
1534 }
1535 if (op->op_flags & OPf_MOD) {
1536 if (op->op_private & OPpLVAL_INTRO)
1537 if (!(op->op_private & OPpPAD_STATE))
1538 save_clearsv(padentry);
1539 if (op->op_private & OPpDEREF) {
1540 /* *sp is equivalent to TARG here. Using *sp rather
1541 than TARG reduces the scope of TARG, so it does not
1542 span the call to save_clearsv, resulting in smaller
1543 machine code. */
1544 rpp_replace_1_1_NN(
1545 vivify_ref(*PL_stack_sp, op->op_private & OPpDEREF));
1546 }
1547 }
1548 return op->op_next;
1549 }
1550 }
1551
1552
1553 /* Implement readline(), and also <X> and <<X>> in the cases where X is
1554 * seen by the parser as file-handle-ish rather than glob-ish.
1555 *
1556 * It expects at least one arg: the typeglob or scalar filehandle to read
1557 * from. An empty <> isn't handled specially by this op; instead the parser
1558 * will have planted a preceding gv(*ARGV) op.
1559 *
1560 * Scalar assignment is optimised away by making the assignment target be
1561 * passed as a second argument, with OPf_STACKED set. For example,
1562 *
1563 * $x[$i] = readline($fh);
1564 *
1565 * is implemented as if written as
1566 *
1567 * readline($x[$i], $fh);
1568 *
1569 * (that is, if the perl-level readline function took two args, which it
1570 * doesn't). The 'while (<>) {...}' construct is handled specially by the
1571 * parser, but not specially by this op. The parser treats the condition
1572 * as
1573 *
1574 * defined($_ = <>)
1575 *
1576 * which is then optimised into the equivalent of
1577 *
1578 * defined(readline($_, *ARGV))
1579 *
1580 * When called as a real function, e.g. (\&CORE::readline)->(*STDIN),
1581 * pp_coreargs() will have pushed a NULL if no argument was supplied.
1582 *
1583 * The parser decides whether '<something>' in the perl src code causes an
1584 * OP_GLOB or an OP_READLINE op to be planted.
1585 */
1586
PP(pp_readline)1587 PP(pp_readline)
1588 {
1589 SV *arg = *PL_stack_sp;
1590
1591 /* pp_coreargs pushes a NULL to indicate no args passed to
1592 * CORE::readline() */
1593 if (arg) {
1594 SvGETMAGIC(arg);
1595
1596 /* unrolled tryAMAGICunTARGETlist(iter_amg, 0) */
1597 SV *tmpsv;
1598 U8 gimme = GIMME_V;
1599 if (UNLIKELY(SvAMAGIC(arg) &&
1600 (tmpsv = amagic_call(arg, &PL_sv_undef, iter_amg,
1601 AMGf_want_list | AMGf_noright
1602 |AMGf_unary))))
1603 {
1604 if (gimme == G_VOID) {
1605 NOOP;
1606 }
1607 else if (gimme == G_LIST) {
1608 SSize_t i;
1609 SSize_t len;
1610 assert(SvTYPE(tmpsv) == SVt_PVAV);
1611 len = av_count((AV *)tmpsv);
1612 assert(*PL_stack_sp == arg);
1613 rpp_popfree_1_NN(); /* pop the original filehhandle arg */
1614 /* no assignment target to pop */
1615 assert(!(PL_op->op_flags & OPf_STACKED));
1616 rpp_extend(len);
1617 for (i = 0; i < len; ++i)
1618 /* amagic_call() naughtily doesn't increment the ref counts
1619 * of the items it pushes onto the temporary array. So we
1620 * don't need to decrement them when shifting off. */
1621 rpp_push_1(av_shift((AV *)tmpsv));
1622 }
1623 else { /* AMGf_want_scalar */
1624 /* OPf_STACKED: assignment optimised away and target
1625 * on stack */
1626 SV *targ = (PL_op->op_flags & OPf_STACKED)
1627 ? PL_stack_sp[-1]
1628 : PAD_SV(PL_op->op_targ);
1629 sv_setsv(targ, tmpsv);
1630 SvSETMAGIC(targ);
1631 if (PL_op->op_flags & OPf_STACKED) {
1632 rpp_popfree_1_NN();
1633 assert(*PL_stack_sp == targ);
1634 }
1635 else
1636 rpp_replace_1_1_NN(targ);
1637 }
1638 return NORMAL;
1639 }
1640 /* end of unrolled tryAMAGICunTARGETlist */
1641
1642 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp);
1643 #ifdef PERL_RC_STACK
1644 /* PL_last_in_gv appears to be non-refcounted, so won't keep
1645 * GV alive */
1646 if (SvREFCNT(PL_last_in_gv) < 2)
1647 sv_2mortal((SV*)PL_last_in_gv);
1648 #endif
1649 rpp_popfree_1_NN();
1650 }
1651 else {
1652 PL_last_in_gv = PL_argvgv;
1653 PL_stack_sp--;
1654 }
1655
1656
1657 /* is it *FOO, $fh, or 'FOO' ? */
1658 if (!isGV_with_GP(PL_last_in_gv)) {
1659 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
1660 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
1661 else {
1662 rpp_xpush_1(MUTABLE_SV(PL_last_in_gv));
1663 Perl_pp_rv2gv(aTHX);
1664 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp);
1665 rpp_popfree_1_NN();
1666 assert( (SV*)PL_last_in_gv == &PL_sv_undef
1667 || isGV_with_GP(PL_last_in_gv));
1668 }
1669 }
1670
1671 return do_readline();
1672 }
1673
1674
PP(pp_eq)1675 PP(pp_eq)
1676 {
1677 if (rpp_try_AMAGIC_2(eq_amg, AMGf_numeric))
1678 return NORMAL;
1679
1680 SV *right = PL_stack_sp[0];
1681 SV *left = PL_stack_sp[-1];
1682
1683 U32 flags_and = SvFLAGS(left) & SvFLAGS(right);
1684 U32 flags_or = SvFLAGS(left) | SvFLAGS(right);
1685
1686 rpp_replace_2_IMM_NN(boolSV(
1687 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
1688 ? (SvIVX(left) == SvIVX(right))
1689 : (flags_and & SVf_NOK)
1690 ? (SvNVX(left) == SvNVX(right))
1691 : ( do_ncmp(left, right) == 0)
1692 ));
1693 return NORMAL;
1694 }
1695
1696
1697 /* also used for: pp_i_preinc() */
1698
PP(pp_preinc)1699 PP(pp_preinc)
1700 {
1701 SV *sv = *PL_stack_sp;
1702
1703 if (LIKELY(((sv->sv_flags &
1704 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1705 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1706 == SVf_IOK))
1707 && SvIVX(sv) != IV_MAX)
1708 {
1709 SvIV_set(sv, SvIVX(sv) + 1);
1710 }
1711 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1712 sv_inc(sv);
1713 SvSETMAGIC(sv);
1714 return NORMAL;
1715 }
1716
1717
1718 /* also used for: pp_i_predec() */
1719
PP(pp_predec)1720 PP(pp_predec)
1721 {
1722 SV *sv = *PL_stack_sp;
1723
1724 if (LIKELY(((sv->sv_flags &
1725 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1726 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1727 == SVf_IOK))
1728 && SvIVX(sv) != IV_MIN)
1729 {
1730 SvIV_set(sv, SvIVX(sv) - 1);
1731 }
1732 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */
1733 sv_dec(sv);
1734 SvSETMAGIC(sv);
1735 return NORMAL;
1736 }
1737
1738
1739 /* also used for: pp_orassign() */
1740
PP(pp_or)1741 PP(pp_or)
1742 {
1743 SV *sv;
1744 PERL_ASYNC_CHECK();
1745 sv = *PL_stack_sp;
1746 if (SvTRUE_NN(sv))
1747 return NORMAL;
1748 else {
1749 if (PL_op->op_type == OP_OR)
1750 rpp_popfree_1_NN();
1751 return cLOGOP->op_other;
1752 }
1753 }
1754
1755
1756 /* also used for: pp_dor() pp_dorassign() */
1757
PP(pp_defined)1758 PP(pp_defined)
1759 {
1760 SV* sv = *PL_stack_sp;
1761 bool defined = FALSE;
1762 const int op_type = PL_op->op_type;
1763 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
1764
1765 if (is_dor) {
1766 PERL_ASYNC_CHECK();
1767 if (UNLIKELY(!sv || !SvANY(sv))) {
1768 if (op_type == OP_DOR)
1769 rpp_popfree_1();
1770 return cLOGOP->op_other;
1771 }
1772 }
1773 else {
1774 /* OP_DEFINED */
1775 if (UNLIKELY(!sv || !SvANY(sv))) {
1776 rpp_replace_1_1(&PL_sv_no);
1777 return NORMAL;
1778 }
1779 }
1780
1781 /* Historically what followed was a switch on SvTYPE(sv), handling SVt_PVAV,
1782 * SVt_PVCV, SVt_PVHV and "default". `defined &sub` is still valid syntax,
1783 * hence we still need the special case PVCV code. But AVs and HVs now
1784 * should never arrive here... */
1785 #ifdef DEBUGGING
1786 assert(SvTYPE(sv) != SVt_PVAV);
1787 assert(SvTYPE(sv) != SVt_PVHV);
1788 #endif
1789
1790 if (UNLIKELY(SvTYPE(sv) == SVt_PVCV)) {
1791 if (CvROOT(sv) || CvXSUB(sv))
1792 defined = TRUE;
1793 }
1794 else {
1795 SvGETMAGIC(sv);
1796 if (SvOK(sv))
1797 defined = TRUE;
1798 }
1799
1800 if (is_dor) {
1801 if(defined)
1802 return NORMAL;
1803 if(op_type == OP_DOR)
1804 rpp_popfree_1_NN();
1805 return cLOGOP->op_other;
1806 }
1807 /* assuming OP_DEFINED */
1808 rpp_replace_1_IMM_NN(defined ? &PL_sv_yes : &PL_sv_no);
1809 return NORMAL;
1810 }
1811
1812
1813
PP(pp_add)1814 PP(pp_add)
1815 {
1816 bool useleft; SV *svl, *svr;
1817 SV *targ = (PL_op->op_flags & OPf_STACKED)
1818 ? PL_stack_sp[-1]
1819 : PAD_SV(PL_op->op_targ);
1820
1821 if (rpp_try_AMAGIC_2(add_amg, AMGf_assign|AMGf_numeric))
1822 return NORMAL;
1823
1824 svr = PL_stack_sp[0];
1825 svl = PL_stack_sp[-1];
1826
1827 #ifdef PERL_PRESERVE_IVUV
1828
1829 /* special-case some simple common cases */
1830 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1831 IV il, ir;
1832 U32 flags = (svl->sv_flags & svr->sv_flags);
1833 if (flags & SVf_IOK) {
1834 /* both args are simple IVs */
1835 UV topl, topr;
1836 il = SvIVX(svl);
1837 ir = SvIVX(svr);
1838 do_iv:
1839 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1840 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1841
1842 /* if both are in a range that can't under/overflow, do a
1843 * simple integer add: if the top of both numbers
1844 * are 00 or 11, then it's safe */
1845 if (!( ((topl+1) | (topr+1)) & 2)) {
1846 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1847 goto ret;
1848 }
1849 goto generic;
1850 }
1851 else if (flags & SVf_NOK) {
1852 /* both args are NVs */
1853 NV nl = SvNVX(svl);
1854 NV nr = SvNVX(svr);
1855
1856 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1857 /* nothing was lost by converting to IVs */
1858 goto do_iv;
1859 }
1860 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1861 goto ret;
1862 }
1863 }
1864
1865 generic:
1866
1867 useleft = USE_LEFT(svl);
1868 /* We must see if we can perform the addition with integers if possible,
1869 as the integer code detects overflow while the NV code doesn't.
1870 If either argument hasn't had a numeric conversion yet attempt to get
1871 the IV. It's important to do this now, rather than just assuming that
1872 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1873 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1874 integer in case the second argument is IV=9223372036854775806
1875 We can (now) rely on sv_2iv to do the right thing, only setting the
1876 public IOK flag if the value in the NV (or PV) slot is truly integer.
1877
1878 A side effect is that this also aggressively prefers integer maths over
1879 fp maths for integer values.
1880
1881 How to detect overflow?
1882
1883 C 99 section 6.2.6.1 says
1884
1885 The range of nonnegative values of a signed integer type is a subrange
1886 of the corresponding unsigned integer type, and the representation of
1887 the same value in each type is the same. A computation involving
1888 unsigned operands can never overflow, because a result that cannot be
1889 represented by the resulting unsigned integer type is reduced modulo
1890 the number that is one greater than the largest value that can be
1891 represented by the resulting type.
1892
1893 (the 9th paragraph)
1894
1895 which I read as "unsigned ints wrap."
1896
1897 signed integer overflow seems to be classed as "exception condition"
1898
1899 If an exceptional condition occurs during the evaluation of an
1900 expression (that is, if the result is not mathematically defined or not
1901 in the range of representable values for its type), the behavior is
1902 undefined.
1903
1904 (6.5, the 5th paragraph)
1905
1906 I had assumed that on 2s complement machines signed arithmetic would
1907 wrap, hence coded pp_add and pp_subtract on the assumption that
1908 everything perl builds on would be happy. After much wailing and
1909 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1910 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
1911 unsigned code below is actually shorter than the old code. :-)
1912 */
1913
1914 if (SvIV_please_nomg(svr)) {
1915 /* Unless the left argument is integer in range we are going to have to
1916 use NV maths. Hence only attempt to coerce the right argument if
1917 we know the left is integer. */
1918 UV auv = 0;
1919 bool auvok = FALSE;
1920 bool a_valid = 0;
1921
1922 if (!useleft) {
1923 auv = 0;
1924 a_valid = auvok = 1;
1925 /* left operand is undef, treat as zero. + 0 is identity,
1926 Could TARGi or TARGu right now, but space optimise by not
1927 adding lots of code to speed up what is probably a rare-ish
1928 case. */
1929 } else {
1930 /* Left operand is defined, so is it IV? */
1931 if (SvIV_please_nomg(svl)) {
1932 if ((auvok = SvUOK(svl)))
1933 auv = SvUVX(svl);
1934 else {
1935 const IV aiv = SvIVX(svl);
1936 if (aiv >= 0) {
1937 auv = aiv;
1938 auvok = 1; /* Now acting as a sign flag. */
1939 } else {
1940 /* Using 0- here and later to silence bogus warning
1941 * from MS VC */
1942 auv = (UV) (0 - (UV) aiv);
1943 }
1944 }
1945 a_valid = 1;
1946 }
1947 }
1948 if (a_valid) {
1949 bool result_good = 0;
1950 UV result;
1951 UV buv;
1952 bool buvok = SvUOK(svr);
1953
1954 if (buvok)
1955 buv = SvUVX(svr);
1956 else {
1957 const IV biv = SvIVX(svr);
1958 if (biv >= 0) {
1959 buv = biv;
1960 buvok = 1;
1961 } else
1962 buv = (UV) (0 - (UV) biv);
1963 }
1964 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1965 else "IV" now, independent of how it came in.
1966 if a, b represents positive, A, B negative, a maps to -A etc
1967 a + b => (a + b)
1968 A + b => -(a - b)
1969 a + B => (a - b)
1970 A + B => -(a + b)
1971 all UV maths. negate result if A negative.
1972 add if signs same, subtract if signs differ. */
1973
1974 if (auvok ^ buvok) {
1975 /* Signs differ. */
1976 if (auv >= buv) {
1977 result = auv - buv;
1978 /* Must get smaller */
1979 if (result <= auv)
1980 result_good = 1;
1981 } else {
1982 result = buv - auv;
1983 if (result <= buv) {
1984 /* result really should be -(auv-buv). as its negation
1985 of true value, need to swap our result flag */
1986 auvok = !auvok;
1987 result_good = 1;
1988 }
1989 }
1990 } else {
1991 /* Signs same */
1992 result = auv + buv;
1993 if (result >= auv)
1994 result_good = 1;
1995 }
1996 if (result_good) {
1997 if (auvok)
1998 TARGu(result,1);
1999 else {
2000 /* Negate result */
2001 if (result <= (UV)IV_MIN)
2002 TARGi(result == (UV)IV_MIN
2003 ? IV_MIN : -(IV)result, 1);
2004 else {
2005 /* result valid, but out of range for IV. */
2006 TARGn(-(NV)result, 1);
2007 }
2008 }
2009 goto ret;
2010 } /* Overflow, drop through to NVs. */
2011 }
2012 }
2013
2014 #else
2015 useleft = USE_LEFT(svl);
2016 #endif
2017
2018 {
2019 NV value = SvNV_nomg(svr);
2020 if (!useleft) {
2021 /* left operand is undef, treat as zero. + 0.0 is identity. */
2022 TARGn(value, 1);
2023 }
2024 else {
2025 TARGn(value + SvNV_nomg(svl), 1);
2026 }
2027 }
2028
2029 ret:
2030 rpp_replace_2_1_NN(targ);
2031 return NORMAL;
2032 }
2033
2034
2035 /* also used for: pp_aelemfast_lex() */
2036
PP(pp_aelemfast)2037 PP(pp_aelemfast)
2038 {
2039 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
2040 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
2041 const U32 lval = PL_op->op_flags & OPf_MOD;
2042 const I8 key = (I8)PL_op->op_private;
2043 SV** svp;
2044 SV *sv;
2045
2046 assert(SvTYPE(av) == SVt_PVAV);
2047
2048 /* inlined av_fetch() for simple cases ... */
2049 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
2050 sv = AvARRAY(av)[key];
2051 if (sv)
2052 goto ret;
2053 if (!lval) {
2054 sv = &PL_sv_undef;
2055 goto ret;
2056 }
2057 }
2058
2059 /* ... else do it the hard way */
2060 svp = av_fetch(av, key, lval);
2061 sv = (svp ? *svp : &PL_sv_undef);
2062
2063 if (UNLIKELY(!svp && lval))
2064 DIE(aTHX_ PL_no_aelem, (int)key);
2065
2066 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2067 mg_get(sv);
2068
2069 ret:
2070 rpp_xpush_1(sv);
2071 return NORMAL;
2072 }
2073
PP(pp_join)2074 PP(pp_join)
2075 {
2076 dMARK; dTARGET;
2077 MARK++;
2078 do_join(TARG, *MARK, MARK, PL_stack_sp);
2079 rpp_popfree_to_NN(MARK - 1);
2080 rpp_push_1(TARG);
2081 return NORMAL;
2082 }
2083
2084
2085 /* Oversized hot code. */
2086
2087 /* also used for: pp_say() */
2088
PP(pp_print)2089 PP(pp_print)
2090 {
2091 dMARK; dORIGMARK;
2092 PerlIO *fp;
2093 MAGIC *mg;
2094 GV * const gv
2095 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
2096 IO *io = GvIO(gv);
2097 SV *retval = &PL_sv_undef;
2098
2099 if (io
2100 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
2101 {
2102 had_magic:
2103 if (MARK == ORIGMARK) {
2104 /* If using default handle then we need to make space to
2105 * pass object as 1st arg, so move other args up ...
2106 */
2107 rpp_extend(1);
2108 MARK = ORIGMARK; /* stack may have been realloced */
2109 ++MARK;
2110 Move(MARK, MARK + 1, (PL_stack_sp - MARK) + 1, SV*);
2111 *MARK = NULL;
2112 ++PL_stack_sp;
2113 }
2114 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
2115 mg,
2116 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
2117 | (PL_op->op_type == OP_SAY
2118 ? TIED_METHOD_SAY : 0)),
2119 PL_stack_sp - mark);
2120 }
2121
2122 if (!io) {
2123 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
2124 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
2125 goto had_magic;
2126 report_evil_fh(gv);
2127 SETERRNO(EBADF,RMS_IFI);
2128 goto just_say_no;
2129 }
2130 else if (!(fp = IoOFP(io))) {
2131 if (IoIFP(io))
2132 report_wrongway_fh(gv, '<');
2133 else
2134 report_evil_fh(gv);
2135 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
2136 goto just_say_no;
2137 }
2138 else {
2139 SV * const ofs = GvSV(PL_ofsgv); /* $, */
2140 MARK++;
2141 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
2142 while (MARK <= PL_stack_sp) {
2143 if (!do_print(*MARK, fp))
2144 break;
2145 MARK++;
2146 if (MARK <= PL_stack_sp) {
2147 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
2148 if (!do_print(GvSV(PL_ofsgv), fp)) {
2149 MARK--;
2150 break;
2151 }
2152 }
2153 }
2154 }
2155 else {
2156 while (MARK <= PL_stack_sp) {
2157 if (!do_print(*MARK, fp))
2158 break;
2159 MARK++;
2160 }
2161 }
2162 if (MARK <= PL_stack_sp)
2163 goto just_say_no;
2164 else {
2165 if (PL_op->op_type == OP_SAY) {
2166 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
2167 goto just_say_no;
2168 }
2169 else if (PL_ors_sv && SvOK(PL_ors_sv))
2170 if (!do_print(PL_ors_sv, fp)) /* $\ */
2171 goto just_say_no;
2172
2173 if (IoFLAGS(io) & IOf_FLUSH)
2174 if (PerlIO_flush(fp) == EOF)
2175 goto just_say_no;
2176 }
2177 }
2178 retval = &PL_sv_yes;
2179
2180 just_say_no:
2181 rpp_popfree_to_NN(ORIGMARK);
2182 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID)
2183 rpp_xpush_IMM(retval);
2184 return NORMAL;
2185 }
2186
2187
2188 /* do the common parts of pp_padhv() and pp_rv2hv()
2189 * It assumes the caller has done rpp_extend(1) or equivalent.
2190 * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
2191 * 'has_targ' indicates that the op has a target - this should
2192 * be a compile-time constant so that the code can constant-folded as
2193 * appropriate. has_targ also implies that the caller has left an
2194 * arg on the stack which needs freeing.
2195 * */
2196
2197 PERL_STATIC_INLINE OP*
S_padhv_rv2hv_common(pTHX_ HV * hv,U8 gimme,bool is_keys,bool has_targ)2198 S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
2199 {
2200 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
2201
2202 if (gimme == G_LIST) {
2203 /* push all (key,value) pairs onto stack */
2204 if (has_targ) { /* i.e. if has arg still on stack */
2205 #ifdef PERL_RC_STACK
2206 SSize_t sp_base = PL_stack_sp - PL_stack_base;
2207 hv_pushkv(hv, 3);
2208 /* Now safe to free the original arg on the stack and shuffle
2209 * down one place anything pushed on top of it */
2210 SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base);
2211 SV *old_sv = PL_stack_sp[-nitems];
2212 if (nitems)
2213 Move(PL_stack_sp - nitems + 1,
2214 PL_stack_sp - nitems, nitems, SV*);
2215 PL_stack_sp--;
2216 SvREFCNT_dec_NN(old_sv);
2217 #else
2218 rpp_popfree_1_NN();
2219 hv_pushkv(hv, 3);
2220 #endif
2221 }
2222 else
2223 hv_pushkv(hv, 3);
2224 return NORMAL;
2225 }
2226
2227 if (is_keys)
2228 /* 'keys %h' masquerading as '%h': reset iterator */
2229 (void)hv_iterinit(hv);
2230
2231 if (gimme == G_VOID) {
2232 if (has_targ)
2233 rpp_popfree_1_NN();
2234 return NORMAL;
2235 }
2236
2237 bool is_bool = ( PL_op->op_private & OPpTRUEBOOL
2238 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
2239 && block_gimme() == G_VOID));
2240
2241 MAGIC *is_tied_mg = SvRMAGICAL(hv)
2242 ? mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied)
2243 : NULL;
2244
2245 IV i = 0;
2246 SV *sv = NULL;
2247 if (UNLIKELY(is_tied_mg)) {
2248 if (is_keys && !is_bool) {
2249 i = 0;
2250 while (hv_iternext(hv))
2251 i++;
2252 /* hv finished with. Safe to free arg now */
2253 if (has_targ)
2254 rpp_popfree_1_NN();
2255 goto push_i;
2256 }
2257 else {
2258 sv = magic_scalarpack(hv, is_tied_mg);
2259 /* hv finished with. Safe to free arg now */
2260 if (has_targ)
2261 rpp_popfree_1_NN();
2262 rpp_push_1(sv);
2263 }
2264 }
2265 else {
2266 #if defined(DYNAMIC_ENV_FETCH) && defined(VMS)
2267 /* maybe nothing set up %ENV for iteration yet...
2268 do this always (not just if HvUSEDKEYS(hv) is currently 0) because
2269 we ought to give a *consistent* answer to "how many keys?"
2270 whether we ask this op in scalar context, or get the list of all
2271 keys then check its length, and whether we do either with or without
2272 an %ENV lookup first. prime_env_iter() returns quickly if nothing
2273 needs doing. */
2274 if (SvRMAGICAL((const SV *)hv)
2275 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2276 prime_env_iter();
2277 }
2278 #endif
2279 i = HvUSEDKEYS(hv);
2280
2281 /* hv finished with. Safe to free arg now */
2282 if (has_targ)
2283 rpp_popfree_1_NN();
2284
2285 if (is_bool) {
2286 rpp_push_IMM(i ? &PL_sv_yes : &PL_sv_zero);
2287 }
2288 else {
2289 push_i:
2290 if (has_targ) {
2291 dTARGET;
2292 TARGi(i,1);
2293 rpp_push_1(targ);
2294 }
2295 else
2296 if (is_keys) {
2297 /* parent op should be an unused OP_KEYS whose targ we can
2298 * use */
2299 dTARG;
2300 OP *k;
2301
2302 assert(!OpHAS_SIBLING(PL_op));
2303 k = PL_op->op_sibparent;
2304 assert(k->op_type == OP_KEYS);
2305 TARG = PAD_SV(k->op_targ);
2306 TARGi(i,1);
2307 rpp_push_1(targ);
2308 }
2309 else
2310 rpp_push_1_norc(newSViv(i));
2311 }
2312 }
2313
2314 return NORMAL;
2315 }
2316
2317
2318 /* This is also called directly by pp_lvavref. */
PP(pp_padav)2319 PP(pp_padav)
2320 {
2321 dTARGET;
2322 U8 gimme;
2323
2324 assert(SvTYPE(TARG) == SVt_PVAV);
2325 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
2326 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
2327 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
2328
2329
2330 if (PL_op->op_flags & OPf_REF)
2331 goto ret;
2332
2333 if (PL_op->op_private & OPpMAYBE_LVSUB) {
2334 const I32 flags = is_lvalue_sub();
2335 if (flags && !(flags & OPpENTERSUB_INARGS)) {
2336 if (GIMME_V == G_SCALAR)
2337 /* diag_listed_as: Can't return %s to lvalue scalar context */
2338 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
2339 goto ret;
2340 }
2341 }
2342
2343 gimme = GIMME_V;
2344 if (gimme == G_LIST)
2345 return S_pushav(aTHX_ (AV*)TARG);
2346
2347 if (gimme == G_VOID)
2348 return NORMAL;
2349
2350 {
2351 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
2352 rpp_extend(1);
2353 if (!maxarg)
2354 targ = &PL_sv_zero;
2355 else if (PL_op->op_private & OPpTRUEBOOL)
2356 targ = &PL_sv_yes;
2357 else {
2358 rpp_push_1_norc(newSViv(maxarg));
2359 return NORMAL;
2360 }
2361 rpp_push_IMM(targ);
2362 return NORMAL;
2363 }
2364
2365 ret:
2366 rpp_xpush_1(targ);
2367 return NORMAL;
2368 }
2369
2370
PP(pp_padhv)2371 PP(pp_padhv)
2372 {
2373 dTARGET;
2374 U8 gimme;
2375
2376 assert(SvTYPE(TARG) == SVt_PVHV);
2377 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
2378 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
2379 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
2380
2381 rpp_extend(1);
2382
2383 if (PL_op->op_flags & OPf_REF) {
2384 rpp_push_1(TARG);
2385 return NORMAL;
2386 }
2387 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
2388 const I32 flags = is_lvalue_sub();
2389 if (flags && !(flags & OPpENTERSUB_INARGS)) {
2390 if (GIMME_V == G_SCALAR)
2391 /* diag_listed_as: Can't return %s to lvalue scalar context */
2392 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
2393 rpp_push_1(TARG);
2394 return NORMAL;
2395 }
2396 }
2397
2398 gimme = GIMME_V;
2399
2400 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
2401 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
2402 0 /* has_targ*/);
2403 }
2404
2405
2406 /* also used for: pp_rv2hv() */
2407 /* also called directly by pp_lvavref */
2408
PP(pp_rv2av)2409 PP(pp_rv2av)
2410 {
2411 SV *sv = *PL_stack_sp;
2412 const U8 gimme = GIMME_V;
2413 static const char an_array[] = "an ARRAY";
2414 static const char a_hash[] = "a HASH";
2415 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
2416 || PL_op->op_type == OP_LVAVREF;
2417 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
2418
2419 SvGETMAGIC(sv);
2420 if (SvROK(sv)) {
2421 if (UNLIKELY(SvAMAGIC(sv))) {
2422 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
2423 }
2424 sv = SvRV(sv);
2425 if (UNLIKELY(SvTYPE(sv) != type))
2426 /* diag_listed_as: Not an ARRAY reference */
2427 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
2428 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
2429 && PL_op->op_private & OPpLVAL_INTRO))
2430 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
2431 }
2432 else if (UNLIKELY(SvTYPE(sv) != type)) {
2433 GV *gv;
2434
2435 if (!isGV_with_GP(sv)) {
2436 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
2437 type);
2438 if (!gv)
2439 return NORMAL;
2440 }
2441 else {
2442 gv = MUTABLE_GV(sv);
2443 }
2444 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
2445 if (PL_op->op_private & OPpLVAL_INTRO)
2446 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
2447 }
2448 if (PL_op->op_flags & OPf_REF) {
2449 rpp_replace_1_1_NN(sv);
2450 return NORMAL;
2451 }
2452 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
2453 const I32 flags = is_lvalue_sub();
2454 if (flags && !(flags & OPpENTERSUB_INARGS)) {
2455 if (gimme != G_LIST)
2456 goto croak_cant_return;
2457 rpp_replace_1_1_NN(sv);
2458 return NORMAL;
2459 }
2460 }
2461
2462 if (is_pp_rv2av) {
2463 AV *const av = MUTABLE_AV(sv);
2464
2465 if (gimme == G_LIST) {
2466 #ifdef PERL_RC_STACK
2467 SSize_t sp_base = PL_stack_sp - PL_stack_base;
2468 (void)S_pushav(aTHX_ av);
2469 /* Now safe to free the original arg on the stack and shuffle
2470 * down one place anything pushed on top of it */
2471 SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base);
2472 SV *old_sv = PL_stack_sp[-nitems];
2473 if (nitems)
2474 Move(PL_stack_sp - nitems + 1,
2475 PL_stack_sp - nitems, nitems, SV*);
2476 PL_stack_sp--;
2477 SvREFCNT_dec_NN(old_sv);
2478 return NORMAL;
2479 #else
2480 rpp_popfree_1_NN();
2481 return S_pushav(aTHX_ av);
2482 #endif
2483 }
2484
2485 if (gimme == G_SCALAR) {
2486 const SSize_t maxarg = AvFILL(av) + 1;
2487 if (PL_op->op_private & OPpTRUEBOOL)
2488 rpp_replace_1_IMM_NN(maxarg ? &PL_sv_yes : &PL_sv_zero);
2489 else {
2490 dTARGET;
2491 TARGi(maxarg, 1);
2492 rpp_replace_1_1_NN(targ);
2493 }
2494 }
2495 }
2496 else {
2497 /* this static function is responsible for popping sv off stack */
2498 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
2499 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2500 1 /* has_targ*/);
2501 }
2502 return NORMAL;
2503
2504 croak_cant_return:
2505 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
2506 is_pp_rv2av ? "array" : "hash");
2507 }
2508
2509
2510 STATIC void
S_do_oddball(pTHX_ SV ** oddkey,SV ** firstkey)2511 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
2512 {
2513 PERL_ARGS_ASSERT_DO_ODDBALL;
2514
2515 if (*oddkey) {
2516 if (ckWARN(WARN_MISC)) {
2517 const char *err;
2518 if (oddkey == firstkey &&
2519 SvROK(*oddkey) &&
2520 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2521 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
2522 {
2523 err = "Reference found where even-sized list expected";
2524 }
2525 else
2526 err = "Odd number of elements in hash assignment";
2527 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
2528 }
2529
2530 }
2531 }
2532
2533
2534 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2535 * are common to both the LHS and RHS of an aassign, and replace them
2536 * with copies. All these copies are made before the actual list assign is
2537 * done.
2538 *
2539 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2540 * element ($b) to the first LH element ($a), modifies $a; when the
2541 * second assignment is done, the second RH element now has the wrong
2542 * value. So we initially replace the RHS with ($b, copy($a)).
2543 * Note that we don't need to make a copy of $b.
2544 *
2545 * The algorithm below works by, for every RHS element, mark the
2546 * corresponding LHS target element with SVf_BREAK. Then if the RHS
2547 * element is found with SVf_BREAK set, it means it would have been
2548 * modified, so make a copy.
2549 * Note that by scanning both LHS and RHS in lockstep, we avoid
2550 * unnecessary copies (like $b above) compared with a naive
2551 * "mark all LHS; copy all marked RHS; unmark all LHS".
2552 *
2553 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2554 * it can't be common and can be skipped.
2555 *
2556 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2557 * that we thought we didn't need to call S_aassign_copy_common(), but we
2558 * have anyway for sanity checking. If we find we need to copy, then panic.
2559 */
2560
2561 PERL_STATIC_INLINE void
S_aassign_copy_common(pTHX_ SV ** firstlelem,SV ** lastlelem,SV ** firstrelem,SV ** lastrelem,bool fake)2562 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
2563 SV **firstrelem, SV **lastrelem
2564 #ifdef DEBUGGING
2565 , bool fake
2566 #endif
2567 )
2568 {
2569 SV **relem;
2570 SV **lelem;
2571 SSize_t lcount = lastlelem - firstlelem + 1;
2572 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
2573 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
2574 bool copy_all = FALSE;
2575
2576 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
2577 assert(firstlelem < lastlelem); /* at least 2 LH elements */
2578 assert(firstrelem < lastrelem); /* at least 2 RH elements */
2579
2580
2581 lelem = firstlelem;
2582 /* we never have to copy the first RH element; it can't be corrupted
2583 * by assigning something to the corresponding first LH element.
2584 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
2585 */
2586 relem = firstrelem + 1;
2587
2588 for (; relem <= lastrelem; relem++) {
2589 SV *svr;
2590
2591 /* mark next LH element */
2592
2593 if (--lcount >= 0) {
2594 SV *svl = *lelem++;
2595
2596 if (UNLIKELY(!svl)) {/* skip AV alias marker */
2597 assert (lelem <= lastlelem);
2598 svl = *lelem++;
2599 lcount--;
2600 }
2601
2602 assert(svl);
2603 if (SvSMAGICAL(svl)) {
2604 copy_all = TRUE;
2605 }
2606 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
2607 if (!marked)
2608 return;
2609 /* this LH element will consume all further args;
2610 * no need to mark any further LH elements (if any).
2611 * But we still need to scan any remaining RHS elements;
2612 * set lcount negative to distinguish from lcount == 0,
2613 * so the loop condition continues being true
2614 */
2615 lcount = -1;
2616 lelem--; /* no need to unmark this element */
2617 }
2618 else if (!(do_rc1 &&
2619 #ifdef PERL_RC_STACK
2620 SvREFCNT(svl) <= 2
2621 #else
2622 SvREFCNT(svl) == 1
2623 #endif
2624 ) && !SvIMMORTAL(svl))
2625 {
2626 SvFLAGS(svl) |= SVf_BREAK;
2627 marked = TRUE;
2628 }
2629 else if (!marked) {
2630 /* don't check RH element if no SVf_BREAK flags set yet */
2631 if (!lcount)
2632 break;
2633 continue;
2634 }
2635 }
2636
2637 /* see if corresponding RH element needs copying */
2638
2639 assert(marked);
2640 svr = *relem;
2641 assert(svr);
2642
2643 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
2644 U32 brk = (SvFLAGS(svr) & SVf_BREAK);
2645
2646 #ifdef DEBUGGING
2647 if (fake) {
2648 /* op_dump(PL_op); */
2649 Perl_croak(aTHX_
2650 "panic: aassign skipped needed copy of common RH elem %"
2651 UVuf, (UV)(relem - firstrelem));
2652 }
2653 #endif
2654
2655 TAINT_NOT; /* Each item is independent */
2656
2657 #ifndef PERL_RC_STACK
2658 /* The TODO test was eventually commented out. It's now been
2659 * revived, but only on PERL_RC_STACK builds. Continue
2660 * this hacky workaround otherwise - DAPM Sept 2023 */
2661
2662 /* Dear TODO test in t/op/sort.t, I love you.
2663 (It's relying on a panic, not a "semi-panic" from newSVsv()
2664 and then an assertion failure below.) */
2665 if (UNLIKELY(SvIS_FREED(svr))) {
2666 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
2667 (void*)svr);
2668 }
2669 #endif
2670
2671 /* avoid break flag while copying; otherwise COW etc
2672 * disabled... */
2673 SvFLAGS(svr) &= ~SVf_BREAK;
2674 /* Not newSVsv(), as it does not allow copy-on-write,
2675 resulting in wasteful copies.
2676 Also, we use SV_NOSTEAL in case the SV is used more than
2677 once, e.g. (...) = (f())[0,0]
2678 Where the same SV appears twice on the RHS without a ref
2679 count bump. (Although I suspect that the SV won't be
2680 stealable here anyway - DAPM).
2681 */
2682 #ifdef PERL_RC_STACK
2683 *relem = newSVsv_flags(svr,
2684 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2685 SvREFCNT_dec_NN(svr);
2686 #else
2687 *relem = sv_mortalcopy_flags(svr,
2688 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2689 #endif
2690 /* ... but restore afterwards in case it's needed again,
2691 * e.g. ($a,$b,$c) = (1,$a,$a)
2692 */
2693 SvFLAGS(svr) |= brk;
2694 }
2695
2696 if (!lcount)
2697 break;
2698 }
2699
2700 if (!marked)
2701 return;
2702
2703 /*unmark LHS */
2704
2705 while (lelem > firstlelem) {
2706 SV * const svl = *(--lelem);
2707 if (svl)
2708 SvFLAGS(svl) &= ~SVf_BREAK;
2709 }
2710 }
2711
2712
2713 /* Helper function for pp_aassign(): after performing something like
2714 *
2715 * ($<,$>) = ($>,$<); # swap real and effective uids
2716 *
2717 * the assignment to the magic variables just sets various flags in
2718 * PL_delaymagic; now we tell the OS to update the uids/gids atomically.
2719 */
2720
2721 STATIC void
S_aassign_uid(pTHX)2722 S_aassign_uid(pTHX)
2723 {
2724 /* Will be used to set PL_tainting below */
2725 Uid_t tmp_uid = PerlProc_getuid();
2726 Uid_t tmp_euid = PerlProc_geteuid();
2727 Gid_t tmp_gid = PerlProc_getgid();
2728 Gid_t tmp_egid = PerlProc_getegid();
2729
2730 /* XXX $> et al currently silently ignore failures */
2731 if (PL_delaymagic & DM_UID) {
2732 #ifdef HAS_SETRESUID
2733 PERL_UNUSED_RESULT(
2734 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2735 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
2736 (Uid_t)-1));
2737 #elif defined(HAS_SETREUID)
2738 PERL_UNUSED_RESULT(
2739 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2740 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
2741 #else
2742 # ifdef HAS_SETRUID
2743 if ((PL_delaymagic & DM_UID) == DM_RUID) {
2744 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
2745 PL_delaymagic &= ~DM_RUID;
2746 }
2747 # endif /* HAS_SETRUID */
2748 # ifdef HAS_SETEUID
2749 if ((PL_delaymagic & DM_UID) == DM_EUID) {
2750 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
2751 PL_delaymagic &= ~DM_EUID;
2752 }
2753 # endif /* HAS_SETEUID */
2754 if (PL_delaymagic & DM_UID) {
2755 if (PL_delaymagic_uid != PL_delaymagic_euid)
2756 Perl_die(aTHX_ "No setreuid available");
2757 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
2758 }
2759 #endif /* HAS_SETRESUID */
2760
2761 tmp_uid = PerlProc_getuid();
2762 tmp_euid = PerlProc_geteuid();
2763 }
2764
2765 /* XXX $> et al currently silently ignore failures */
2766 if (PL_delaymagic & DM_GID) {
2767 #ifdef HAS_SETRESGID
2768 PERL_UNUSED_RESULT(
2769 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2770 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
2771 (Gid_t)-1));
2772 #elif defined(HAS_SETREGID)
2773 PERL_UNUSED_RESULT(
2774 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2775 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
2776 #else
2777 # ifdef HAS_SETRGID
2778 if ((PL_delaymagic & DM_GID) == DM_RGID) {
2779 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
2780 PL_delaymagic &= ~DM_RGID;
2781 }
2782 # endif /* HAS_SETRGID */
2783 # ifdef HAS_SETEGID
2784 if ((PL_delaymagic & DM_GID) == DM_EGID) {
2785 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
2786 PL_delaymagic &= ~DM_EGID;
2787 }
2788 # endif /* HAS_SETEGID */
2789 if (PL_delaymagic & DM_GID) {
2790 if (PL_delaymagic_gid != PL_delaymagic_egid)
2791 Perl_die(aTHX_ "No setregid available");
2792 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
2793 }
2794 #endif /* HAS_SETRESGID */
2795
2796 tmp_gid = PerlProc_getgid();
2797 tmp_egid = PerlProc_getegid();
2798 }
2799 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
2800 #ifdef NO_TAINT_SUPPORT
2801 PERL_UNUSED_VAR(tmp_uid);
2802 PERL_UNUSED_VAR(tmp_euid);
2803 PERL_UNUSED_VAR(tmp_gid);
2804 PERL_UNUSED_VAR(tmp_egid);
2805 #endif
2806 }
2807
2808
PP(pp_aassign)2809 PP(pp_aassign)
2810 {
2811 SV **lastlelem = PL_stack_sp;
2812 SV **lastrelem = PL_stack_base + POPMARK;
2813 SV **firstrelem = PL_stack_base + POPMARK + 1;
2814 SV **firstlelem = lastrelem + 1;
2815
2816 SV **relem;
2817 SV **lelem;
2818 U8 gimme;
2819 /* PL_delaymagic is restored by JMPENV_POP on dieing, so we
2820 * only need to save locally, not on the save stack */
2821 U16 old_delaymagic = PL_delaymagic;
2822 #ifdef DEBUGGING
2823 bool fake = 0;
2824 #endif
2825
2826 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
2827
2828 /* If there's a common identifier on both sides we have to take
2829 * special care that assigning the identifier on the left doesn't
2830 * clobber a value on the right that's used later in the list.
2831 */
2832
2833 /* at least 2 LH and RH elements, or commonality isn't an issue */
2834 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2835 for (relem = firstrelem+1; relem <= lastrelem; relem++) {
2836 if (SvGMAGICAL(*relem))
2837 goto do_scan;
2838 }
2839 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2840 if (*lelem && SvSMAGICAL(*lelem))
2841 goto do_scan;
2842 }
2843 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
2844 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
2845 /* skip the scan if all scalars have a ref count of 1 */
2846 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2847 SV *sv = *lelem;
2848 if (!sv ||
2849 #ifdef PERL_RC_STACK
2850 SvREFCNT(sv) <= 2
2851 #else
2852 SvREFCNT(sv) == 1
2853 #endif
2854 )
2855 continue;
2856 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
2857 goto do_scan;
2858 break;
2859 }
2860 }
2861 else {
2862 do_scan:
2863 S_aassign_copy_common(aTHX_
2864 firstlelem, lastlelem, firstrelem, lastrelem
2865 #ifdef DEBUGGING
2866 , fake
2867 #endif
2868 );
2869 }
2870 }
2871 }
2872 #ifdef DEBUGGING
2873 else {
2874 /* on debugging builds, do the scan even if we've concluded we
2875 * don't need to, then panic if we find commonality. Note that the
2876 * scanner assumes at least 2 elements */
2877 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2878 fake = 1;
2879 goto do_scan;
2880 }
2881 }
2882 #endif
2883
2884 gimme = GIMME_V;
2885 bool is_list = (gimme == G_LIST);
2886 relem = firstrelem;
2887 lelem = firstlelem;
2888 #ifdef PERL_RC_STACK
2889 /* Where we can reset stack to at the end, without needing to free
2890 * each element. This is normally all the lelem's, but it can vary for
2891 * things like odd number of hash elements, which pushes a
2892 * &PL_sv_undef into the 'lvalue' part of the stack.
2893 */
2894 SV ** first_discard = firstlelem;
2895 #endif
2896
2897 if (relem > lastrelem)
2898 goto no_relems;
2899
2900 /* first lelem loop while there are still relems */
2901 while (LIKELY(lelem <= lastlelem)) {
2902 bool alias = FALSE;
2903 SV *lsv = *lelem;
2904
2905 TAINT_NOT; /* Each item stands on its own, taintwise. */
2906
2907 assert(relem <= lastrelem);
2908 if (UNLIKELY(!lsv)) {
2909 alias = TRUE;
2910 lsv = *++lelem;
2911 ASSUME(SvTYPE(lsv) == SVt_PVAV);
2912 }
2913
2914 switch (SvTYPE(lsv)) {
2915 case SVt_PVAV: {
2916 SV **svp;
2917 SSize_t i;
2918 SSize_t nelems = lastrelem - relem + 1;
2919 AV *ary = MUTABLE_AV(lsv);
2920
2921 /* Assigning to an aggregate is tricky. First there is the
2922 * issue of commonality, e.g. @a = ($a[0]). Since the
2923 * stack isn't refcounted, clearing @a prior to storing
2924 * elements will free $a[0]. Similarly with
2925 * sub FETCH { $status[$_[1]] } @status = @tied[0,1];
2926 *
2927 * The way to avoid these issues is to make the copy of each
2928 * SV (and we normally store a *copy* in the array) *before*
2929 * clearing the array. But this has a problem in that
2930 * if the code croaks during copying, the not-yet-stored copies
2931 * could leak. One way to avoid this is to make all the copies
2932 * mortal, but that's quite expensive.
2933 *
2934 * The current solution to these issues is to use a chunk
2935 * of the tmps stack as a temporary refcounted-stack. SVs
2936 * will be put on there during processing to avoid leaks,
2937 * but will be removed again before the end of this block,
2938 * so free_tmps() is never normally called. Also, the
2939 * sv_refcnt of the SVs doesn't have to be manipulated, since
2940 * the ownership of 1 reference count is transferred directly
2941 * from the tmps stack to the AV when the SV is stored.
2942 *
2943 * We disarm slots in the temps stack by storing PL_sv_undef
2944 * there: it doesn't matter if that SV's refcount is
2945 * repeatedly decremented during a croak. But usually this is
2946 * only an interim measure. By the end of this code block
2947 * we try where possible to not leave any PL_sv_undef's on the
2948 * tmps stack e.g. by shuffling newer entries down.
2949 *
2950 * There is one case where we don't copy: non-magical
2951 * SvTEMP(sv)'s with a ref count of 1. The only owner of these
2952 * is on the tmps stack, so its safe to directly steal the SV
2953 * rather than copying. This is common in things like function
2954 * returns, map etc, which all return a list of such SVs.
2955 *
2956 * Note however something like @a = (f())[0,0], where there is
2957 * a danger of the same SV being shared: this avoided because
2958 * when the SV is stored as $a[0], its ref count gets bumped,
2959 * so the RC==1 test fails and the second element is copied
2960 * instead.
2961 *
2962 * We also use one slot in the tmps stack to hold an extra
2963 * ref to the array, to ensure it doesn't get prematurely
2964 * freed. Again, this is removed before the end of this block.
2965 *
2966 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
2967 * @a = ($a[0]) case, but the current implementation uses the
2968 * same algorithm regardless, so ignores that flag. (It *is*
2969 * used in the hash branch below, however).
2970 *
2971 *
2972 * The net effect of this next block of code (apart from
2973 * optimisations and aliasing) is to make a copy of each
2974 * *relem and store the new SV both in the array and back on
2975 * the *relem slot of the stack, overwriting the original.
2976 * This new list of SVs will later be either returned
2977 * (G_LIST), or popped.
2978 *
2979 * Note that under PERL_RC_STACK builds most of this
2980 * complexity can be thrown away: things can be kept alive on
2981 * the argument stack without involving the temps stack. In
2982 * particular, the args are kept on the argument stack and
2983 * processed from there, rather than their pointers being
2984 * copied to the temps stack and then processed from there.
2985 */
2986
2987 #ifndef PERL_RC_STACK
2988 /* Reserve slots for ary, plus the elems we're about to copy,
2989 * then protect ary and temporarily void the remaining slots
2990 * with &PL_sv_undef */
2991 EXTEND_MORTAL(nelems + 1);
2992 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
2993 SSize_t tmps_base = PL_tmps_ix + 1;
2994 for (i = 0; i < nelems; i++)
2995 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2996 PL_tmps_ix += nelems;
2997 #endif
2998
2999 /* Make a copy of each RHS elem and save on the tmps_stack
3000 * (or pass through where we can optimise away the copy) */
3001
3002 if (UNLIKELY(alias)) {
3003 U32 lval = (is_list)
3004 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
3005 for (svp = relem; svp <= lastrelem; svp++) {
3006 SV *rsv = *svp;
3007
3008 SvGETMAGIC(rsv);
3009 if (!SvROK(rsv))
3010 DIE(aTHX_ "Assigned value is not a reference");
3011 if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
3012 /* diag_listed_as: Assigned value is not %s reference */
3013 DIE(aTHX_
3014 "Assigned value is not a SCALAR reference");
3015 if (lval) {
3016 /* XXX the 'mortal' part here is probably
3017 * unnecessary under PERL_RC_STACK.
3018 */
3019 rsv = sv_mortalcopy(rsv);
3020 rpp_replace_at_NN(svp, rsv);
3021 }
3022 /* XXX else check for weak refs? */
3023 #ifndef PERL_RC_STACK
3024 rsv = SvREFCNT_inc_NN(SvRV(rsv));
3025 assert(tmps_base <= PL_tmps_max);
3026 PL_tmps_stack[tmps_base++] = rsv;
3027 #endif
3028 }
3029 }
3030 else {
3031 for (svp = relem; svp <= lastrelem; svp++) {
3032 SV *rsv = *svp;
3033
3034 if (rpp_is_lone(rsv) && !SvGMAGICAL(rsv)) {
3035 /* can skip the copy */
3036 #ifndef PERL_RC_STACK
3037 SvREFCNT_inc_simple_void_NN(rsv);
3038 #endif
3039 SvTEMP_off(rsv);
3040 }
3041 else {
3042 SV *nsv;
3043 /* see comment in S_aassign_copy_common about
3044 * SV_NOSTEAL */
3045 nsv = newSVsv_flags(rsv,
3046 (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC));
3047 #ifdef PERL_RC_STACK
3048 rpp_replace_at_norc_NN(svp, nsv);
3049 #else
3050 /* using rpp_replace_at_norc() would mortalise,
3051 * but we're manually adding nsv to the tmps stack
3052 * below already */
3053 rpp_replace_at_NN(svp, nsv);
3054 #endif
3055
3056 rsv = nsv;
3057 }
3058
3059 #ifndef PERL_RC_STACK
3060 assert(tmps_base <= PL_tmps_max);
3061 PL_tmps_stack[tmps_base++] = rsv;
3062 #endif
3063 }
3064 }
3065
3066 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
3067 av_clear(ary);
3068
3069 /* Store in the array, the argument copies that are in the
3070 * tmps stack (or for PERL_RC_STACK, on the args stack) */
3071
3072 #ifndef PERL_RC_STACK
3073 tmps_base -= nelems;
3074 #endif
3075 if (alias || SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
3076 /* for arrays we can't cheat with, use the official API */
3077 av_extend(ary, nelems - 1);
3078 for (i = 0; i < nelems; i++) {
3079 SV **svp =
3080 #ifdef PERL_RC_STACK
3081 &relem[i];
3082 #else
3083 &(PL_tmps_stack[tmps_base + i]);
3084 #endif
3085
3086 SV *rsv = *svp;
3087 #ifdef PERL_RC_STACK
3088 if (alias) {
3089 assert(SvROK(rsv));
3090 rsv = SvRV(rsv);
3091 }
3092 #endif
3093
3094 /* A tied store won't take ownership of rsv, so keep
3095 * the 1 refcnt on the tmps stack; otherwise disarm
3096 * the tmps stack entry */
3097 if (av_store(ary, i, rsv))
3098 #ifdef PERL_RC_STACK
3099 SvREFCNT_inc_simple_NN(rsv);
3100 #else
3101 *svp = &PL_sv_undef;
3102 #endif
3103 /* av_store() may have added set magic to rsv */;
3104 SvSETMAGIC(rsv);
3105 }
3106 #ifndef PERL_RC_STACK
3107 /* disarm ary refcount: see comments below about leak */
3108 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
3109 #endif
3110 }
3111 else {
3112 /* Simple array: directly access/set the guts of the AV */
3113 SSize_t fill = nelems - 1;
3114 if (fill > AvMAX(ary))
3115 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
3116 &AvARRAY(ary));
3117 AvFILLp(ary) = fill;
3118 #ifdef PERL_RC_STACK
3119 Copy(relem, AvARRAY(ary), nelems, SV*);
3120 /* ownership of one ref count of each elem passed to
3121 * array. Quietly remove old SVs from stack, or if need
3122 * to keep the list on the stack too, bump the count */
3123 if (UNLIKELY(is_list))
3124 for (i = 0; i < nelems; i++)
3125 SvREFCNT_inc_void_NN(relem[i]);
3126 else {
3127 assert(first_discard == relem + nelems);
3128 Zero(relem, nelems, SV*);
3129 first_discard = relem;
3130 }
3131 #else
3132 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
3133 /* Quietly remove all the SVs from the tmps stack slots,
3134 * since ary has now taken ownership of the refcnt.
3135 * Also remove ary: which will now leak if we die before
3136 * the SvREFCNT_dec_NN(ary) below */
3137 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
3138 Move(&PL_tmps_stack[tmps_base + nelems],
3139 &PL_tmps_stack[tmps_base - 1],
3140 PL_tmps_ix - (tmps_base + nelems) + 1,
3141 SV*);
3142 PL_tmps_ix -= (nelems + 1);
3143 #endif
3144 }
3145
3146 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
3147 /* its assumed @ISA set magic can't die and leak ary */
3148 SvSETMAGIC(MUTABLE_SV(ary));
3149
3150 #ifdef PERL_RC_STACK
3151 assert(*lelem == (SV*)ary);
3152 *lelem = NULL;
3153 #endif
3154 lelem++;
3155 SvREFCNT_dec_NN(ary);
3156 relem = lastrelem + 1;
3157 goto no_relems;
3158 }
3159
3160 case SVt_PVHV: { /* normal hash */
3161
3162 SV **svp;
3163 SSize_t i;
3164 SSize_t nelems = lastrelem - relem + 1;
3165 HV *hash = MUTABLE_HV(lsv);
3166
3167 if (UNLIKELY(nelems & 1)) {
3168 do_oddball(lastrelem, relem);
3169 /* we have firstlelem to reuse, it's not needed any more */
3170 #ifdef PERL_RC_STACK
3171 if (lelem == lastrelem + 1) {
3172 /* the lelem slot we want to use is the
3173 * one keeping hash alive. Mortalise the hash
3174 * so it doesn't leak */
3175 assert(lastrelem[1] == (SV*)hash);
3176 sv_2mortal((SV*)hash);
3177 }
3178 else {
3179 /* safe to repurpose old lelem slot */
3180 assert(!lastrelem[1] || SvIMMORTAL(lastrelem[1]));
3181 }
3182 first_discard++;
3183 assert(first_discard = lastrelem + 2);
3184 #endif
3185 *++lastrelem = &PL_sv_undef;
3186 nelems++;
3187 }
3188
3189 /* See the SVt_PVAV branch above for a long description of
3190 * how the following all works. The main difference for hashes
3191 * is that we treat keys and values separately (and have
3192 * separate loops for them): as for arrays, values are always
3193 * copied (except for the SvTEMP optimisation), since they
3194 * need to be stored in the hash; while keys are only
3195 * processed where they might get prematurely freed or
3196 * whatever. The same comments about simplifying under
3197 * PERL_RC_STACK apply here too */
3198
3199 /* tmps stack slots:
3200 * * reserve a slot for the hash keepalive;
3201 * * reserve slots for the hash values we're about to copy;
3202 * * preallocate for the keys we'll possibly copy or refcount bump
3203 * later;
3204 * then protect hash and temporarily void the remaining
3205 * value slots with &PL_sv_undef */
3206 #ifndef PERL_RC_STACK
3207 EXTEND_MORTAL(nelems + 1);
3208 #endif
3209 /* convert to number of key/value pairs */
3210 nelems >>= 1;
3211
3212 #ifndef PERL_RC_STACK
3213 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
3214 SSize_t tmps_base = PL_tmps_ix + 1;
3215 for (i = 0; i < nelems; i++)
3216 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
3217 PL_tmps_ix += nelems;
3218 #endif
3219
3220 /* Make a copy of each RHS hash value and save on the tmps_stack
3221 * (or pass through where we can optimise away the copy) */
3222
3223 for (svp = relem + 1; svp <= lastrelem; svp += 2) {
3224 SV *rsv = *svp;
3225
3226 if (rpp_is_lone(rsv) && !SvGMAGICAL(rsv)) {
3227 /* can skip the copy */
3228 #ifndef PERL_RC_STACK
3229 SvREFCNT_inc_simple_void_NN(rsv);
3230 #endif
3231 SvTEMP_off(rsv);
3232 }
3233 else {
3234 SV *nsv;
3235 /* see comment in S_aassign_copy_common about
3236 * SV_NOSTEAL */
3237 nsv = newSVsv_flags(rsv,
3238 (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC));
3239 #ifdef PERL_RC_STACK
3240 rpp_replace_at_norc_NN(svp, nsv);
3241 #else
3242 /* using rpp_replace_at_norc() would mortalise,
3243 * but we're manually adding nsv to the tmps stack
3244 * below already */
3245 rpp_replace_at_NN(svp, nsv);
3246 #endif
3247 rsv = nsv;
3248 }
3249
3250 #ifndef PERL_RC_STACK
3251 assert(tmps_base <= PL_tmps_max);
3252 PL_tmps_stack[tmps_base++] = rsv;
3253 #endif
3254 }
3255
3256 #ifndef PERL_RC_STACK
3257 tmps_base -= nelems;
3258 #endif
3259
3260
3261 /* possibly protect keys */
3262
3263 if (UNLIKELY(is_list)) {
3264 /* handle e.g.
3265 * @a = ((%h = ($$r, 1)), $r = "x");
3266 * $_++ for %h = (1,2,3,4);
3267 */
3268 #ifndef PERL_RC_STACK
3269 EXTEND_MORTAL(nelems);
3270 #endif
3271 for (svp = relem; svp <= lastrelem; svp += 2) {
3272 rpp_replace_at_norc_NN(svp,
3273 newSVsv_flags(*svp,
3274 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
3275 }
3276 }
3277 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
3278 /* for possible commonality, e.g.
3279 * %h = ($h{a},1)
3280 * avoid premature freeing RHS keys by mortalising
3281 * them.
3282 * For a magic element, make a copy so that its magic is
3283 * called *before* the hash is emptied (which may affect
3284 * a tied value for example).
3285 * In theory we should check for magic keys in all
3286 * cases, not just under OPpASSIGN_COMMON_AGG, but in
3287 * practice, !OPpASSIGN_COMMON_AGG implies only
3288 * constants or padtmps on the RHS.
3289 *
3290 * For PERL_RC_STACK, no danger of premature frees, so
3291 * just handle the magic.
3292 */
3293 #ifdef PERL_RC_STACK
3294 for (svp = relem; svp <= lastrelem; svp += 2) {
3295 SV *rsv = *svp;
3296 if (UNLIKELY(SvGMAGICAL(rsv)))
3297 /* XXX does this actually need to be copied, or
3298 * could we just call the get magic??? */
3299 rpp_replace_at_norc_NN(svp,
3300 newSVsv_flags(rsv,
3301 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
3302 }
3303 #else
3304 EXTEND_MORTAL(nelems);
3305 for (svp = relem; svp <= lastrelem; svp += 2) {
3306 SV *rsv = *svp;
3307 if (UNLIKELY(SvGMAGICAL(rsv))) {
3308 SSize_t n;
3309 rpp_replace_at_norc_NN(svp,
3310 newSVsv_flags(rsv,
3311 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
3312 /* allow other branch to continue pushing
3313 * onto tmps stack without checking each time */
3314 n = (lastrelem - relem) >> 1;
3315 EXTEND_MORTAL(n);
3316 }
3317 else
3318 PL_tmps_stack[++PL_tmps_ix] =
3319 SvREFCNT_inc_simple_NN(rsv);
3320 }
3321 #endif
3322 }
3323
3324 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
3325 hv_clear(hash);
3326
3327 /* "nelems" was converted to the number of pairs earlier. */
3328 if (nelems > PERL_HASH_DEFAULT_HvMAX) {
3329 hv_ksplit(hash, nelems);
3330 }
3331
3332 /* now assign the keys and values to the hash */
3333
3334 #ifndef PERL_RC_STACK
3335 bool dirty_tmps = FALSE;
3336 #endif
3337 if (UNLIKELY(is_list)) {
3338 /* @a = (%h = (...)) etc */
3339 SV **svp;
3340 SV **topelem = relem;
3341
3342 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
3343 SV *key = *svp++;
3344 SV *val = *svp;
3345 /* remove duplicates from list we return */
3346 if (!hv_exists_ent(hash, key, 0)) {
3347 /* copy key back: possibly to an earlier
3348 * stack location if we encountered dups earlier,
3349 * The values will be updated later
3350 */
3351 rpp_replace_at_NN(topelem, key);
3352 topelem += 2;
3353 }
3354 /* A tied store won't take ownership of val, so keep
3355 * the 1 refcnt on the tmps stack; otherwise disarm
3356 * the tmps stack entry */
3357 if (hv_store_ent(hash, key, val, 0))
3358 #ifdef PERL_RC_STACK
3359 SvREFCNT_inc_simple_NN(val);
3360 #else
3361 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
3362 else
3363 dirty_tmps = TRUE;
3364 #endif
3365 /* hv_store_ent() may have added set magic to val */;
3366 SvSETMAGIC(val);
3367 }
3368
3369 if (topelem < svp) {
3370 /* at this point we have removed the duplicate key/value
3371 * pairs from the stack, but the remaining values may be
3372 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
3373 * the (a 2), but the stack now probably contains
3374 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
3375 * obliterates the earlier key. So refresh all values. */
3376 lastrelem = topelem - 1;
3377 while (relem < lastrelem) {
3378 HE *he;
3379 he = hv_fetch_ent(hash, *relem++, 0, 0);
3380 rpp_replace_at_NN(relem++,
3381 (he ? HeVAL(he) : &PL_sv_undef));
3382 }
3383 }
3384 }
3385 else {
3386 SV **svp;
3387 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
3388 SV *key = *svp++;
3389 SV *val = *svp;
3390 #ifdef PERL_RC_STACK
3391 {
3392 HE *stored = hv_store_ent(hash, key, val, 0);
3393 /* hv_store_ent() may have added set magic to val */;
3394 SvSETMAGIC(val);
3395 /* remove key and val from stack */
3396 *svp = NULL;
3397 if (!stored)
3398 SvREFCNT_dec_NN(val);
3399 svp[-1] = NULL;
3400 SvREFCNT_dec_NN(key);
3401 }
3402 #else
3403 if (hv_store_ent(hash, key, val, 0))
3404 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
3405 else
3406 dirty_tmps = TRUE;
3407 /* hv_store_ent() may have added set magic to val */;
3408 SvSETMAGIC(val);
3409 #endif
3410 }
3411 #ifdef PERL_RC_STACK
3412 /* now that all the key and val slots on the stack have
3413 * been discarded, we can skip freeing them on return */
3414 assert(first_discard == lastrelem + 1);
3415 first_discard = relem;
3416 #endif
3417 }
3418
3419 #ifdef PERL_RC_STACK
3420 /* Disarm the ref-counted pointer on the stack. This will
3421 * usually point to the hash, except for the case of an odd
3422 * number of elems where the hash was mortalised and its slot
3423 * on the stack was made part of the relems with the slot's
3424 * value overwritten with &PL_sv_undef. */
3425 if (*lelem == (SV*)hash) {
3426 *lelem = NULL;
3427 SvREFCNT_dec_NN(hash);
3428 }
3429 #else
3430 if (dirty_tmps) {
3431 /* there are still some 'live' recounts on the tmps stack
3432 * - usually caused by storing into a tied hash. So let
3433 * free_tmps() do the proper but slow job later.
3434 * Just disarm hash refcount: see comments below about leak
3435 */
3436 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
3437 }
3438 else {
3439 /* Quietly remove all the SVs from the tmps stack slots,
3440 * since hash has now taken ownership of the refcnt.
3441 * Also remove hash: which will now leak if we die before
3442 * the SvREFCNT_dec_NN(hash) below */
3443 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
3444 Move(&PL_tmps_stack[tmps_base + nelems],
3445 &PL_tmps_stack[tmps_base - 1],
3446 PL_tmps_ix - (tmps_base + nelems) + 1,
3447 SV*);
3448 PL_tmps_ix -= (nelems + 1);
3449 }
3450
3451 SvREFCNT_dec_NN(hash);
3452 #endif
3453 lelem++;
3454 relem = lastrelem + 1;
3455 goto no_relems;
3456 }
3457
3458 default:
3459 if (!SvIMMORTAL(lsv)) {
3460 if (UNLIKELY(
3461 rpp_is_lone(lsv) && !SvSMAGICAL(lsv) &&
3462 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
3463 ))
3464 Perl_warner(aTHX_
3465 packWARN(WARN_MISC),
3466 "Useless assignment to a temporary"
3467 );
3468
3469 #ifndef PERL_RC_STACK
3470 /* avoid freeing $$lsv if it might be needed for further
3471 * elements, e.g. ($ref, $foo) = (1, $$ref) */
3472 SV *ref;
3473 if ( SvROK(lsv)
3474 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
3475 && lelem < lastlelem
3476 ) {
3477 SSize_t ix;
3478 SvREFCNT_inc_simple_void_NN(ref);
3479 /* an unrolled sv_2mortal */
3480 ix = ++PL_tmps_ix;
3481 if (UNLIKELY(ix >= PL_tmps_max))
3482 /* speculatively grow enough to cover other
3483 * possible refs */
3484 (void)tmps_grow_p(ix + (lastlelem - lelem + 1));
3485 PL_tmps_stack[ix] = ref;
3486 }
3487 #endif
3488
3489 sv_setsv(lsv, *relem);
3490 SvSETMAGIC(lsv);
3491 if (UNLIKELY(is_list))
3492 rpp_replace_at_NN(relem, lsv);
3493 #ifdef PERL_RC_STACK
3494 *lelem = NULL;
3495 SvREFCNT_dec_NN(lsv);
3496 #endif
3497 }
3498 lelem++;
3499 if (++relem > lastrelem)
3500 goto no_relems;
3501 break;
3502 } /* switch */
3503 } /* while */
3504
3505
3506 no_relems:
3507
3508 /* simplified lelem loop for when there are no relems left */
3509 while (LIKELY(lelem <= lastlelem)) {
3510 SV *lsv = *lelem;
3511
3512 TAINT_NOT; /* Each item stands on its own, taintwise. */
3513
3514 if (UNLIKELY(!lsv)) {
3515 lsv = *++lelem;
3516 ASSUME(SvTYPE(lsv) == SVt_PVAV);
3517 }
3518
3519 switch (SvTYPE(lsv)) {
3520 case SVt_PVAV:
3521 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
3522 av_clear((AV*)lsv);
3523 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
3524 SvSETMAGIC(lsv);
3525 }
3526 break;
3527
3528 case SVt_PVHV:
3529 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
3530 hv_clear((HV*)lsv);
3531 break;
3532
3533 default:
3534 if (!SvIMMORTAL(lsv)) {
3535 sv_set_undef(lsv);
3536 SvSETMAGIC(lsv);
3537 }
3538 if (UNLIKELY(is_list)) {
3539 /* this usually grows the list of relems to be returned
3540 * into the stack space holding lelems (unless
3541 * there was previously a hash with dup elements) */
3542 #ifdef PERL_RC_STACK
3543 assert(relem <= first_discard);
3544 assert(relem <= lelem);
3545 if (relem == first_discard)
3546 first_discard++;
3547 #endif
3548 rpp_replace_at(relem++, lsv);
3549 #ifdef PERL_RC_STACK
3550 if (relem == lelem + 1) {
3551 lelem++;
3552 /* skip the NULLing of the slot */
3553 continue;
3554 }
3555 #endif
3556 }
3557 break;
3558 } /* switch */
3559 #ifdef PERL_RC_STACK
3560 *lelem = NULL;
3561 SvREFCNT_dec_NN(lsv);
3562 #endif
3563 lelem++;
3564 } /* while */
3565
3566 TAINT_NOT; /* result of list assign isn't tainted */
3567
3568 if (UNLIKELY(PL_delaymagic & ~DM_DELAY))
3569 /* update system UIDs and/or GIDs */
3570 S_aassign_uid(aTHX);
3571 PL_delaymagic = old_delaymagic;
3572
3573 #ifdef PERL_RC_STACK
3574 /* On ref-counted builds, the code above should have stored
3575 * NULL in each lelem field and already freed each lelem. Thus
3576 * the popfree_to() can start at a lower point.
3577 * Under some circumstances, &PL_sv_undef might be stored rather than
3578 * NULL, but this also doesn't need its refcount decrementing.
3579 * Assert that this is true.
3580 * Note that duplicate hash keys in list context can cause
3581 * lastrelem and relem to be lower than at the start;
3582 * while an odd number of hash elements can cause lastrelem to
3583 * have a value one higher than at the start */
3584 # ifdef DEBUGGING
3585 for (SV **svp = first_discard; svp <= PL_stack_sp; svp++)
3586 assert(!*svp || SvIMMORTAL(*svp));
3587 # endif
3588 PL_stack_sp = first_discard - 1;
3589
3590 /* now pop all the R elements too */
3591 rpp_popfree_to_NN((is_list ? relem : firstrelem) - 1);
3592
3593 #else
3594 /* pop all L and R elements apart from any being returned */
3595 rpp_popfree_to_NN((is_list ? relem : firstrelem) - 1);
3596 #endif
3597
3598 if (gimme == G_SCALAR) {
3599 rpp_extend(1);
3600 SV *sv;
3601 if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
3602 rpp_push_IMM((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
3603 else {
3604 dTARGET;
3605 TARGi(firstlelem - firstrelem, 1);
3606 sv = targ;
3607 rpp_push_1(sv);
3608 }
3609 }
3610
3611 return NORMAL;
3612 }
3613
3614
PP(pp_qr)3615 PP(pp_qr)
3616 {
3617 PMOP * const pm = cPMOP;
3618 REGEXP * rx = PM_GETRE(pm);
3619 regexp *prog = ReANY(rx);
3620 SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
3621 SV * const rv = newSV_type_mortal(SVt_IV);
3622 CV **cvp;
3623 CV *cv;
3624
3625 SvUPGRADE(rv, SVt_IV);
3626 /* For a subroutine describing itself as "This is a hacky workaround" I'm
3627 loathe to use it here, but it seems to be the right fix. Or close.
3628 The key part appears to be that it's essential for pp_qr to return a new
3629 object (SV), which implies that there needs to be an effective way to
3630 generate a new SV from the existing SV that is pre-compiled in the
3631 optree. */
3632 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
3633 SvROK_on(rv);
3634
3635 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
3636 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
3637 *cvp = cv_clone(cv);
3638 SvREFCNT_dec_NN(cv);
3639 }
3640
3641 if (pkg) {
3642 HV *const stash = gv_stashsv(pkg, GV_ADD);
3643 SvREFCNT_dec_NN(pkg);
3644 (void)sv_bless(rv, stash);
3645 }
3646
3647 if (UNLIKELY(RXp_ISTAINTED(prog))) {
3648 SvTAINTED_on(rv);
3649 SvTAINTED_on(SvRV(rv));
3650 }
3651 rpp_xpush_1(rv);
3652 return NORMAL;
3653 }
3654
3655 STATIC bool
S_are_we_in_Debug_EXECUTE_r(pTHX)3656 S_are_we_in_Debug_EXECUTE_r(pTHX)
3657 {
3658 /* Given a 'use re' is in effect, does it ask for outputting execution
3659 * debug info?
3660 *
3661 * This is separated from the sole place it's called, an inline function,
3662 * because it is the large-ish slow portion of the function */
3663
3664 DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX;
3665
3666 return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK));
3667 }
3668
3669 PERL_STATIC_INLINE bool
S_should_we_output_Debug_r(pTHX_ regexp * prog)3670 S_should_we_output_Debug_r(pTHX_ regexp *prog)
3671 {
3672 PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R;
3673
3674 /* pp_match can output regex debugging info. This function returns a
3675 * boolean as to whether or not it should.
3676 *
3677 * Under -Dr, it should. Any reasonable compiler will optimize this bit of
3678 * code away on non-debugging builds. */
3679 if (UNLIKELY(DEBUG_r_TEST)) {
3680 return TRUE;
3681 }
3682
3683 /* If the regex engine is using the non-debugging execution routine, then
3684 * no debugging should be output. Same if the field is NULL that pluggable
3685 * engines are not supposed to fill. */
3686 if ( LIKELY(prog->engine->exec == &Perl_regexec_flags)
3687 || UNLIKELY(prog->engine->op_comp == NULL))
3688 {
3689 return FALSE;
3690 }
3691
3692 /* Otherwise have to check */
3693 return S_are_we_in_Debug_EXECUTE_r(aTHX);
3694 }
3695
3696
PP(pp_match)3697 PP(pp_match)
3698 {
3699 SV *targ;
3700 PMOP *pm = cPMOP;
3701 PMOP *dynpm = pm;
3702 const char *s;
3703 const char *strend;
3704 SSize_t curpos = 0; /* initial pos() or current $+[0] */
3705 I32 global;
3706 U8 r_flags = 0;
3707 const char *truebase; /* Start of string */
3708 REGEXP *rx = PM_GETRE(pm);
3709 regexp *prog = ReANY(rx);
3710 bool rxtainted;
3711 const U8 gimme = GIMME_V;
3712 STRLEN len;
3713 const I32 oldsave = PL_savestack_ix;
3714 I32 had_zerolen = 0;
3715 MAGIC *mg = NULL;
3716 SSize_t sp_base;
3717
3718 if (PL_op->op_flags & OPf_STACKED) {
3719 targ = PL_stack_sp[0];
3720 /* We have to keep targ alive on the stack. At the end we have to
3721 * free it and shuffle down all the return values by one.
3722 * Remember the position.
3723 */
3724 sp_base = PL_stack_sp - PL_stack_base;
3725 assert(sp_base > 0);
3726 }
3727 else {
3728 sp_base = 0;
3729 if (PL_op->op_targ)
3730 targ = PAD_SV(PL_op->op_targ);
3731 else {
3732 targ = DEFSV;
3733 }
3734 rpp_extend(1);
3735 }
3736
3737 /* Skip get-magic if this is a qr// clone, because regcomp has
3738 already done it. */
3739 truebase = prog->mother_re
3740 ? SvPV_nomg_const(TARG, len)
3741 : SvPV_const(TARG, len);
3742 if (!truebase)
3743 DIE(aTHX_ "panic: pp_match");
3744 strend = truebase + len;
3745 rxtainted = (RXp_ISTAINTED(prog) ||
3746 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
3747 TAINT_NOT;
3748
3749 /* We need to know this in case we fail out early - pos() must be reset */
3750 global = dynpm->op_pmflags & PMf_GLOBAL;
3751
3752 /* PMdf_USED is set after a ?? matches once */
3753 if (
3754 #ifdef USE_ITHREADS
3755 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
3756 #else
3757 pm->op_pmflags & PMf_USED
3758 #endif
3759 ) {
3760 if (UNLIKELY(should_we_output_Debug_r(prog))) {
3761 PerlIO_printf(Perl_debug_log, "?? already matched once");
3762 }
3763 goto nope;
3764 }
3765
3766 /* handle the empty pattern */
3767 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
3768 if (PL_curpm == PL_reg_curpm) {
3769 if (PL_curpm_under) {
3770 if (PL_curpm_under == PL_reg_curpm) {
3771 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3772 } else {
3773 pm = PL_curpm_under;
3774 }
3775 }
3776 } else {
3777 pm = PL_curpm;
3778 }
3779 rx = PM_GETRE(pm);
3780 prog = ReANY(rx);
3781 }
3782
3783 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
3784 if (UNLIKELY(should_we_output_Debug_r(prog))) {
3785 PerlIO_printf(Perl_debug_log,
3786 "String shorter than min possible regex match (%zd < %zd)\n",
3787 len, RXp_MINLEN(prog));
3788 }
3789 goto nope;
3790 }
3791
3792 /* get pos() if //g */
3793 if (global) {
3794 mg = mg_find_mglob(TARG);
3795 if (mg && mg->mg_len >= 0) {
3796 curpos = MgBYTEPOS(mg, TARG, truebase, len);
3797 /* last time pos() was set, it was zero-length match */
3798 if (mg->mg_flags & MGf_MINMATCH)
3799 had_zerolen = 1;
3800 }
3801 }
3802
3803 #ifdef PERL_SAWAMPERSAND
3804 if ( RXp_NPARENS(prog)
3805 || PL_sawampersand
3806 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3807 || (dynpm->op_pmflags & PMf_KEEPCOPY)
3808 )
3809 #endif
3810 {
3811 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
3812 /* In @a = /(.)/g, we iterate multiple times, but copy the buffer
3813 * only on the first iteration. Therefore we need to copy $' as well
3814 * as $&, to make the rest of the string available for captures in
3815 * subsequent iterations */
3816 if (! (global && gimme == G_LIST))
3817 r_flags |= REXEC_COPY_SKIP_POST;
3818 };
3819 #ifdef PERL_SAWAMPERSAND
3820 if (dynpm->op_pmflags & PMf_KEEPCOPY)
3821 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3822 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3823 #endif
3824
3825 s = truebase;
3826
3827 play_it_again:
3828 if (global)
3829 s = truebase + curpos;
3830
3831 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
3832 had_zerolen, TARG, NULL, r_flags))
3833 goto nope;
3834
3835 PL_curpm = pm;
3836 if (dynpm->op_pmflags & PMf_ONCE)
3837 #ifdef USE_ITHREADS
3838 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
3839 #else
3840 dynpm->op_pmflags |= PMf_USED;
3841 #endif
3842
3843 if (rxtainted)
3844 RXp_MATCH_TAINTED_on(prog);
3845 TAINT_IF(RXp_MATCH_TAINTED(prog));
3846
3847 /* update pos */
3848
3849 if (global && (gimme != G_LIST || (dynpm->op_pmflags & PMf_CONTINUE))) {
3850 if (!mg)
3851 mg = sv_magicext_mglob(TARG);
3852 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS_END(prog,0));
3853 if (RXp_ZERO_LEN(prog))
3854 mg->mg_flags |= MGf_MINMATCH;
3855 else
3856 mg->mg_flags &= ~MGf_MINMATCH;
3857 }
3858
3859 if ((!RXp_NPARENS(prog) && !global) || gimme != G_LIST) {
3860 LEAVE_SCOPE(oldsave);
3861 if (sp_base)
3862 rpp_popfree_1(); /* free arg */
3863 rpp_push_IMM(&PL_sv_yes);
3864 return NORMAL;
3865 }
3866
3867 /* push captures on stack */
3868
3869 {
3870 const I32 logical_nparens = RXp_LOGICAL_NPARENS(prog);
3871 /* This following statement is *devious* code. If we are in a global
3872 match and the pattern has no parens in it, we should return $&
3873 (offset pair 0). So we set logical_paren to 1 when we should return
3874 $&, otherwise we set it to 0.
3875
3876 This allows us to simply add logical_nparens to logical_paren to
3877 compute the number of elements we are going to return.
3878
3879 In the loop init we "not" it with: logical_paren = !logical_paren
3880 which results in it being 0 inside the loop when we want to return
3881 $&, and results in it being 1 when we want to return the parens.
3882 Thus we either loop over 1..logical_nparens, or just over 0.
3883
3884 This is an elegant way to do this code-wise, but is super devious
3885 and potentially confusing. When I first saw this logic I thought
3886 "WTF?". But it makes sense after you poke it a while.
3887
3888 Frankly I probably would have done it differently, but it works so
3889 I am leaving it. - Yves */
3890 I32 logical_paren = (global && !logical_nparens) ? 1 : 0;
3891 I32 *l2p = RXp_LOGICAL_TO_PARNO(prog);
3892 /* This is used to step through the physical parens associated
3893 with a given logical paren. */
3894 I32 *p2l_next = RXp_PARNO_TO_LOGICAL_NEXT(prog);
3895
3896 rpp_extend(logical_nparens + logical_paren); /* devious code ... */
3897 EXTEND_MORTAL(logical_nparens + logical_paren); /* ... see above */
3898
3899 /* Loop over the logical parens in the pattern. This may not
3900 correspond to the actual paren checked, as branch reset may
3901 mean that there is more than one paren "behind" the logical
3902 parens. Eg, in /(?|(a)|(b))/ there are two parens, but one
3903 logical paren. */
3904 for (logical_paren = !logical_paren;
3905 logical_paren <= logical_nparens;
3906 logical_paren++)
3907 {
3908 /* Now convert the logical_paren to the physical parens which
3909 are "behind" it. If branch reset was not used, then
3910 physical_paren and logical_paren are the same as each other
3911 and we will only perform one iteration of the loop. */
3912 I32 phys_paren = l2p ? l2p[logical_paren] : logical_paren;
3913 SSize_t offs_start, offs_end;
3914 /* We check the loop invariants below and break out of the loop
3915 explicitly if our checks fail, so we use while (1) here to
3916 avoid double testing a conditional. */
3917 while (1) {
3918 /* Check end offset first, as the start might be >=0 even
3919 though the end is -1, so testing the end first helps
3920 us avoid the start check. Really we should be able to
3921 get away with ONLY testing the end, but testing both
3922 doesn't hurt much and preserves sanity. */
3923 if (((offs_end = RXp_OFFS_END(prog, phys_paren)) != -1) &&
3924 ((offs_start = RXp_OFFS_START(prog, phys_paren)) != -1))
3925 {
3926 const SSize_t len = offs_end - offs_start;
3927 const char * const s = offs_start + truebase;
3928 if ( UNLIKELY( len < 0 || len > strend - s) ) {
3929 DIE(aTHX_ "panic: pp_match start/end pointers, paren=%" I32df ", "
3930 "start=%zd, end=%zd, s=%p, strend=%p, len=%zd",
3931 phys_paren, offs_start, offs_end, s, strend, len);
3932 }
3933 rpp_push_1(newSVpvn_flags(s, len,
3934 (DO_UTF8(TARG))
3935 ? SVf_UTF8|SVs_TEMP
3936 : SVs_TEMP)
3937 );
3938 break;
3939 } else if (!p2l_next || !(phys_paren = p2l_next[phys_paren])) {
3940 /* Either logical_paren and phys_paren are the same and
3941 we won't have a p2l_next, or they aren't the same (and
3942 we do have a p2l_next) but we have exhausted the list
3943 of physical parens associated with this logical paren.
3944 Either way we are done, and we can push undef and break
3945 out of the loop. */
3946 rpp_push_1(sv_newmortal());
3947 break;
3948 }
3949 }
3950 }
3951 if (global) {
3952 curpos = (UV)RXp_OFFS_END(prog,0);
3953 had_zerolen = RXp_ZERO_LEN(prog);
3954 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
3955 goto play_it_again;
3956 }
3957 LEAVE_SCOPE(oldsave);
3958 goto ret_list;
3959 }
3960 NOT_REACHED; /* NOTREACHED */
3961
3962 nope:
3963 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
3964 if (!mg)
3965 mg = mg_find_mglob(TARG);
3966 if (mg)
3967 mg->mg_len = -1;
3968 }
3969 LEAVE_SCOPE(oldsave);
3970 if (gimme != G_LIST) {
3971 if (sp_base)
3972 rpp_popfree_1(); /* free arg */
3973 rpp_push_IMM(&PL_sv_no);
3974 return NORMAL;
3975 }
3976
3977 ret_list:
3978 /* return when in list context (i.e. don't push YES/NO, but do return
3979 * a (possibly empty) list of matches */
3980 if (sp_base) {
3981 /* need to free the original argument and shift any results down
3982 * by one */
3983 SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base);
3984 #ifdef PERL_RC_STACK
3985 SV *old_sv = PL_stack_sp[-nitems];
3986 #endif
3987 if (nitems)
3988 Move(PL_stack_sp - nitems + 1,
3989 PL_stack_sp - nitems, nitems, SV*);
3990 PL_stack_sp--;
3991 #ifdef PERL_RC_STACK
3992 SvREFCNT_dec_NN(old_sv);
3993 #endif
3994 }
3995
3996 return NORMAL;
3997 }
3998
3999
4000 /* Perl_do_readline(): implement <$fh>, readline($fh) and glob('*.h')
4001 *
4002 * This function is tail-called by pp_readline(), pp_rcatline() and
4003 * pp_glob(), and it may check PL_op's op_type and op_flags as
4004 * appropriate.
4005 *
4006 * For file reading:
4007 * It reads the line(s) from PL_last_in_gv.
4008 * It returns a list of lines, or in scalar context, reads one line into
4009 * targ (or if OPf_STACKED, into the top SV on the stack), and
4010 * returns that. (If OP_RCATLINE, concats rather than sets).
4011 *
4012 * So it normally expects zero args, or one arg when the OPf_STACKED
4013 * optimisation is present.
4014 *
4015 * For file globbing:
4016 * Note that we don't normally reach here: we only get here if perl is
4017 * built with PERL_EXTERNAL_GLOB, which is normally only when
4018 * building miniperl.
4019 *
4020 * Expects one arg, which is the pattern string (e.g. '*.h').
4021 * The caller sets PL_last_in_gv to a plain GV that just has a new
4022 * IO::File PVIO attached. That PVIO is used to attach a pipe file
4023 * handle to when an external glob is being run in scalar context,
4024 * so the pipe is available on subsequent iterations.
4025 *
4026 * Handles tied IO magic, but not overloading - that's the caller's
4027 * responsibility.
4028 *
4029 * Handles the *ARGV filehandle specially, to do all the <> wizardry.
4030 *
4031 * In summary: on entry, the stack has zero or one items pushed, and
4032 * looks like:
4033 *
4034 * - when OP_READLINE without OPf_STACKED
4035 * target when OP_READLINE with OPf_STACKED, or when OP_RCATLINE
4036 * '*.h' when OP_GLOB
4037 */
4038
4039 OP *
Perl_do_readline(pTHX)4040 Perl_do_readline(pTHX)
4041 {
4042
4043 const I32 type = PL_op->op_type;
4044
4045 /* only readline/rcatline can have the STACKED optimisation,
4046 * and rcatline *always* has it */
4047 if (PL_op->op_flags & OPf_STACKED) {
4048 assert(type != OP_GLOB);
4049 assert(GIMME_V == G_SCALAR);
4050 }
4051 if (type == OP_RCATLINE)
4052 assert(PL_op->op_flags & OPf_STACKED);
4053
4054 const U8 gimme = GIMME_V;
4055 SV *targ = (gimme == G_SCALAR)
4056 ? (PL_op->op_flags & OPf_STACKED)
4057 ? *PL_stack_sp
4058 : PAD_SV(PL_op->op_targ)
4059 : NULL;
4060 SV *sv;
4061 STRLEN tmplen = 0;
4062 STRLEN offset;
4063 PerlIO *fp;
4064 IO * const io = GvIO(PL_last_in_gv);
4065
4066 /* process tied file handle if present */
4067
4068 if (io) {
4069 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
4070 if (mg) {
4071 /* not possible for the faked-up IO passed by an OP_GLOB to be
4072 * tied */
4073 assert(type != OP_GLOB);
4074 /* OPf_STACKED only applies when in scalar context */
4075 assert(!(gimme != G_SCALAR && (PL_op->op_flags & OPf_STACKED)));
4076
4077 /* tied_method() frees everything currently above the passed
4078 * mark, and returns any values at mark[1] onwards */
4079 Perl_tied_method(aTHX_ SV_CONST(READLINE),
4080 /* mark => */ PL_stack_sp,
4081 MUTABLE_SV(io), mg, gimme, 0);
4082
4083 if (gimme == G_SCALAR) {
4084 SvSetSV_nosteal(targ, *PL_stack_sp);
4085 SvSETMAGIC(targ);
4086 if (PL_op->op_flags & OPf_STACKED) {
4087 /* free the tied method call's return value */
4088 rpp_popfree_1();
4089 assert(*PL_stack_sp == targ);
4090 }
4091 else
4092 rpp_replace_1_1(targ);
4093 }
4094 else
4095 /* no targ to pop off the stack - any returned values
4096 * are in the right place in the stack */
4097 assert(!(PL_op->op_flags & OPf_STACKED));
4098
4099 return NORMAL;
4100 }
4101 }
4102
4103 fp = NULL;
4104
4105 /* handle possible *ARGV, and check for read on write-only FH */
4106
4107 if (io) {
4108 fp = IoIFP(io);
4109 if (fp) {
4110 if (IoTYPE(io) == IoTYPE_WRONLY)
4111 report_wrongway_fh(PL_last_in_gv, '>');
4112 }
4113 else {
4114 if (IoFLAGS(io) & IOf_ARGV) {
4115 if (IoFLAGS(io) & IOf_START) {
4116 IoLINES(io) = 0;
4117 if (av_count(GvAVn(PL_last_in_gv)) == 0) {
4118 IoFLAGS(io) &= ~IOf_START;
4119 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
4120 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
4121 sv_setpvs(GvSVn(PL_last_in_gv), "-");
4122 SvSETMAGIC(GvSV(PL_last_in_gv));
4123 fp = IoIFP(io);
4124 goto have_fp;
4125 }
4126 }
4127 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
4128 if (!fp) { /* Note: fp != IoIFP(io) */
4129 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
4130 }
4131 }
4132 else if (type == OP_GLOB) {
4133 fp = Perl_start_glob(aTHX_ *PL_stack_sp, io);
4134 rpp_popfree_1_NN();
4135 }
4136 }
4137 }
4138
4139 /* handle bad file handle */
4140
4141 if (!fp) {
4142 if ((!io || !(IoFLAGS(io) & IOf_START))
4143 && ckWARN(WARN_CLOSED)
4144 && type != OP_GLOB)
4145 {
4146 report_evil_fh(PL_last_in_gv);
4147 }
4148
4149 if (gimme == G_SCALAR) {
4150 /* undef targ, and return that undefined value */
4151 if (type != OP_RCATLINE)
4152 sv_set_undef(targ);
4153 if (!(PL_op->op_flags & OPf_STACKED))
4154 rpp_push_1(targ);
4155 }
4156 return NORMAL;
4157 }
4158
4159 have_fp:
4160
4161 /* prepare targ to have a string assigned to it */
4162
4163 if (gimme == G_SCALAR) {
4164 sv = targ;
4165 if (type == OP_RCATLINE && SvGMAGICAL(sv))
4166 mg_get(sv);
4167
4168 if (SvROK(sv)) {
4169 if (type == OP_RCATLINE)
4170 SvPV_force_nomg_nolen(sv);
4171 else
4172 sv_unref(sv);
4173 }
4174 else if (isGV_with_GP(sv)) {
4175 SvPV_force_nomg_nolen(sv);
4176 }
4177
4178 SvUPGRADE(sv, SVt_PV);
4179 tmplen = SvLEN(sv); /* remember if already alloced */
4180 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
4181 /* try short-buffering it. Please update t/op/readline.t
4182 * if you change the growth length.
4183 */
4184 Sv_Grow(sv, 80);
4185 }
4186
4187 offset = 0;
4188 if (type == OP_RCATLINE && SvOK(sv)) {
4189 if (!SvPOK(sv)) {
4190 SvPV_force_nomg_nolen(sv);
4191 }
4192 offset = SvCUR(sv);
4193 }
4194 }
4195 else {
4196 /* XXX on RC builds, push on stack rather than mortalize ? */
4197 sv = sv_2mortal(newSV(80));
4198 offset = 0;
4199 }
4200
4201 /* This should not be marked tainted if the fp is marked clean */
4202 #define MAYBE_TAINT_LINE(io, sv) \
4203 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
4204 TAINT; \
4205 SvTAINTED_on(sv); \
4206 }
4207
4208 /* delay EOF state for a snarfed empty file */
4209 #define SNARF_EOF(gimme,rs,io,sv) \
4210 (gimme != G_SCALAR || SvCUR(sv) \
4211 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
4212
4213 /* create one or more lines, or (if OP_GLOB), pathnames */
4214
4215 for (;;) {
4216 if (!sv_gets(sv, fp, offset)
4217 && (type == OP_GLOB
4218 || SNARF_EOF(gimme, PL_rs, io, sv)
4219 || PerlIO_error(fp)))
4220 {
4221 if (IoFLAGS(io) & IOf_ARGV) {
4222 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
4223 if (fp) {
4224 continue;
4225 }
4226 (void)do_close(PL_last_in_gv, FALSE);
4227 }
4228 else if (type == OP_GLOB) {
4229 /* clear any errors here so we only fail on the pclose()
4230 failing, which should only happen on the child
4231 failing
4232 */
4233 PerlIO_clearerr(fp);
4234 if (!do_close(PL_last_in_gv, FALSE)) {
4235 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
4236 "glob failed (child exited with status %d%s)",
4237 (int)(STATUS_CURRENT >> 8),
4238 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4239 }
4240 }
4241
4242 if (gimme == G_SCALAR) {
4243 if (type != OP_RCATLINE) {
4244 SV_CHECK_THINKFIRST_COW_DROP(targ);
4245 SvOK_off(targ);
4246 }
4247 /* targ not already there? */
4248 if (!(PL_op->op_flags & OPf_STACKED))
4249 rpp_push_1(targ);
4250 }
4251 else if (PL_op->op_flags & OPf_STACKED)
4252 rpp_popfree_1_NN();
4253
4254 MAYBE_TAINT_LINE(io, sv);
4255 return NORMAL;
4256 }
4257
4258 MAYBE_TAINT_LINE(io, sv);
4259 IoLINES(io)++;
4260 IoFLAGS(io) |= IOf_NOLINE;
4261 SvSETMAGIC(sv);
4262 rpp_extend(1);
4263 if (PL_op->op_flags & OPf_STACKED) {
4264 /* push sv while keeping targ above it, so targ doesn't get
4265 * freed */
4266 assert(*PL_stack_sp == targ);
4267 PL_stack_sp[1] = targ;
4268 *PL_stack_sp++ = NULL;
4269 rpp_replace_at(PL_stack_sp - 1, sv);
4270 }
4271 else
4272 rpp_push_1(sv);
4273
4274 if (type == OP_GLOB) {
4275 const char *t1;
4276 Stat_t statbuf;
4277
4278 /* chomp(sv) */
4279 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
4280 char * const tmps = SvEND(sv) - 1;
4281 if (*tmps == *SvPVX_const(PL_rs)) {
4282 *tmps = '\0';
4283 SvCUR_set(sv, SvCUR(sv) - 1);
4284 }
4285 }
4286
4287 /* find longest substring of sv up to first metachar */
4288 for (t1 = SvPVX_const(sv); *t1; t1++) {
4289 #ifdef __VMS
4290 if (memCHRs("*%?", *t1))
4291 #else
4292 if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1))
4293 #endif
4294 break;
4295 }
4296
4297 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
4298 /* Unmatched wildcard? Chuck it... */
4299 /* no need to worry about targ still on top of stack */
4300 assert(!(PL_op->op_flags & OPf_STACKED));
4301 rpp_popfree_1();
4302 continue;
4303 }
4304 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
4305 /* check line if valid Unicode */
4306 if (ckWARN(WARN_UTF8)) {
4307 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
4308 const STRLEN len = SvCUR(sv) - offset;
4309 const U8 *f;
4310
4311 if (!is_utf8_string_loc(s, len, &f))
4312 /* Emulate :encoding(utf8) warning in the same case. */
4313 Perl_warner(aTHX_ packWARN(WARN_UTF8),
4314 "utf8 \"\\x%02X\" does not map to Unicode",
4315 f < (U8*)SvEND(sv) ? *f : 0);
4316 }
4317 }
4318
4319 if (gimme == G_LIST) {
4320 if (SvLEN(sv) - SvCUR(sv) > 20) {
4321 SvPV_shrink_to_cur(sv);
4322 }
4323 /* XXX on RC builds, push on stack rather than mortalize ? */
4324 sv = sv_2mortal(newSV(80));
4325 continue;
4326 }
4327
4328 if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
4329 /* try to reclaim a bit of scalar space (only on 1st alloc) */
4330 const STRLEN new_len
4331 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
4332 SvPV_renew(sv, new_len);
4333 }
4334
4335
4336 if (PL_op->op_flags & OPf_STACKED)
4337 rpp_popfree_1_NN(); /* finally remove targ */
4338 /* return sv, which was recently pushed onto the stack */
4339 return NORMAL;
4340 } /* for (;;) */
4341 }
4342
4343
PP(pp_helem)4344 PP(pp_helem)
4345 {
4346 HE* he;
4347 SV **svp;
4348 SV * const keysv = PL_stack_sp[0];
4349 HV * const hv = MUTABLE_HV(PL_stack_sp[-1]);
4350 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
4351 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4352 SV *sv;
4353 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4354 bool preeminent = TRUE;
4355 SV *retsv;
4356
4357 if (SvTYPE(hv) != SVt_PVHV) {
4358 retsv = &PL_sv_undef;
4359 goto ret;
4360 }
4361
4362 if (localizing) {
4363 MAGIC *mg;
4364 HV *stash;
4365
4366 /* Try to preserve the existence of a tied hash
4367 * element by using EXISTS and DELETE if possible.
4368 * Fall back to FETCH and STORE otherwise. */
4369 if (SvCANEXISTDELETE(hv))
4370 preeminent = hv_exists_ent(hv, keysv, 0);
4371 }
4372
4373 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
4374 svp = he ? &HeVAL(he) : NULL;
4375 if (lval) {
4376 if (!svp || !*svp || *svp == &PL_sv_undef) {
4377 SV* lv;
4378 SV* key2;
4379 if (!defer) {
4380 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4381 }
4382 lv = newSV_type_mortal(SVt_PVLV);
4383 LvTYPE(lv) = 'y';
4384 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
4385 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
4386 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
4387 LvTARGLEN(lv) = 1;
4388 retsv = lv;
4389 goto ret;
4390 }
4391
4392 if (localizing) {
4393 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
4394 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4395 else if (preeminent)
4396 save_helem_flags(hv, keysv, svp,
4397 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4398 else
4399 SAVEHDELETE(hv, keysv);
4400 }
4401 else if (PL_op->op_private & OPpDEREF) {
4402 retsv = vivify_ref(*svp, PL_op->op_private & OPpDEREF);
4403 goto ret;;
4404 }
4405 }
4406 sv = (svp && *svp ? *svp : &PL_sv_undef);
4407 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
4408 * was to make C<local $tied{foo} = $tied{foo}> possible.
4409 * However, it seems no longer to be needed for that purpose, and
4410 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
4411 * would loop endlessly since the pos magic is getting set on the
4412 * mortal copy and lost. However, the copy has the effect of
4413 * triggering the get magic, and losing it altogether made things like
4414 * c<$tied{foo};> in void context no longer do get magic, which some
4415 * code relied on. Also, delayed triggering of magic on @+ and friends
4416 * meant the original regex may be out of scope by now. So as a
4417 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
4418 * being called too many times). */
4419 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
4420 mg_get(sv);
4421 retsv = sv;
4422
4423 ret:
4424 rpp_replace_2_1_NN(retsv);
4425 return NORMAL;
4426 }
4427
4428
4429 /* a stripped-down version of Perl_softref2xv() for use by
4430 * pp_multideref(), which doesn't use PL_op->op_flags */
4431
4432 STATIC GV *
S_softref2xv_lite(pTHX_ SV * const sv,const char * const what,const svtype type)4433 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
4434 const svtype type)
4435 {
4436 if (PL_op->op_private & HINT_STRICT_REFS) {
4437 if (SvOK(sv))
4438 Perl_die(aTHX_ PL_no_symref_sv, sv,
4439 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
4440 else
4441 Perl_die(aTHX_ PL_no_usym, what);
4442 }
4443 if (!SvOK(sv))
4444 Perl_die(aTHX_ PL_no_usym, what);
4445 return gv_fetchsv_nomg(sv, GV_ADD, type);
4446 }
4447
4448
4449 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
4450 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
4451 *
4452 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
4453 * Each of these either contains a set of actions, or an argument, such as
4454 * an IV to use as an array index, or a lexical var to retrieve.
4455 * Several actions are stored per UV; we keep shifting new actions off the
4456 * one UV, and only reload when it becomes zero.
4457 */
4458
PP(pp_multideref)4459 PP(pp_multideref)
4460 {
4461 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
4462 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
4463 UV actions = items->uv;
4464
4465 assert(actions);
4466 /* this tells find_uninit_var() where we're up to */
4467 PL_multideref_pc = items;
4468 bool replace = FALSE;
4469
4470 while (1) {
4471 /* there are three main classes of action; the first retrieves
4472 * the initial AV or HV from a variable or the stack; the second
4473 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
4474 * the third an unrolled (/DREFHV, rv2hv, helem).
4475 */
4476 switch (actions & MDEREF_ACTION_MASK) {
4477
4478 case MDEREF_reload:
4479 actions = (++items)->uv;
4480 continue;
4481
4482 case MDEREF_AV_padav_aelem: /* $lex[...] */
4483 sv = PAD_SVl((++items)->pad_offset);
4484 goto do_AV_aelem;
4485
4486 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
4487 sv = UNOP_AUX_item_sv(++items);
4488 assert(isGV_with_GP(sv));
4489 sv = (SV*)GvAVn((GV*)sv);
4490 goto do_AV_aelem;
4491
4492 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
4493 {
4494 sv = *PL_stack_sp;
4495 replace = TRUE;
4496 goto do_AV_rv2av_aelem;
4497 }
4498
4499 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
4500 sv = UNOP_AUX_item_sv(++items);
4501 assert(isGV_with_GP(sv));
4502 sv = GvSVn((GV*)sv);
4503 goto do_AV_vivify_rv2av_aelem;
4504
4505 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
4506 sv = PAD_SVl((++items)->pad_offset);
4507 /* FALLTHROUGH */
4508
4509 do_AV_vivify_rv2av_aelem:
4510 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
4511 /* this is the OPpDEREF action normally found at the end of
4512 * ops like aelem, helem, rv2sv */
4513 sv = vivify_ref(sv, OPpDEREF_AV);
4514 /* FALLTHROUGH */
4515
4516 do_AV_rv2av_aelem:
4517 /* this is basically a copy of pp_rv2av when it just has the
4518 * sKR/1 flags */
4519 SvGETMAGIC(sv);
4520 if (LIKELY(SvROK(sv))) {
4521 if (UNLIKELY(SvAMAGIC(sv))) {
4522 sv = amagic_deref_call(sv, to_av_amg);
4523 }
4524 sv = SvRV(sv);
4525 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
4526 DIE(aTHX_ "Not an ARRAY reference");
4527 }
4528 else if (SvTYPE(sv) != SVt_PVAV) {
4529 if (!isGV_with_GP(sv))
4530 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
4531 sv = MUTABLE_SV(GvAVn((GV*)sv));
4532 }
4533 /* FALLTHROUGH */
4534
4535 do_AV_aelem:
4536 {
4537 /* retrieve the key; this may be either a lexical or package
4538 * var (whose index/ptr is stored as an item) or a signed
4539 * integer constant stored as an item.
4540 */
4541 SV *elemsv;
4542 IV elem = 0; /* to shut up stupid compiler warnings */
4543
4544
4545 assert(SvTYPE(sv) == SVt_PVAV);
4546
4547 switch (actions & MDEREF_INDEX_MASK) {
4548 case MDEREF_INDEX_none:
4549 goto finish;
4550 case MDEREF_INDEX_const:
4551 elem = (++items)->iv;
4552 break;
4553 case MDEREF_INDEX_padsv:
4554 elemsv = PAD_SVl((++items)->pad_offset);
4555 goto check_elem;
4556 case MDEREF_INDEX_gvsv:
4557 elemsv = UNOP_AUX_item_sv(++items);
4558 assert(isGV_with_GP(elemsv));
4559 elemsv = GvSVn((GV*)elemsv);
4560 check_elem:
4561 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
4562 && ckWARN(WARN_MISC)))
4563 Perl_warner(aTHX_ packWARN(WARN_MISC),
4564 "Use of reference \"%" SVf "\" as array index",
4565 SVfARG(elemsv));
4566 /* the only time that S_find_uninit_var() needs this
4567 * is to determine which index value triggered the
4568 * undef warning. So just update it here. Note that
4569 * since we don't save and restore this var (e.g. for
4570 * tie or overload execution), its value will be
4571 * meaningless apart from just here */
4572 PL_multideref_pc = items;
4573 elem = SvIV(elemsv);
4574 break;
4575 }
4576
4577
4578 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
4579
4580 if (!(actions & MDEREF_FLAG_last)) {
4581 SV** svp = av_fetch((AV*)sv, elem, 1);
4582 if (!svp || ! (sv=*svp))
4583 DIE(aTHX_ PL_no_aelem, elem);
4584 break;
4585 }
4586
4587 if (PL_op->op_private &
4588 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
4589 {
4590 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
4591 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
4592 }
4593 else {
4594 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
4595 sv = av_delete((AV*)sv, elem, discard);
4596 if (discard)
4597 return NORMAL;
4598 if (!sv)
4599 sv = &PL_sv_undef;
4600 }
4601 }
4602 else {
4603 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
4604 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4605 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4606 bool preeminent = TRUE;
4607 AV *const av = (AV*)sv;
4608 SV** svp;
4609
4610 if (UNLIKELY(localizing)) {
4611 MAGIC *mg;
4612 HV *stash;
4613
4614 /* Try to preserve the existence of a tied array
4615 * element by using EXISTS and DELETE if possible.
4616 * Fall back to FETCH and STORE otherwise. */
4617 if (SvCANEXISTDELETE(av))
4618 preeminent = av_exists(av, elem);
4619 }
4620
4621 svp = av_fetch(av, elem, lval && !defer);
4622
4623 if (lval) {
4624 if (!svp || !(sv = *svp)) {
4625 IV len;
4626 if (!defer)
4627 DIE(aTHX_ PL_no_aelem, elem);
4628 len = av_top_index(av);
4629 /* Resolve a negative index that falls within
4630 * the array. Leave it negative it if falls
4631 * outside the array. */
4632 if (elem < 0 && len + elem >= 0)
4633 elem = len + elem;
4634 if (elem >= 0 && elem <= len)
4635 /* Falls within the array. */
4636 sv = av_nonelem(av,elem);
4637 else
4638 /* Falls outside the array. If it is neg-
4639 ative, magic_setdefelem will use the
4640 index for error reporting. */
4641 sv = sv_2mortal(newSVavdefelem(av,elem,1));
4642 }
4643 else {
4644 if (UNLIKELY(localizing)) {
4645 if (preeminent) {
4646 save_aelem(av, elem, svp);
4647 sv = *svp; /* may have changed */
4648 }
4649 else
4650 SAVEADELETE(av, elem);
4651 }
4652 }
4653 }
4654 else {
4655 sv = (svp ? *svp : &PL_sv_undef);
4656 /* see note in pp_helem() */
4657 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
4658 mg_get(sv);
4659 }
4660 }
4661
4662 }
4663 finish:
4664 {
4665 if (replace)
4666 rpp_replace_1_1_NN(sv);
4667 else
4668 rpp_xpush_1(sv);
4669 return NORMAL;
4670 }
4671 /* NOTREACHED */
4672
4673
4674
4675
4676 case MDEREF_HV_padhv_helem: /* $lex{...} */
4677 sv = PAD_SVl((++items)->pad_offset);
4678 goto do_HV_helem;
4679
4680 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
4681 sv = UNOP_AUX_item_sv(++items);
4682 assert(isGV_with_GP(sv));
4683 sv = (SV*)GvHVn((GV*)sv);
4684 goto do_HV_helem;
4685
4686 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
4687 {
4688 sv = *PL_stack_sp;
4689 replace = TRUE;
4690 goto do_HV_rv2hv_helem;
4691 }
4692
4693 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
4694 sv = UNOP_AUX_item_sv(++items);
4695 assert(isGV_with_GP(sv));
4696 sv = GvSVn((GV*)sv);
4697 goto do_HV_vivify_rv2hv_helem;
4698
4699 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
4700 sv = PAD_SVl((++items)->pad_offset);
4701 /* FALLTHROUGH */
4702
4703 do_HV_vivify_rv2hv_helem:
4704 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
4705 /* this is the OPpDEREF action normally found at the end of
4706 * ops like aelem, helem, rv2sv */
4707 sv = vivify_ref(sv, OPpDEREF_HV);
4708 /* FALLTHROUGH */
4709
4710 do_HV_rv2hv_helem:
4711 /* this is basically a copy of pp_rv2hv when it just has the
4712 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
4713
4714 SvGETMAGIC(sv);
4715 if (LIKELY(SvROK(sv))) {
4716 if (UNLIKELY(SvAMAGIC(sv))) {
4717 sv = amagic_deref_call(sv, to_hv_amg);
4718 }
4719 sv = SvRV(sv);
4720 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
4721 DIE(aTHX_ "Not a HASH reference");
4722 }
4723 else if (SvTYPE(sv) != SVt_PVHV) {
4724 if (!isGV_with_GP(sv))
4725 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
4726 sv = MUTABLE_SV(GvHVn((GV*)sv));
4727 }
4728 /* FALLTHROUGH */
4729
4730 do_HV_helem:
4731 {
4732 /* retrieve the key; this may be either a lexical / package
4733 * var or a string constant, whose index/ptr is stored as an
4734 * item
4735 */
4736 SV *keysv = NULL; /* to shut up stupid compiler warnings */
4737
4738 assert(SvTYPE(sv) == SVt_PVHV);
4739
4740 switch (actions & MDEREF_INDEX_MASK) {
4741 case MDEREF_INDEX_none:
4742 goto finish;
4743
4744 case MDEREF_INDEX_const:
4745 keysv = UNOP_AUX_item_sv(++items);
4746 break;
4747
4748 case MDEREF_INDEX_padsv:
4749 keysv = PAD_SVl((++items)->pad_offset);
4750 break;
4751
4752 case MDEREF_INDEX_gvsv:
4753 keysv = UNOP_AUX_item_sv(++items);
4754 keysv = GvSVn((GV*)keysv);
4755 break;
4756 }
4757
4758 /* see comment above about setting this var */
4759 PL_multideref_pc = items;
4760
4761
4762 /* ensure that candidate CONSTs have been HEKified */
4763 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
4764 || SvTYPE(keysv) >= SVt_PVMG
4765 || !SvOK(keysv)
4766 || SvROK(keysv)
4767 || SvIsCOW_shared_hash(keysv));
4768
4769 /* this is basically a copy of pp_helem with OPpDEREF skipped */
4770
4771 if (!(actions & MDEREF_FLAG_last)) {
4772 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
4773 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
4774 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4775 break;
4776 }
4777
4778 if (PL_op->op_private &
4779 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
4780 {
4781 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
4782 sv = hv_exists_ent((HV*)sv, keysv, 0)
4783 ? &PL_sv_yes : &PL_sv_no;
4784 }
4785 else {
4786 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
4787 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
4788 if (discard)
4789 return NORMAL;
4790 if (!sv)
4791 sv = &PL_sv_undef;
4792 }
4793 }
4794 else {
4795 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
4796 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4797 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4798 bool preeminent = TRUE;
4799 SV **svp;
4800 HV * const hv = (HV*)sv;
4801 HE* he;
4802
4803 if (UNLIKELY(localizing)) {
4804 MAGIC *mg;
4805 HV *stash;
4806
4807 /* Try to preserve the existence of a tied hash
4808 * element by using EXISTS and DELETE if possible.
4809 * Fall back to FETCH and STORE otherwise. */
4810 if (SvCANEXISTDELETE(hv))
4811 preeminent = hv_exists_ent(hv, keysv, 0);
4812 }
4813
4814 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
4815 svp = he ? &HeVAL(he) : NULL;
4816
4817
4818 if (lval) {
4819 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
4820 SV* lv;
4821 SV* key2;
4822 if (!defer)
4823 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4824 lv = newSV_type_mortal(SVt_PVLV);
4825 LvTYPE(lv) = 'y';
4826 sv_magic(lv, key2 = newSVsv(keysv),
4827 PERL_MAGIC_defelem, NULL, 0);
4828 /* sv_magic() increments refcount */
4829 SvREFCNT_dec_NN(key2);
4830 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
4831 LvTARGLEN(lv) = 1;
4832 sv = lv;
4833 }
4834 else {
4835 if (localizing) {
4836 if (HvNAME_get(hv) && isGV_or_RVCV(sv))
4837 save_gp(MUTABLE_GV(sv),
4838 !(PL_op->op_flags & OPf_SPECIAL));
4839 else if (preeminent) {
4840 save_helem_flags(hv, keysv, svp,
4841 (PL_op->op_flags & OPf_SPECIAL)
4842 ? 0 : SAVEf_SETMAGIC);
4843 sv = *svp; /* may have changed */
4844 }
4845 else
4846 SAVEHDELETE(hv, keysv);
4847 }
4848 }
4849 }
4850 else {
4851 sv = (svp && *svp ? *svp : &PL_sv_undef);
4852 /* see note in pp_helem() */
4853 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
4854 mg_get(sv);
4855 }
4856 }
4857 goto finish;
4858 }
4859
4860 } /* switch */
4861
4862 actions >>= MDEREF_SHIFT;
4863 } /* while */
4864 /* NOTREACHED */
4865 }
4866
4867
PP(pp_iter)4868 PP(pp_iter)
4869 {
4870 PERL_CONTEXT *cx = CX_CUR();
4871 SV **itersvp = CxITERVAR(cx);
4872 const U8 type = CxTYPE(cx);
4873
4874 /* Classic "for" syntax iterates one-at-a-time.
4875 Many-at-a-time for loops are only for lexicals declared as part of the
4876 for loop, and rely on all the lexicals being in adjacent pad slots.
4877
4878 Curiously, even if the iterator variable is a lexical, the pad offset is
4879 stored in the targ slot of the ENTERITER op, meaning that targ of this OP
4880 has always been zero. Hence we can use this op's targ to hold "how many"
4881 for many-at-a-time. We actually store C<how_many - 1>, so that for the
4882 case of one-at-a-time we have zero (as before), as this makes all the
4883 logic of the for loop below much simpler, with all the other
4884 one-at-a-time cases just falling out of this "naturally". */
4885 PADOFFSET how_many = PL_op->op_targ;
4886 PADOFFSET i = 0;
4887
4888 assert(itersvp);
4889
4890 for (; i <= how_many; ++i ) {
4891 SV *oldsv;
4892 SV *sv;
4893 AV *av;
4894 IV ix;
4895 IV inc;
4896
4897 switch (type) {
4898
4899 case CXt_LOOP_LAZYSV: /* string increment */
4900 {
4901 SV* cur = cx->blk_loop.state_u.lazysv.cur;
4902 SV *end = cx->blk_loop.state_u.lazysv.end;
4903 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
4904 It has SvPVX of "" and SvCUR of 0, which is what we want. */
4905 STRLEN maxlen = 0;
4906 const char *max = SvPV_const(end, maxlen);
4907 bool pad_it = FALSE;
4908 if (DO_UTF8(end) && IN_UNI_8_BIT)
4909 maxlen = sv_len_utf8_nomg(end);
4910 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen)) {
4911 if (LIKELY(!i)) {
4912 goto retno;
4913 }
4914 /* We are looping n-at-a-time and the range isn't a multiple
4915 of n, so we fill the rest of the lexicals with undef.
4916 This only happens on the last iteration of the loop, and
4917 we will have already set up the "terminate next time"
4918 condition earlier in this for loop for this call of the
4919 ITER op when we set up the lexical corresponding to the
4920 last value in the range. Hence we don't goto retno (yet),
4921 and just below we don't repeat the setup for "terminate
4922 next time". */
4923 pad_it = TRUE;
4924 }
4925
4926 oldsv = *itersvp;
4927 /* NB: on the first iteration, oldsv will have a ref count of at
4928 * least 2 (one extra from blk_loop.itersave), so the GV or pad
4929 * slot will get localised; on subsequent iterations the RC==1
4930 * optimisation may kick in and the SV will be reused. */
4931 if (UNLIKELY(pad_it)) {
4932 *itersvp = &PL_sv_undef;
4933 SvREFCNT_dec(oldsv);
4934 }
4935 else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
4936 /* safe to reuse old SV */
4937 sv_setsv(oldsv, cur);
4938 }
4939 else {
4940 /* we need a fresh SV every time so that loop body sees a
4941 * completely new SV for closures/references to work as
4942 * they used to */
4943 *itersvp = newSVsv(cur);
4944 SvREFCNT_dec(oldsv);
4945 }
4946
4947 if (UNLIKELY(pad_it)) {
4948 /* We're "beyond the end" of the iterator here, filling the
4949 extra lexicals with undef, so we mustn't do anything
4950 (further) to the iterator itself at this point.
4951 (Observe how the other two blocks modify the iterator's
4952 value) */
4953 }
4954 else if (strEQ(SvPVX_const(cur), max))
4955 sv_setiv(cur, 0); /* terminate next time */
4956 else
4957 sv_inc(cur);
4958 break;
4959 }
4960
4961 case CXt_LOOP_LAZYIV: /* integer increment */
4962 {
4963 IV cur = cx->blk_loop.state_u.lazyiv.cur;
4964 bool pad_it = FALSE;
4965 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end)) {
4966 if (LIKELY(!i)) {
4967 goto retno;
4968 }
4969 pad_it = TRUE;
4970 }
4971
4972 oldsv = *itersvp;
4973 /* see NB comment above */
4974 if (UNLIKELY(pad_it)) {
4975 *itersvp = &PL_sv_undef;
4976 SvREFCNT_dec(oldsv);
4977 }
4978 else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
4979 /* safe to reuse old SV */
4980
4981 if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
4982 == SVt_IV) {
4983 /* Cheap SvIOK_only().
4984 * Assert that flags which SvIOK_only() would test or
4985 * clear can't be set, because we're SVt_IV */
4986 assert(!(SvFLAGS(oldsv) &
4987 (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
4988 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
4989 /* SvIV_set() where sv_any points to head */
4990 oldsv->sv_u.svu_iv = cur;
4991
4992 }
4993 else
4994 sv_setiv(oldsv, cur);
4995 }
4996 else {
4997 /* we need a fresh SV every time so that loop body sees a
4998 * completely new SV for closures/references to work as they
4999 * used to */
5000 *itersvp = newSViv(cur);
5001 SvREFCNT_dec(oldsv);
5002 }
5003
5004 if (UNLIKELY(pad_it)) {
5005 /* We're good (see "We are looping n-at-a-time" comment
5006 above). */
5007 }
5008 else if (UNLIKELY(cur == IV_MAX)) {
5009 /* Handle end of range at IV_MAX */
5010 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
5011 } else
5012 ++cx->blk_loop.state_u.lazyiv.cur;
5013 break;
5014 }
5015
5016 case CXt_LOOP_LIST: /* for (1,2,3) */
5017
5018 assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
5019 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
5020 ix = (cx->blk_loop.state_u.stack.ix += inc);
5021 if (UNLIKELY(inc > 0
5022 ? ix > cx->blk_oldsp
5023 : ix <= cx->blk_loop.state_u.stack.basesp)
5024 ) {
5025 if (LIKELY(!i)) {
5026 goto retno;
5027 }
5028
5029 sv = &PL_sv_undef;
5030 }
5031 else {
5032 sv = PL_stack_base[ix];
5033 }
5034
5035 av = NULL;
5036 goto loop_ary_common;
5037
5038 case CXt_LOOP_ARY: /* for (@ary) */
5039
5040 av = cx->blk_loop.state_u.ary.ary;
5041 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
5042 ix = (cx->blk_loop.state_u.ary.ix += inc);
5043 if (UNLIKELY(inc > 0
5044 ? ix > AvFILL(av)
5045 : ix < 0)
5046 ) {
5047 if (LIKELY(!i)) {
5048 goto retno;
5049 }
5050
5051 sv = &PL_sv_undef;
5052 } else if (UNLIKELY(SvRMAGICAL(av))) {
5053 SV * const * const svp = av_fetch(av, ix, FALSE);
5054 sv = svp ? *svp : NULL;
5055 }
5056 else {
5057 sv = AvARRAY(av)[ix];
5058 }
5059
5060 loop_ary_common:
5061
5062 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
5063 SvSetMagicSV(*itersvp, sv);
5064 break;
5065 }
5066
5067 if (LIKELY(sv)) {
5068 if (UNLIKELY(SvIS_FREED(sv))) {
5069 *itersvp = NULL;
5070 Perl_croak(aTHX_ "Use of freed value in iteration");
5071 }
5072 if (SvPADTMP(sv)) {
5073 sv = newSVsv(sv);
5074 }
5075 else {
5076 SvTEMP_off(sv);
5077 SvREFCNT_inc_simple_void_NN(sv);
5078 }
5079 }
5080 else if (av) {
5081 sv = newSVavdefelem(av, ix, 0);
5082 }
5083 else
5084 sv = &PL_sv_undef;
5085
5086 oldsv = *itersvp;
5087 *itersvp = sv;
5088 SvREFCNT_dec(oldsv);
5089 break;
5090
5091 default:
5092 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
5093 }
5094
5095 /* Only relevant for a many-at-a-time loop: */
5096 ++itersvp;
5097 }
5098
5099 /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead
5100 * jump straight to the AND op's op_other */
5101 assert(PL_op->op_next->op_type == OP_AND);
5102 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
5103 return cLOGOPx(PL_op->op_next)->op_other;
5104 }
5105 else {
5106 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
5107 * obvious way. */
5108 /* pp_enteriter should have pre-extended the stack */
5109 EXTEND_SKIP(PL_stack_sp, 1);
5110 rpp_push_IMM(&PL_sv_yes);
5111 return PL_op->op_next;
5112 }
5113
5114 retno:
5115 /* Try to bypass pushing &PL_sv_no and calling pp_and(); instead
5116 * jump straight to the AND op's op_next */
5117 assert(PL_op->op_next->op_type == OP_AND);
5118 /* pp_enteriter should have pre-extended the stack */
5119 EXTEND_SKIP(PL_stack_sp, 1);
5120 /* we only need this for the rare case where the OP_AND isn't
5121 * in void context, e.g. $x = do { for (..) {...} };
5122 * (or for when an XS module has replaced the op_ppaddr)
5123 * but it's cheaper to just push it rather than testing first
5124 */
5125 rpp_push_IMM(&PL_sv_no);
5126 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
5127 return PL_op->op_next->op_next;
5128 }
5129 else {
5130 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
5131 * obvious way. */
5132 return PL_op->op_next;
5133 }
5134 }
5135
5136
5137 /*
5138 A description of how taint works in pattern matching and substitution.
5139
5140 This is all conditional on NO_TAINT_SUPPORT remaining undefined (the default).
5141 Under NO_TAINT_SUPPORT, taint-related operations should become no-ops.
5142
5143 While the pattern is being assembled/concatenated and then compiled,
5144 PL_tainted will get set (via TAINT_set) if any component of the pattern
5145 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
5146 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
5147 TAINT_get). It will also be set if any component of the pattern matches
5148 based on locale-dependent behavior.
5149
5150 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
5151 the pattern is marked as tainted. This means that subsequent usage, such
5152 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
5153 on the new pattern too.
5154
5155 RXf_TAINTED_SEEN is used post-execution by the get magic code
5156 of $1 et al to indicate whether the returned value should be tainted.
5157 It is the responsibility of the caller of the pattern (i.e. pp_match,
5158 pp_subst etc) to set this flag for any other circumstances where $1 needs
5159 to be tainted.
5160
5161 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
5162
5163 There are three possible sources of taint
5164 * the source string
5165 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
5166 * the replacement string (or expression under /e)
5167
5168 There are four destinations of taint and they are affected by the sources
5169 according to the rules below:
5170
5171 * the return value (not including /r):
5172 tainted by the source string and pattern, but only for the
5173 number-of-iterations case; boolean returns aren't tainted;
5174 * the modified string (or modified copy under /r):
5175 tainted by the source string, pattern, and replacement strings;
5176 * $1 et al:
5177 tainted by the pattern, and under 'use re "taint"', by the source
5178 string too;
5179 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
5180 should always be unset before executing subsequent code.
5181
5182 The overall action of pp_subst is:
5183
5184 * at the start, set bits in rxtainted indicating the taint status of
5185 the various sources.
5186
5187 * After each pattern execution, update the SUBST_TAINT_PAT bit in
5188 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
5189 pattern has subsequently become tainted via locale ops.
5190
5191 * If control is being passed to pp_substcont to execute a /e block,
5192 save rxtainted in the CXt_SUBST block, for future use by
5193 pp_substcont.
5194
5195 * Whenever control is being returned to perl code (either by falling
5196 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
5197 use the flag bits in rxtainted to make all the appropriate types of
5198 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
5199 et al will appear tainted.
5200
5201 pp_match is just a simpler version of the above.
5202
5203 */
5204
PP(pp_subst)5205 PP(pp_subst)
5206 {
5207 dTARG;
5208 PMOP *pm = cPMOP;
5209 PMOP *rpm = pm;
5210 char *s;
5211 char *strend;
5212 const char *c;
5213 STRLEN clen;
5214 SSize_t iters = 0;
5215 SSize_t maxiters;
5216 bool once;
5217 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
5218 See "how taint works" above */
5219 char *orig;
5220 U8 r_flags;
5221 REGEXP *rx = PM_GETRE(pm);
5222 regexp *prog = ReANY(rx);
5223 STRLEN len;
5224 int force_on_match = 0;
5225 const I32 oldsave = PL_savestack_ix;
5226 bool doutf8 = FALSE; /* whether replacement is in utf8 */
5227 #ifdef PERL_ANY_COW
5228 bool was_cow;
5229 #endif
5230 SV *nsv = NULL;
5231 SSize_t sp_offset = 0; /* number of items left on stack */
5232 SV *dstr;
5233 SV *retval;
5234
5235 PERL_ASYNC_CHECK();
5236
5237 if (pm->op_pmflags & PMf_CONST) {
5238 /* known replacement string */
5239 dstr = *PL_stack_sp;
5240 sp_offset++;
5241 }
5242 else
5243 dstr = NULL;
5244
5245 if (PL_op->op_flags & OPf_STACKED) {
5246 /* expr =~ s///; */
5247 TARG = PL_stack_sp[-sp_offset];
5248 sp_offset++;
5249 }
5250 else {
5251 if (ARGTARG)
5252 /* $lex =~ s///; */
5253 GETTARGET;
5254 else {
5255 /* s///; */
5256 TARG = DEFSV;
5257 }
5258 if (!sp_offset)
5259 rpp_extend(1);
5260 }
5261
5262 SvGETMAGIC(TARG); /* must come before cow check */
5263 #ifdef PERL_ANY_COW
5264 /* note that a string might get converted to COW during matching */
5265 was_cow = cBOOL(SvIsCOW(TARG));
5266 #endif
5267 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
5268 #ifndef PERL_ANY_COW
5269 if (SvIsCOW(TARG))
5270 sv_force_normal_flags(TARG,0);
5271 #endif
5272 if ((SvREADONLY(TARG)
5273 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
5274 || SvTYPE(TARG) > SVt_PVLV)
5275 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
5276 Perl_croak_no_modify();
5277 }
5278
5279 orig = SvPV_nomg(TARG, len);
5280 /* note we don't (yet) force the var into being a string; if we fail
5281 * to match, we leave as-is; on successful match however, we *will*
5282 * coerce into a string, then repeat the match */
5283 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
5284 force_on_match = 1;
5285
5286 /* only replace once? */
5287 once = !(rpm->op_pmflags & PMf_GLOBAL);
5288
5289 /* See "how taint works" above */
5290 if (TAINTING_get) {
5291 rxtainted = (
5292 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
5293 | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
5294 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
5295 | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
5296 || (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0));
5297 TAINT_NOT;
5298 }
5299
5300 force_it:
5301 if (!pm || !orig)
5302 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
5303
5304 strend = orig + len;
5305 /* We can match twice at each position, once with zero-length,
5306 * second time with non-zero.
5307 * Don't handle utf8 specially; we can use length-in-bytes as an
5308 * upper bound on length-in-characters, and avoid the cpu-cost of
5309 * computing a tighter bound. */
5310 maxiters = 2 * len + 10;
5311
5312 /* handle the empty pattern */
5313 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
5314 if (PL_curpm == PL_reg_curpm) {
5315 if (PL_curpm_under) {
5316 if (PL_curpm_under == PL_reg_curpm) {
5317 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
5318 } else {
5319 pm = PL_curpm_under;
5320 }
5321 }
5322 } else {
5323 pm = PL_curpm;
5324 }
5325 rx = PM_GETRE(pm);
5326 prog = ReANY(rx);
5327 }
5328
5329 #ifdef PERL_SAWAMPERSAND
5330 r_flags = ( RXp_NPARENS(prog)
5331 || PL_sawampersand
5332 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5333 || (rpm->op_pmflags & PMf_KEEPCOPY)
5334 )
5335 ? REXEC_COPY_STR
5336 : 0;
5337 #else
5338 r_flags = REXEC_COPY_STR;
5339 #endif
5340
5341 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
5342 {
5343 SV *ret = rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no;
5344 if (dstr)
5345 rpp_popfree_1_NN(); /* pop replacement string */
5346 if (PL_op->op_flags & OPf_STACKED)
5347 rpp_replace_1_1_NN(ret); /* pop LHS of =~ */
5348 else
5349 rpp_push_1(ret);
5350 LEAVE_SCOPE(oldsave);
5351 return NORMAL;
5352 }
5353 PL_curpm = pm;
5354
5355 /* known replacement string? */
5356 if (dstr) {
5357 /* replacement needing upgrading? */
5358 if (DO_UTF8(TARG) && !doutf8) {
5359 nsv = sv_newmortal();
5360 SvSetSV(nsv, dstr);
5361 sv_utf8_upgrade(nsv);
5362 c = SvPV_const(nsv, clen);
5363 doutf8 = TRUE;
5364 }
5365 else {
5366 c = SvPV_const(dstr, clen);
5367 doutf8 = DO_UTF8(dstr);
5368 }
5369
5370 if (UNLIKELY(TAINT_get))
5371 rxtainted |= SUBST_TAINT_REPL;
5372 }
5373 else {
5374 c = NULL;
5375 doutf8 = FALSE;
5376 }
5377
5378 if (c
5379 #ifdef PERL_ANY_COW
5380 && !was_cow
5381 #endif
5382 && (SSize_t)clen <= RXp_MINLENRET(prog)
5383 && ( once
5384 || !(r_flags & REXEC_COPY_STR)
5385 || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
5386 )
5387 && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
5388 && (!doutf8 || SvUTF8(TARG))
5389 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
5390 {
5391 /* known replacement string and can do in-place substitution */
5392
5393 #ifdef PERL_ANY_COW
5394 /* string might have got converted to COW since we set was_cow */
5395 if (SvIsCOW(TARG)) {
5396 if (!force_on_match)
5397 goto have_a_cow;
5398 assert(SvVOK(TARG));
5399 }
5400 #endif
5401 if (force_on_match) {
5402 /* redo the first match, this time with the orig var
5403 * forced into being a string */
5404 force_on_match = 0;
5405 orig = SvPV_force_nomg(TARG, len);
5406 goto force_it;
5407 }
5408
5409 if (once) {
5410 char *d, *m;
5411 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
5412 rxtainted |= SUBST_TAINT_PAT;
5413 m = orig + RXp_OFFS_START(prog,0);
5414 d = orig + RXp_OFFS_END(prog,0);
5415 s = orig;
5416 if (m - s > strend - d) { /* faster to shorten from end */
5417 SSize_t i;
5418 if (clen) {
5419 Copy(c, m, clen, char);
5420 m += clen;
5421 }
5422 i = strend - d;
5423 if (i > 0) {
5424 Move(d, m, i, char);
5425 m += i;
5426 }
5427 *m = '\0';
5428 SvCUR_set(TARG, m - s);
5429 }
5430 else { /* faster from front */
5431 SSize_t i = m - s;
5432 d -= clen;
5433 if (i > 0)
5434 Move(s, d - i, i, char);
5435 sv_chop(TARG, d-i);
5436 if (clen)
5437 Copy(c, d, clen, char);
5438 }
5439 retval = &PL_sv_yes;
5440 goto ret;
5441 }
5442 else {
5443 char *d, *m;
5444 d = s = RXp_OFFS_START(prog,0) + orig;
5445 do {
5446 SSize_t i;
5447 if (UNLIKELY(iters++ > maxiters))
5448 DIE(aTHX_ "Substitution loop");
5449 /* run time pattern taint, eg locale */
5450 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
5451 rxtainted |= SUBST_TAINT_PAT;
5452 m = RXp_OFFS_START(prog,0) + orig;
5453 if ((i = m - s)) {
5454 if (s != d)
5455 Move(s, d, i, char);
5456 d += i;
5457 }
5458 if (clen) {
5459 Copy(c, d, clen, char);
5460 d += clen;
5461 }
5462 s = RXp_OFFS_END(prog,0) + orig;
5463 } while (CALLREGEXEC(rx, s, strend, orig,
5464 s == m, /* don't match same null twice */
5465 TARG, NULL,
5466 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
5467 if (s != d) {
5468 SSize_t i = strend - s;
5469 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
5470 Move(s, d, i+1, char); /* include the NUL */
5471 }
5472 assert(iters);
5473 goto ret_iters;
5474 }
5475 }
5476 else {
5477 /* not known replacement string or can't do in-place substitution) */
5478 bool first;
5479 char *m;
5480 SV *repl;
5481 if (force_on_match) {
5482 /* redo the first match, this time with the orig var
5483 * forced into being a string */
5484 force_on_match = 0;
5485 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
5486 /* I feel that it should be possible to avoid this mortal copy
5487 given that the code below copies into a new destination.
5488 However, I suspect it isn't worth the complexity of
5489 unravelling the C<goto force_it> for the small number of
5490 cases where it would be viable to drop into the copy code. */
5491 TARG = sv_2mortal(newSVsv(TARG));
5492 }
5493 orig = SvPV_force_nomg(TARG, len);
5494 goto force_it;
5495 }
5496 #ifdef PERL_ANY_COW
5497 have_a_cow:
5498 #endif
5499 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
5500 rxtainted |= SUBST_TAINT_PAT;
5501 repl = dstr;
5502 s = RXp_OFFS_START(prog,0) + orig;
5503 dstr = newSVpvn_flags(orig, s-orig,
5504 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
5505 if (!c) {
5506 /* not known replacement string - call out to ops and OP_SUBSTCONT */
5507 PERL_CONTEXT *cx;
5508 m = orig;
5509 /* note that a whole bunch of local vars are saved here for
5510 * use by pp_substcont: here's a list of them in case you're
5511 * searching for places in this sub that uses a particular var:
5512 * iters maxiters r_flags oldsave rxtainted orig dstr targ
5513 * s m strend rx once */
5514 CX_PUSHSUBST(cx);
5515 return cPMOP->op_pmreplrootu.op_pmreplroot;
5516 }
5517
5518 /* We get here if it's a known replacement string, but can't
5519 * substitute in-place */
5520
5521 first = TRUE;
5522 do {
5523 if (UNLIKELY(iters++ > maxiters))
5524 DIE(aTHX_ "Substitution loop");
5525 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
5526 rxtainted |= SUBST_TAINT_PAT;
5527 if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
5528 char *old_s = s;
5529 char *old_orig = orig;
5530 assert(RXp_SUBOFFSET(prog) == 0);
5531
5532 orig = RXp_SUBBEG(prog);
5533 s = orig + (old_s - old_orig);
5534 strend = s + (strend - old_s);
5535 }
5536 m = RXp_OFFS_START(prog,0) + orig;
5537 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
5538 s = RXp_OFFS_END(prog,0) + orig;
5539 if (first) {
5540 /* replacement already stringified */
5541 if (clen)
5542 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
5543 first = FALSE;
5544 }
5545 else {
5546 sv_catsv(dstr, repl);
5547 }
5548 if (once)
5549 break;
5550 } while (CALLREGEXEC(rx, s, strend, orig,
5551 s == m, /* Yields minend of 0 or 1 */
5552 TARG, NULL,
5553 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
5554 assert(strend >= s);
5555 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
5556
5557 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
5558 /* From here on down we're using the copy, and leaving the original
5559 untouched. */
5560 TARG = dstr;
5561 retval = dstr;
5562 goto ret;
5563 } else {
5564 #ifdef PERL_ANY_COW
5565 /* The match may make the string COW. If so, brilliant, because
5566 that's just saved us one malloc, copy and free - the regexp has
5567 donated the old buffer, and we malloc an entirely new one, rather
5568 than the regexp malloc()ing a buffer and copying our original,
5569 only for us to throw it away here during the substitution. */
5570 if (SvIsCOW(TARG)) {
5571 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
5572 } else
5573 #endif
5574 {
5575 SvPV_free(TARG);
5576 }
5577 SvPV_set(TARG, SvPVX(dstr));
5578 SvCUR_set(TARG, SvCUR(dstr));
5579 SvLEN_set(TARG, SvLEN(dstr));
5580 SvFLAGS(TARG) |= SvUTF8(dstr);
5581 SvPV_set(dstr, NULL);
5582 goto ret_iters;
5583 }
5584 }
5585
5586 ret_iters:
5587 if (PL_op->op_private & OPpTRUEBOOL)
5588 retval = &PL_sv_yes;
5589 else {
5590 retval = sv_newmortal();
5591 sv_setiv(retval, iters);
5592 }
5593
5594 ret:
5595 if (dstr)
5596 rpp_popfree_1_NN(); /* pop replacement string */
5597 if (PL_op->op_flags & OPf_STACKED)
5598 rpp_replace_1_1_NN(retval); /* pop LHS of =~ */
5599 else
5600 rpp_push_1(retval);
5601
5602 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
5603 (void)SvPOK_only_UTF8(TARG);
5604 }
5605
5606 /* See "how taint works" above */
5607 if (TAINTING_get) {
5608 if ((rxtainted & SUBST_TAINT_PAT) ||
5609 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
5610 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
5611 )
5612 (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
5613
5614 if (!(rxtainted & SUBST_TAINT_BOOLRET)
5615 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
5616 )
5617 SvTAINTED_on(retval); /* taint return value */
5618 else
5619 SvTAINTED_off(retval); /* may have got tainted earlier */
5620
5621 /* needed for mg_set below */
5622 TAINT_set(
5623 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
5624 );
5625 SvTAINT(TARG);
5626 }
5627 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
5628 TAINT_NOT;
5629 LEAVE_SCOPE(oldsave);
5630 return NORMAL;
5631 }
5632
5633
PP(pp_grepwhile)5634 PP(pp_grepwhile)
5635 {
5636 /* Understanding the stack during a grep.
5637 *
5638 * 'grep expr, args' is implemented in the form of
5639 * grepstart;
5640 * do {
5641 * expr;
5642 * grepwhile;
5643 * } while (args);
5644 *
5645 * The stack examples below are in the form of 'perl -Ds' output,
5646 * where any stack element indexed by PL_markstack_ptr[i] has a star
5647 * just to the right of it. In addition, the corresponding i value
5648 * is displayed under the indexed stack element.
5649 *
5650 * On entry to grepwhile, the stack looks like this:
5651 *
5652 * => * M1..Mn X1 * X2..Xn C * R1..Rn BOOL
5653 * [-2] [-1] [0]
5654 *
5655 * where:
5656 * M1..Mn Accumulated args which have been matched so far.
5657 * X1..Xn Random discardable elements from previous iterations.
5658 * C The current (just processed) arg, still aliased to $_.
5659 * R1..Rn The args remaining to be processed.
5660 * BOOL the result of the just-executed grep expression.
5661 *
5662 * Note that it is easiest to think of the top two stack marks as both
5663 * being one too high, and so it would make more sense to have had the
5664 * marks like this:
5665 *
5666 * => * M1..Mn * X1..Xn * C R1..Rn BOOL
5667 * [-2] [-1] [0]
5668 *
5669 * where the stack is divided neatly into 3 groups:
5670 * - matched,
5671 * - discarded,
5672 * - being, or yet to be, processed.
5673 * But off-by-one is the way it is currently, and it works as long as
5674 * we keep it consistent and bear it in mind.
5675 *
5676 * pp_grepwhile() does the following:
5677 *
5678 * - for a match, replace the X1 pointer with a pointer to C and bump
5679 * PL_markstack_ptr[-1]
5680 * - if more args to process, bump PL_markstack_ptr[0] and update the
5681 * $_ alias, else
5682 * - remove top 3 MARKs and return M1..Mn, or a scalar,
5683 * or void as appropriate.
5684 *
5685 */
5686
5687 bool match = SvTRUE_NN(*PL_stack_sp);
5688 rpp_popfree_1_NN();
5689
5690 if (match) {
5691 SV **from_p = PL_stack_base + PL_markstack_ptr[0];
5692 SV **to_p = PL_stack_base + PL_markstack_ptr[-1]++;
5693 SV *from = *from_p;
5694 SV *to = *to_p;
5695
5696 if (from != to) {
5697 *to_p = from;
5698 #ifdef PERL_RC_STACK
5699 SvREFCNT_inc_simple_void_NN(from);
5700 SvREFCNT_dec(to);
5701 #endif
5702 }
5703 }
5704
5705 ++*PL_markstack_ptr;
5706 FREETMPS;
5707 LEAVE_with_name("grep_item"); /* exit inner scope */
5708
5709 /* All done yet? */
5710 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > PL_stack_sp)) {
5711 SSize_t items;
5712 const U8 gimme = GIMME_V;
5713
5714 LEAVE_with_name("grep"); /* exit outer scope */
5715 (void)POPMARK; /* pop src */
5716 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
5717 (void)POPMARK; /* pop dst */
5718 SV **base = PL_stack_base + POPMARK; /* pop original mark */
5719
5720 if (gimme == G_LIST)
5721 rpp_popfree_to_NN(base + items);
5722 else {
5723 rpp_popfree_to_NN(base);
5724 if (gimme == G_SCALAR) {
5725 if (PL_op->op_private & OPpTRUEBOOL)
5726 rpp_push_IMM(items ? &PL_sv_yes : &PL_sv_zero);
5727 else {
5728 dTARGET;
5729 TARGi(items,1);
5730 rpp_push_1(TARG);
5731 }
5732 }
5733 }
5734
5735 return NORMAL;
5736 }
5737 else {
5738 SV *src;
5739
5740 ENTER_with_name("grep_item"); /* enter inner scope */
5741 SAVEVPTR(PL_curpm);
5742
5743 src = PL_stack_base[TOPMARK];
5744 if (SvPADTMP(src)) {
5745 SV *newsrc = sv_mortalcopy(src);
5746 PL_stack_base[TOPMARK] = newsrc;
5747 #ifdef PERL_RC_STACK
5748 SvREFCNT_inc_simple_void_NN(newsrc);
5749 SvREFCNT_dec(src);
5750 #endif
5751 src = newsrc;
5752 PL_tmps_floor++;
5753 }
5754 SvTEMP_off(src);
5755 DEFSV_set(src);
5756
5757 return cLOGOP->op_other;
5758 }
5759 }
5760
5761
5762 /* leave_adjust_stacks():
5763 *
5764 * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
5765 * positioning them at to_sp+1 onwards, and do the equivalent of a
5766 * FREEMPS and TAINT_NOT.
5767 *
5768 * Not intended to be called in void context.
5769 *
5770 * When leaving a sub, eval, do{} or other scope, the things that need
5771 * doing to process the return args are:
5772 * * in scalar context, only return the last arg (or PL_sv_undef if none);
5773 * * for the types of return that return copies of their args (such
5774 * as rvalue sub return), make a mortal copy of every return arg,
5775 * except where we can optimise the copy away without it being
5776 * semantically visible;
5777 * * make sure that the arg isn't prematurely freed; in the case of an
5778 * arg not copied, this may involve mortalising it. For example, in
5779 * C<sub f { my $x = ...; $x }>, $x would be freed when we do
5780 * CX_LEAVE_SCOPE(cx) unless it's protected or copied.
5781 *
5782 * What condition to use when deciding whether to pass the arg through
5783 * or make a copy, is determined by the 'pass' arg; its valid values are:
5784 * 0: rvalue sub/eval exit
5785 * 1: other rvalue scope exit
5786 * 2: :lvalue sub exit in rvalue context
5787 * 3: :lvalue sub exit in lvalue context and other lvalue scope exits
5788 *
5789 * There is a big issue with doing a FREETMPS. We would like to free any
5790 * temps created by the last statement which the sub executed, rather than
5791 * leaving them for the caller. In a situation where a sub call isn't
5792 * soon followed by a nextstate (e.g. nested recursive calls, a la
5793 * fibonacci()), temps can accumulate, causing memory and performance
5794 * issues.
5795 *
5796 * On the other hand, we don't want to free any TEMPs which are keeping
5797 * alive any return args that we skipped copying; nor do we wish to undo
5798 * any mortalising done here.
5799 *
5800 * The solution is to split the temps stack frame into two, with a cut
5801 * point delineating the two halves. We arrange that by the end of this
5802 * function, all the temps stack frame entries we wish to keep are in the
5803 * range PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
5804 * the range tmps_base .. PL_tmps_ix. During the course of this
5805 * function, tmps_base starts off as PL_tmps_floor+1, then increases
5806 * whenever we find or create a temp that we know should be kept. In
5807 * general the stuff above tmps_base is undecided until we reach the end,
5808 * and we may need a sort stage for that.
5809 *
5810 * To determine whether a TEMP is keeping a return arg alive, every
5811 * arg that is kept rather than copied and which has the SvTEMP flag
5812 * set, has the flag temporarily unset, to mark it. At the end we scan
5813 * the temps stack frame above the cut for entries without SvTEMP and
5814 * keep them, while turning SvTEMP on again. Note that if we die before
5815 * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
5816 * those SVs may be slightly less efficient.
5817 *
5818 * In practice various optimisations for some common cases mean we can
5819 * avoid most of the scanning and swapping about with the temps stack.
5820 */
5821
5822 void
Perl_leave_adjust_stacks(pTHX_ SV ** from_sp,SV ** to_sp,U8 gimme,int pass)5823 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
5824 {
5825 SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
5826 SSize_t nargs;
5827
5828 PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
5829
5830 TAINT_NOT;
5831
5832 if (gimme == G_LIST) {
5833 nargs = PL_stack_sp - from_sp;
5834 from_sp++;
5835 }
5836 else {
5837 assert(gimme == G_SCALAR);
5838 if (UNLIKELY(from_sp >= PL_stack_sp)) {
5839 /* no return args */
5840 assert(from_sp == PL_stack_sp);
5841 rpp_xpush_IMM(&PL_sv_undef);
5842 }
5843 from_sp = PL_stack_sp;
5844 nargs = 1;
5845 }
5846
5847 /* common code for G_SCALAR and G_LIST */
5848
5849 #ifdef PERL_RC_STACK
5850 {
5851 /* free any items from the stack which are about to get
5852 * over-written */
5853 SV **p = from_sp - 1;
5854 assert(p >= to_sp);
5855 while (p > to_sp) {
5856 SV *sv = *p;
5857 *p-- = NULL;
5858 SvREFCNT_dec(sv);
5859 }
5860 }
5861 #endif
5862
5863
5864 tmps_base = PL_tmps_floor + 1;
5865
5866 assert(nargs >= 0);
5867 if (nargs) {
5868 /* pointer version of tmps_base. Not safe across temp stack
5869 * reallocs. */
5870 SV **tmps_basep;
5871
5872 EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
5873 tmps_basep = PL_tmps_stack + tmps_base;
5874
5875 /* process each return arg */
5876
5877 do {
5878 SV *sv = *from_sp++;
5879
5880 assert(PL_tmps_ix + nargs < PL_tmps_max);
5881 #ifdef DEBUGGING
5882 /* PADTMPs with container set magic shouldn't appear in the
5883 * wild. This assert is more important for pp_leavesublv(),
5884 * but by testing for it here, we're more likely to catch
5885 * bad cases (what with :lvalue subs not being widely
5886 * deployed). The two issues are that for something like
5887 * sub :lvalue { $tied{foo} }
5888 * or
5889 * sub :lvalue { substr($foo,1,2) }
5890 * pp_leavesublv() will croak if the sub returns a PADTMP,
5891 * and currently functions like pp_substr() return a mortal
5892 * rather than using their PADTMP when returning a PVLV.
5893 * This is because the PVLV will hold a ref to $foo,
5894 * so $foo would get delayed in being freed while
5895 * the PADTMP SV remained in the PAD.
5896 * So if this assert fails it means either:
5897 * 1) there is pp code similar to pp_substr that is
5898 * returning a PADTMP instead of a mortal, and probably
5899 * needs fixing, or
5900 * 2) pp_leavesublv is making unwarranted assumptions
5901 * about always croaking on a PADTMP
5902 */
5903 if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
5904 MAGIC *mg;
5905 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
5906 assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
5907 }
5908 }
5909 #endif
5910
5911 if (
5912 pass == 0 ? (rpp_is_lone(sv) && !SvMAGICAL(sv))
5913 : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
5914 : pass == 2 ? (!SvPADTMP(sv))
5915 : 1)
5916 {
5917 /* pass through: skip copy for logic or optimisation
5918 * reasons; instead mortalise it, except that ... */
5919
5920 #ifdef PERL_RC_STACK
5921 from_sp[-1] = NULL;
5922 #endif
5923 *++to_sp = sv;
5924
5925 if (SvTEMP(sv)) {
5926 /* ... since this SV is an SvTEMP , we don't need to
5927 * re-mortalise it; instead we just need to ensure
5928 * that its existing entry in the temps stack frame
5929 * ends up below the cut and so avoids being freed
5930 * this time round. We mark it as needing to be kept
5931 * by temporarily unsetting SvTEMP; then at the end,
5932 * we shuffle any !SvTEMP entries on the tmps stack
5933 * back below the cut.
5934 * However, there's a significant chance that there's
5935 * a 1:1 correspondence between the first few (or all)
5936 * elements in the return args stack frame and those
5937 * in the temps stack frame; e,g.:
5938 * sub f { ....; map {...} .... },
5939 * or if we're exiting multiple scopes and one of the
5940 * inner scopes has already made mortal copies of each
5941 * return arg.
5942 *
5943 * If so, this arg sv will correspond to the next item
5944 * on the tmps stack above the cut, and so can be kept
5945 * merely by moving the cut boundary up one, rather
5946 * than messing with SvTEMP. If all args are 1:1 then
5947 * we can avoid the sorting stage below completely.
5948 *
5949 * If there are no items above the cut on the tmps
5950 * stack, then the SvTEMP must comne from an item
5951 * below the cut, so there's nothing to do.
5952 */
5953 if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
5954 if (sv == *tmps_basep)
5955 tmps_basep++;
5956 else
5957 SvTEMP_off(sv);
5958 }
5959 }
5960 else if (!SvPADTMP(sv)) {
5961 /* mortalise arg to avoid it being freed during save
5962 * stack unwinding. Pad tmps don't need mortalising as
5963 * they're never freed. This is the equivalent of
5964 * sv_2mortal(SvREFCNT_inc(sv)), except that:
5965 * * it assumes that the temps stack has already been
5966 * extended;
5967 * * it puts the new item at the cut rather than at
5968 * ++PL_tmps_ix, moving the previous occupant there
5969 * instead.
5970 */
5971 if (!SvIMMORTAL(sv)) {
5972 SvREFCNT_inc_simple_void_NN(sv);
5973 SvTEMP_on(sv);
5974 /* Note that if there's nothing above the cut,
5975 * this copies the garbage one slot above
5976 * PL_tmps_ix onto itself. This is harmless (the
5977 * stack's already been extended), but might in
5978 * theory trigger warnings from tools like ASan
5979 */
5980 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
5981 *tmps_basep++ = sv;
5982 }
5983 }
5984 }
5985 else {
5986 /* Make a mortal copy of the SV.
5987 * The following code is the equivalent of sv_mortalcopy()
5988 * except that:
5989 * * it assumes the temps stack has already been extended;
5990 * * it optimises the copying for some simple SV types;
5991 * * it puts the new item at the cut rather than at
5992 * ++PL_tmps_ix, moving the previous occupant there
5993 * instead.
5994 */
5995 SV *newsv = newSV_type(SVt_NULL);
5996
5997 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
5998 /* put it on the tmps stack early so it gets freed if we die */
5999 *tmps_basep++ = newsv;
6000
6001 if (SvTYPE(sv) <= SVt_IV) {
6002 /* arg must be one of undef, IV/UV, or RV: skip
6003 * sv_setsv_flags() and do the copy directly */
6004 U32 dstflags;
6005 U32 srcflags = SvFLAGS(sv);
6006
6007 assert(!SvGMAGICAL(sv));
6008 if (srcflags & (SVf_IOK|SVf_ROK)) {
6009 SET_SVANY_FOR_BODYLESS_IV(newsv);
6010
6011 if (srcflags & SVf_ROK) {
6012 newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
6013 /* SV type plus flags */
6014 dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
6015 }
6016 else {
6017 /* both src and dst are <= SVt_IV, so sv_any
6018 * points to the head; so access the heads
6019 * directly rather than going via sv_any.
6020 */
6021 assert( &(sv->sv_u.svu_iv)
6022 == &(((XPVIV*) SvANY(sv))->xiv_iv));
6023 assert( &(newsv->sv_u.svu_iv)
6024 == &(((XPVIV*) SvANY(newsv))->xiv_iv));
6025 newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
6026 /* SV type plus flags */
6027 dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
6028 |(srcflags & SVf_IVisUV));
6029 }
6030 }
6031 else {
6032 assert(!(srcflags & SVf_OK));
6033 dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
6034 }
6035 SvFLAGS(newsv) = dstflags;
6036
6037 }
6038 else {
6039 /* do the full sv_setsv() */
6040 SSize_t old_base;
6041
6042 SvTEMP_on(newsv);
6043 old_base = tmps_basep - PL_tmps_stack;
6044 SvGETMAGIC(sv);
6045 sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
6046 /* the mg_get or sv_setsv might have created new temps
6047 * or realloced the tmps stack; regrow and reload */
6048 EXTEND_MORTAL(nargs);
6049 tmps_basep = PL_tmps_stack + old_base;
6050 TAINT_NOT; /* Each item is independent */
6051 }
6052
6053
6054 #ifdef PERL_RC_STACK
6055 from_sp[-1] = NULL;
6056 SvREFCNT_dec_NN(sv);
6057 assert(!to_sp[1]);
6058 *++to_sp = newsv;
6059 SvREFCNT_inc_simple_void_NN(newsv);
6060 #else
6061 *++to_sp = newsv;
6062 #endif
6063
6064 }
6065 } while (--nargs);
6066
6067 /* If there are any temps left above the cut, we need to sort
6068 * them into those to keep and those to free. The only ones to
6069 * keep are those for which we've temporarily unset SvTEMP.
6070 * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
6071 * swapping pairs as necessary. Stop when we meet in the middle.
6072 */
6073 {
6074 SV **top = PL_tmps_stack + PL_tmps_ix;
6075 while (tmps_basep <= top) {
6076 SV *sv = *top;
6077 if (SvTEMP(sv))
6078 top--;
6079 else {
6080 SvTEMP_on(sv);
6081 *top = *tmps_basep;
6082 *tmps_basep = sv;
6083 tmps_basep++;
6084 }
6085 }
6086 }
6087
6088 tmps_base = tmps_basep - PL_tmps_stack;
6089 }
6090
6091 PL_stack_sp = to_sp;
6092
6093 /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
6094 while (PL_tmps_ix >= tmps_base) {
6095 SV* const sv = PL_tmps_stack[PL_tmps_ix--];
6096 #ifdef PERL_POISON
6097 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
6098 #endif
6099 if (LIKELY(sv)) {
6100 SvTEMP_off(sv);
6101 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
6102 }
6103 }
6104 }
6105
6106
6107 /* also tail-called by pp_return */
6108
PP(pp_leavesub)6109 PP(pp_leavesub)
6110 {
6111 U8 gimme;
6112 PERL_CONTEXT *cx;
6113 SV **oldsp;
6114 OP *retop;
6115
6116 cx = CX_CUR();
6117 assert(CxTYPE(cx) == CXt_SUB);
6118
6119 if (CxMULTICALL(cx)) {
6120 /* entry zero of a stack is always PL_sv_undef, which
6121 * simplifies converting a '()' return into undef in scalar context */
6122 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
6123 return 0;
6124 }
6125
6126 gimme = cx->blk_gimme;
6127 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
6128
6129 if (gimme == G_VOID)
6130 rpp_popfree_to_NN(oldsp);
6131 else
6132 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
6133
6134 CX_LEAVE_SCOPE(cx);
6135 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
6136 cx_popblock(cx);
6137 retop = cx->blk_sub.retop;
6138 CX_POP(cx);
6139
6140 return retop;
6141 }
6142
6143
6144 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
6145 * forces an abandon */
6146
6147 void
Perl_clear_defarray(pTHX_ AV * av,bool abandon)6148 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
6149 {
6150 PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
6151
6152 if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))
6153 #ifndef PERL_RC_STACK
6154 && !AvREAL(av)
6155 #endif
6156 ) {
6157 clear_defarray_simple(av);
6158 #ifndef PERL_RC_STACK
6159 AvREIFY_only(av);
6160 #endif
6161 }
6162 else {
6163 /* abandon */
6164 const SSize_t size = AvFILLp(av) + 1;
6165 /* The ternary gives consistency with av_extend() */
6166 AV *newav = newAV_alloc_xz(size < PERL_ARRAY_NEW_MIN_KEY ?
6167 PERL_ARRAY_NEW_MIN_KEY : size);
6168 #ifndef PERL_RC_STACK
6169 AvREIFY_only(newav);
6170 #endif
6171 PAD_SVl(0) = MUTABLE_SV(newav);
6172 SvREFCNT_dec_NN(av);
6173 }
6174 }
6175
6176
PP(pp_entersub)6177 PP(pp_entersub)
6178 {
6179 GV *gv;
6180 CV *cv;
6181 PERL_CONTEXT *cx;
6182 I32 old_savestack_ix;
6183 SV *sv = *PL_stack_sp;
6184
6185 if (UNLIKELY(!sv))
6186 goto do_die;
6187
6188 /* Locate the CV to call:
6189 * - most common case: RV->CV: f(), $ref->():
6190 * note that if a sub is compiled before its caller is compiled,
6191 * the stash entry will be a ref to a CV, rather than being a GV.
6192 * - second most common case: CV: $ref->method()
6193 */
6194
6195 /* a non-magic-RV -> CV ? */
6196 if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
6197 cv = MUTABLE_CV(SvRV(sv));
6198 if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
6199 goto do_ref;
6200 }
6201 else
6202 cv = MUTABLE_CV(sv);
6203
6204 /* a CV ? */
6205 if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
6206 /* handle all the weird cases */
6207 switch (SvTYPE(sv)) {
6208 case SVt_PVLV:
6209 if (!isGV_with_GP(sv))
6210 goto do_default;
6211 /* FALLTHROUGH */
6212 case SVt_PVGV:
6213 cv = GvCVu((const GV *)sv);
6214 if (UNLIKELY(!cv)) {
6215 HV *stash;
6216 cv = sv_2cv(sv, &stash, &gv, 0);
6217 if (!cv) {
6218 old_savestack_ix = PL_savestack_ix;
6219 goto try_autoload;
6220 }
6221 }
6222 break;
6223
6224 default:
6225 do_default:
6226 SvGETMAGIC(sv);
6227 if (SvROK(sv)) {
6228 do_ref:
6229 if (UNLIKELY(SvAMAGIC(sv))) {
6230 sv = amagic_deref_call(sv, to_cv_amg);
6231 }
6232 }
6233 else {
6234 const char *sym;
6235 STRLEN len;
6236 if (UNLIKELY(!SvOK(sv)))
6237 DIE(aTHX_ PL_no_usym, "a subroutine");
6238
6239 sym = SvPV_nomg_const(sv, len);
6240 if (PL_op->op_private & HINT_STRICT_REFS)
6241 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
6242 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
6243 break;
6244 }
6245 cv = MUTABLE_CV(SvRV(sv));
6246 if (LIKELY(SvTYPE(cv) == SVt_PVCV))
6247 break;
6248 /* FALLTHROUGH */
6249 case SVt_PVHV:
6250 case SVt_PVAV:
6251 do_die:
6252 DIE(aTHX_ "Not a CODE reference");
6253 }
6254 }
6255
6256 /* At this point we want to save PL_savestack_ix, either by doing a
6257 * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
6258 * CV we will be using (so we don't know whether its XS, so we can't
6259 * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
6260 * the save stack. So remember where we are currently on the save
6261 * stack, and later update the CX or scopestack entry accordingly. */
6262 old_savestack_ix = PL_savestack_ix;
6263
6264 /* these two fields are in a union. If they ever become separate,
6265 * we have to test for both of them being null below */
6266 assert(cv);
6267 assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
6268 while (UNLIKELY(!CvROOT(cv))) {
6269 GV* autogv;
6270 SV* sub_name;
6271
6272 /* anonymous or undef'd function leaves us no recourse */
6273 if (CvLEXICAL(cv) && CvHASGV(cv))
6274 DIE(aTHX_ "Undefined subroutine &%" SVf " called",
6275 SVfARG(cv_name(cv, NULL, 0)));
6276 if (CvANON(cv) || !CvHASGV(cv)) {
6277 DIE(aTHX_ "Undefined subroutine called");
6278 }
6279
6280 /* autoloaded stub? */
6281 if (cv != GvCV(gv = CvGV(cv))) {
6282 cv = GvCV(gv);
6283 }
6284 /* should call AUTOLOAD now? */
6285 else {
6286 try_autoload:
6287 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
6288 (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
6289 |(PL_op->op_flags & OPf_REF
6290 ? GV_AUTOLOAD_ISMETHOD
6291 : 0));
6292 cv = autogv ? GvCV(autogv) : NULL;
6293 }
6294 if (!cv) {
6295 sub_name = sv_newmortal();
6296 gv_efullname3(sub_name, gv, NULL);
6297 DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
6298 }
6299 }
6300
6301 /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
6302 if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
6303 DIE(aTHX_ "Closure prototype called");
6304
6305 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
6306 && !CvNODEBUG(cv)))
6307 {
6308 Perl_get_db_sub(aTHX_ &sv, cv);
6309 if (CvISXSUB(cv))
6310 PL_curcopdb = PL_curcop;
6311 if (CvLVALUE(cv)) {
6312 /* check for lsub that handles lvalue subroutines */
6313 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
6314 /* if lsub not found then fall back to DB::sub */
6315 if (!cv) cv = GvCV(PL_DBsub);
6316 } else {
6317 cv = GvCV(PL_DBsub);
6318 }
6319
6320 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
6321 DIE(aTHX_ "No DB::sub routine defined");
6322 }
6323
6324 rpp_popfree_1_NN(); /* finished with sv now */
6325
6326 if (!(CvISXSUB(cv))) {
6327 /* This path taken at least 75% of the time */
6328 dMARK;
6329 PADLIST *padlist;
6330 I32 depth;
6331 bool hasargs;
6332 U8 gimme;
6333
6334 /* keep PADTMP args alive throughout the call (we need to do this
6335 * because @_ isn't refcounted). Note that we create the mortals
6336 * in the caller's tmps frame, so they won't be freed until after
6337 * we return from the sub.
6338 */
6339 {
6340 SV **svp = MARK;
6341 while (svp < PL_stack_sp) {
6342 SV *sv = *++svp;
6343 if (!sv)
6344 continue;
6345 if (SvPADTMP(sv)) {
6346 SV *newsv = sv_mortalcopy(sv);
6347 *svp = newsv;
6348 #ifdef PERL_RC_STACK
6349 /* should just skip the mortalisation instead */
6350 SvREFCNT_inc_simple_void_NN(newsv);
6351 SvREFCNT_dec_NN(sv);
6352 #endif
6353 sv = newsv;
6354 }
6355 SvTEMP_off(sv);
6356 }
6357 }
6358
6359 gimme = GIMME_V;
6360 cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
6361 hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
6362 cx_pushsub(cx, cv, PL_op->op_next, hasargs);
6363
6364 padlist = CvPADLIST(cv);
6365 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
6366 pad_push(padlist, depth);
6367 PAD_SET_CUR_NOSAVE(padlist, depth);
6368 if (LIKELY(hasargs)) {
6369 AV *const av = MUTABLE_AV(PAD_SVl(0));
6370 SSize_t items;
6371 AV **defavp;
6372
6373 defavp = &GvAV(PL_defgv);
6374 cx->blk_sub.savearray = *defavp;
6375 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
6376
6377 /* it's the responsibility of whoever leaves a sub to ensure
6378 * that a clean, empty AV is left in pad[0]. This is normally
6379 * done by cx_popsub() */
6380
6381 #ifdef PERL_RC_STACK
6382 assert(AvREAL(av));
6383 #else
6384 assert(!AvREAL(av));
6385 #endif
6386 assert(AvFILLp(av) == -1);
6387
6388 items = PL_stack_sp - MARK;
6389 if (UNLIKELY(items - 1 > AvMAX(av))) {
6390 SV **ary = AvALLOC(av);
6391 Renew(ary, items, SV*);
6392 AvMAX(av) = items - 1;
6393 AvALLOC(av) = ary;
6394 AvARRAY(av) = ary;
6395 }
6396
6397 if (items)
6398 Copy(MARK+1,AvARRAY(av),items,SV*);
6399 AvFILLp(av) = items - 1;
6400 #ifdef PERL_RC_STACK
6401 /* transfer ownership of the arguments' refcounts to av */
6402 PL_stack_sp = MARK;
6403 #endif
6404 }
6405 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
6406 !CvLVALUE(cv)))
6407 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
6408 SVfARG(cv_name(cv, NULL, 0)));
6409 /* warning must come *after* we fully set up the context
6410 * stuff so that __WARN__ handlers can safely dounwind()
6411 * if they want to
6412 */
6413 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
6414 && ckWARN(WARN_RECURSION)
6415 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
6416 sub_crush_depth(cv);
6417 return CvSTART(cv);
6418 }
6419 else {
6420 SSize_t markix = TOPMARK;
6421 bool is_scalar;
6422
6423 ENTER;
6424 /* pretend we did the ENTER earlier */
6425 PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
6426
6427 SAVETMPS;
6428
6429 if (UNLIKELY(((PL_op->op_private
6430 & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
6431 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
6432 !CvLVALUE(cv)))
6433 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
6434 SVfARG(cv_name(cv, NULL, 0)));
6435
6436 if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) {
6437 /* Need to copy @_ to stack. Alternative may be to
6438 * switch stack to @_, and copy return values
6439 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
6440 AV * const av = GvAV(PL_defgv);
6441 const SSize_t items = AvFILL(av) + 1;
6442
6443 if (items) {
6444 SSize_t i = 0;
6445 const bool m = cBOOL(SvRMAGICAL(av));
6446 /* Mark is at the end of the stack. */
6447 rpp_extend(items);
6448 for (; i < items; ++i)
6449 {
6450 SV *sv;
6451 if (m) {
6452 SV ** const svp = av_fetch(av, i, 0);
6453 sv = svp ? *svp : NULL;
6454 }
6455 else
6456 sv = AvARRAY(av)[i];
6457
6458 rpp_push_1(sv ? sv : av_nonelem(av, i));
6459 }
6460 }
6461 }
6462 else {
6463 SV **mark = PL_stack_base + markix;
6464 SSize_t items = PL_stack_sp - mark;
6465 while (items--) {
6466 mark++;
6467 if (*mark && SvPADTMP(*mark)) {
6468 SV *oldsv = *mark;
6469 SV *newsv = sv_mortalcopy(oldsv);
6470 *mark = newsv;
6471 #ifdef PERL_RC_STACK
6472 /* should just skip the mortalisation instead */
6473 SvREFCNT_inc_simple_void_NN(newsv);
6474 SvREFCNT_dec_NN(oldsv);
6475 #endif
6476 }
6477 }
6478 }
6479
6480 /* We assume first XSUB in &DB::sub is the called one. */
6481 if (UNLIKELY(PL_curcopdb)) {
6482 SAVEVPTR(PL_curcop);
6483 PL_curcop = PL_curcopdb;
6484 PL_curcopdb = NULL;
6485 }
6486 /* Do we need to open block here? XXXX */
6487
6488 /* calculate gimme here as PL_op might get changed and then not
6489 * restored until the LEAVE further down */
6490 is_scalar = (GIMME_V == G_SCALAR);
6491
6492 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
6493 assert(CvXSUB(cv));
6494
6495 rpp_invoke_xs(cv);
6496
6497 #ifdef PERL_USE_HWM
6498 /* This duplicates the check done in runops_debug(), but provides more
6499 * information in the common case of the fault being with an XSUB.
6500 *
6501 * It should also catch an XSUB pushing more than it extends
6502 * in scalar context.
6503 */
6504 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
6505 Perl_croak_nocontext(
6506 "panic: XSUB %s::%s (%s) failed to extend arg stack: "
6507 "base=%p, sp=%p, hwm=%p\n",
6508 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)), CvFILE(cv),
6509 PL_stack_base, PL_stack_sp,
6510 PL_stack_base + PL_curstackinfo->si_stack_hwm);
6511 #endif
6512 /* Enforce some sanity in scalar context. */
6513 if (is_scalar) {
6514 SV **svp = PL_stack_base + markix + 1;
6515 if (svp != PL_stack_sp) {
6516 #ifdef PERL_RC_STACK
6517 if (svp < PL_stack_sp) {
6518 /* move return value to bottom of stack frame
6519 * and free everything else */
6520 SV* retsv = *PL_stack_sp;
6521 *PL_stack_sp = *svp;
6522 *svp = retsv;
6523 rpp_popfree_to_NN(svp);
6524 }
6525 else
6526 rpp_push_IMM(&PL_sv_undef);
6527 #else
6528 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
6529 PL_stack_sp = svp;
6530 #endif
6531 }
6532 }
6533 LEAVE;
6534 return NORMAL;
6535 }
6536 }
6537
6538 void
Perl_sub_crush_depth(pTHX_ CV * cv)6539 Perl_sub_crush_depth(pTHX_ CV *cv)
6540 {
6541 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
6542
6543 if (CvANON(cv))
6544 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
6545 else {
6546 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"",
6547 SVfARG(cv_name(cv,NULL,0)));
6548 }
6549 }
6550
6551
6552
6553 /* like croak, but report in context of caller */
6554
6555 void
Perl_croak_caller(const char * pat,...)6556 Perl_croak_caller(const char *pat, ...)
6557 {
6558 dTHX;
6559 va_list args;
6560 const PERL_CONTEXT *cx = caller_cx(0, NULL);
6561
6562 /* make error appear at call site */
6563 assert(cx);
6564 PL_curcop = cx->blk_oldcop;
6565
6566 va_start(args, pat);
6567 vcroak(pat, &args);
6568 NOT_REACHED; /* NOTREACHED */
6569 va_end(args);
6570 }
6571
6572
PP(pp_aelem)6573 PP(pp_aelem)
6574 {
6575 SV** svp;
6576 SV* const elemsv = PL_stack_sp[0];
6577 IV elem = SvIV(elemsv);
6578 AV *const av = MUTABLE_AV(PL_stack_sp[-1]);
6579 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
6580 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
6581 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6582 bool preeminent = TRUE;
6583 SV *sv;
6584 SV *retsv;
6585
6586 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
6587 Perl_warner(aTHX_ packWARN(WARN_MISC),
6588 "Use of reference \"%" SVf "\" as array index",
6589 SVfARG(elemsv));
6590 if (UNLIKELY(SvTYPE(av) != SVt_PVAV)) {
6591 retsv = &PL_sv_undef;
6592 goto ret;
6593 }
6594
6595 if (UNLIKELY(localizing)) {
6596 MAGIC *mg;
6597 HV *stash;
6598
6599 /* Try to preserve the existence of a tied array
6600 * element by using EXISTS and DELETE if possible.
6601 * Fall back to FETCH and STORE otherwise. */
6602 if (SvCANEXISTDELETE(av))
6603 preeminent = av_exists(av, elem);
6604 }
6605
6606 svp = av_fetch(av, elem, lval && !defer);
6607 if (lval) {
6608 #ifdef PERL_MALLOC_WRAP
6609 if (SvUOK(elemsv)) {
6610 const UV uv = SvUV(elemsv);
6611 elem = uv > IV_MAX ? IV_MAX : uv;
6612 }
6613 else if (SvNOK(elemsv))
6614 elem = (IV)SvNV(elemsv);
6615 if (elem > 0) {
6616 MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend");
6617 }
6618 #endif
6619 if (!svp || !*svp) {
6620 IV len;
6621 if (!defer)
6622 DIE(aTHX_ PL_no_aelem, elem);
6623 len = av_top_index(av);
6624 /* Resolve a negative index that falls within the array. Leave
6625 it negative it if falls outside the array. */
6626 if (elem < 0 && len + elem >= 0)
6627 elem = len + elem;
6628 if (elem >= 0 && elem <= len)
6629 /* Falls within the array. */
6630 retsv = av_nonelem(av, elem);
6631 else
6632 /* Falls outside the array. If it is negative,
6633 magic_setdefelem will use the index for error reporting.
6634 */
6635 retsv = sv_2mortal(newSVavdefelem(av, elem, 1));
6636 goto ret;
6637 }
6638 if (UNLIKELY(localizing)) {
6639 if (preeminent)
6640 save_aelem(av, elem, svp);
6641 else
6642 SAVEADELETE(av, elem);
6643 }
6644 else if (PL_op->op_private & OPpDEREF) {
6645 retsv = vivify_ref(*svp, PL_op->op_private & OPpDEREF);
6646 goto ret;
6647 }
6648 }
6649 sv = (svp ? *svp : &PL_sv_undef);
6650 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
6651 mg_get(sv);
6652 retsv = sv;
6653
6654 ret:
6655 rpp_replace_2_1_NN(retsv);
6656 return NORMAL;
6657 }
6658
6659 SV*
Perl_vivify_ref(pTHX_ SV * sv,U32 to_what)6660 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
6661 {
6662 PERL_ARGS_ASSERT_VIVIFY_REF;
6663
6664 SvGETMAGIC(sv);
6665 if (!SvOK(sv)) {
6666 if (SvREADONLY(sv))
6667 Perl_croak_no_modify();
6668 prepare_SV_for_RV(sv);
6669 switch (to_what) {
6670 case OPpDEREF_SV:
6671 SvRV_set(sv, newSV_type(SVt_NULL));
6672 break;
6673 case OPpDEREF_AV:
6674 SvRV_set(sv, MUTABLE_SV(newAV()));
6675 break;
6676 case OPpDEREF_HV:
6677 SvRV_set(sv, MUTABLE_SV(newHV()));
6678 break;
6679 }
6680 SvROK_on(sv);
6681 SvSETMAGIC(sv);
6682 SvGETMAGIC(sv);
6683 }
6684 if (SvGMAGICAL(sv)) {
6685 /* copy the sv without magic to prevent magic from being
6686 executed twice */
6687 SV* msv = sv_newmortal();
6688 sv_setsv_nomg(msv, sv);
6689 return msv;
6690 }
6691 return sv;
6692 }
6693
6694 PERL_STATIC_INLINE HV *
S_opmethod_stash(pTHX_ SV * meth)6695 S_opmethod_stash(pTHX_ SV* meth)
6696 {
6697 SV* ob;
6698 HV* stash;
6699
6700 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
6701 ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a "
6702 "package or object reference", SVfARG(meth)),
6703 (SV *)NULL)
6704 : *(PL_stack_base + TOPMARK + 1);
6705
6706 PERL_ARGS_ASSERT_OPMETHOD_STASH;
6707
6708 if (UNLIKELY(!sv))
6709 undefined:
6710 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value",
6711 SVfARG(meth));
6712
6713 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
6714 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
6715 stash = gv_stashsv(sv, GV_CACHE_ONLY);
6716 if (stash) return stash;
6717 }
6718
6719 if (SvROK(sv))
6720 ob = MUTABLE_SV(SvRV(sv));
6721 else if (!SvOK(sv)) goto undefined;
6722 else if (isGV_with_GP(sv)) {
6723 if (!GvIO(sv))
6724 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
6725 "without a package or object reference",
6726 SVfARG(meth));
6727 ob = sv;
6728 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
6729 assert(!LvTARGLEN(ob));
6730 ob = LvTARG(ob);
6731 assert(ob);
6732 }
6733 /* Replace the object at the base of the stack frame.
6734 * This is "below" whatever pp_wrap has wrapped, so needs freeing.
6735 */
6736 SV *newsv = sv_2mortal(newRV(ob));
6737 SV **svp = (PL_stack_base + TOPMARK + 1);
6738 #ifdef PERL_RC_STACK
6739 SV *oldsv = *svp;
6740 #endif
6741 *svp = newsv;
6742 #ifdef PERL_RC_STACK
6743 SvREFCNT_inc_simple_void_NN(newsv);
6744 SvREFCNT_dec_NN(oldsv);
6745 #endif
6746 }
6747 else {
6748 /* this isn't a reference */
6749 GV* iogv;
6750 STRLEN packlen;
6751 const char * const packname = SvPV_nomg_const(sv, packlen);
6752 const U32 packname_utf8 = SvUTF8(sv);
6753 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
6754 if (stash) return stash;
6755
6756 if ((PL_op->op_private & OPpMETH_NO_BAREWORD_IO) ||
6757 !(iogv = gv_fetchpvn_flags(
6758 packname, packlen, packname_utf8, SVt_PVIO
6759 )) ||
6760 !(ob=MUTABLE_SV(GvIO(iogv))))
6761 {
6762 /* this isn't the name of a filehandle either */
6763 if (!packlen)
6764 {
6765 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
6766 "without a package or object reference",
6767 SVfARG(meth));
6768 }
6769 /* assume it's a package name */
6770 stash = gv_stashpvn(packname, packlen, packname_utf8);
6771 if (stash) return stash;
6772 else return MUTABLE_HV(sv);
6773 }
6774 /* it _is_ a filehandle name -- replace with a reference.
6775 * Replace the object at the base of the stack frame.
6776 * This is "below" whatever pp_wrap has wrapped, so needs freeing.
6777 */
6778 SV *newsv = sv_2mortal(newRV(MUTABLE_SV(iogv)));
6779 SV **svp = (PL_stack_base + TOPMARK + 1);
6780 #ifdef PERL_RC_STACK
6781 SV *oldsv = *svp;
6782 #endif
6783 *svp = newsv;
6784 #ifdef PERL_RC_STACK
6785 SvREFCNT_inc_simple_void_NN(newsv);
6786 SvREFCNT_dec_NN(oldsv);
6787 #endif
6788 }
6789
6790 /* if we got here, ob should be an object or a glob */
6791 if (!ob || !(SvOBJECT(ob)
6792 || (isGV_with_GP(ob)
6793 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
6794 && SvOBJECT(ob))))
6795 {
6796 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference",
6797 SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES)
6798 ? newSVpvs_flags("DOES", SVs_TEMP)
6799 : meth));
6800 }
6801
6802 return SvSTASH(ob);
6803 }
6804
PP(pp_method)6805 PP(pp_method)
6806 {
6807 GV* gv;
6808 HV* stash;
6809 SV* const meth = *PL_stack_sp;
6810
6811 if (SvROK(meth)) {
6812 SV* const rmeth = SvRV(meth);
6813 if (SvTYPE(rmeth) == SVt_PVCV) {
6814 rpp_replace_1_1_NN(rmeth);
6815 return NORMAL;
6816 }
6817 }
6818
6819 stash = opmethod_stash(meth);
6820
6821 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
6822 assert(gv);
6823
6824 rpp_replace_1_1_NN(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6825 return NORMAL;
6826 }
6827
6828 #define METHOD_CHECK_CACHE(stash,cache,meth) \
6829 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
6830 if (he) { \
6831 gv = MUTABLE_GV(HeVAL(he)); \
6832 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
6833 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
6834 { \
6835 rpp_xpush_1(MUTABLE_SV(GvCV(gv))); \
6836 return NORMAL; \
6837 } \
6838 } \
6839
PP(pp_method_named)6840 PP(pp_method_named)
6841 {
6842 GV* gv;
6843 SV* const meth = cMETHOP_meth;
6844 HV* const stash = opmethod_stash(meth);
6845
6846 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
6847 METHOD_CHECK_CACHE(stash, stash, meth);
6848 }
6849
6850 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
6851 assert(gv);
6852
6853 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6854 return NORMAL;
6855 }
6856
PP(pp_method_super)6857 PP(pp_method_super)
6858 {
6859 GV* gv;
6860 HV* cache;
6861 SV* const meth = cMETHOP_meth;
6862 HV* const stash = CopSTASH(PL_curcop);
6863 /* Actually, SUPER doesn't need real object's (or class') stash at all,
6864 * as it uses CopSTASH. However, we must ensure that object(class) is
6865 * correct (this check is done by S_opmethod_stash) */
6866 opmethod_stash(meth);
6867
6868 if ((cache = HvMROMETA(stash)->super)) {
6869 METHOD_CHECK_CACHE(stash, cache, meth);
6870 }
6871
6872 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
6873 assert(gv);
6874
6875 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6876 return NORMAL;
6877 }
6878
PP(pp_method_redir)6879 PP(pp_method_redir)
6880 {
6881 GV* gv;
6882 SV* const meth = cMETHOP_meth;
6883 HV* stash = gv_stashsv(cMETHOP_rclass, 0);
6884 opmethod_stash(meth); /* not used but needed for error checks */
6885
6886 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
6887 else stash = MUTABLE_HV(cMETHOP_rclass);
6888
6889 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
6890 assert(gv);
6891
6892 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6893 return NORMAL;
6894 }
6895
PP(pp_method_redir_super)6896 PP(pp_method_redir_super)
6897 {
6898 GV* gv;
6899 HV* cache;
6900 SV* const meth = cMETHOP_meth;
6901 HV* stash = gv_stashsv(cMETHOP_rclass, 0);
6902 opmethod_stash(meth); /* not used but needed for error checks */
6903
6904 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOP_rclass);
6905 else if ((cache = HvMROMETA(stash)->super)) {
6906 METHOD_CHECK_CACHE(stash, cache, meth);
6907 }
6908
6909 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
6910 assert(gv);
6911
6912 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6913 return NORMAL;
6914 }
6915
6916 /*
6917 * ex: set ts=8 sts=4 sw=4 et:
6918 */
6919