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