| CARVIEW |
Select Language
HTTP/2 302
server: nginx
date: Thu, 31 Jul 2025 07:50:16 GMT
content-type: text/plain; charset=utf-8
content-length: 0
x-archive-redirect-reason: found capture at 20210116114752
location: https://web.archive.org/web/20210116114752/https://perl5.git.perl.org/perl5.git/blob/HEAD:/pp_hot.c
server-timing: captures_list;dur=0.549521, exclusion.robots;dur=0.017220, exclusion.robots.policy;dur=0.007588, esindex;dur=0.013560, cdx.remote;dur=35.689251, LoadShardBlock;dur=386.202166, PetaboxLoader3.datanode;dur=115.314722, PetaboxLoader3.resolve;dur=103.946464
x-app-server: wwwb-app216
x-ts: 302
x-tr: 460
server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0
set-cookie: SERVER=wwwb-app216; path=/
x-location: All
x-rl: 0
x-na: 0
x-page-cache: MISS
server-timing: MISS
x-nid: DigitalOcean
referrer-policy: no-referrer-when-downgrade
permissions-policy: interest-cohort=()
HTTP/2 200
server: nginx
date: Thu, 31 Jul 2025 07:50:20 GMT
content-type: application/xhtml+xml; charset=utf-8
x-archive-orig-date: Sat, 16 Jan 2021 11:47:51 GMT
x-archive-orig-server: Apache/2.4.6 (CentOS) OpenSSL/1.0.2k-fips
x-archive-orig-keep-alive: timeout=5, max=100
x-archive-orig-connection: Keep-Alive
x-archive-orig-x-crawler-transfer-encoding: chunked
x-archive-orig-content-length: 1048576
x-archive-guessed-content-type: text/html
x-archive-guessed-charset: utf-8
memento-datetime: Sat, 16 Jan 2021 11:47:52 GMT
link: ; rel="original", ; rel="timemap"; type="application/link-format", ; rel="timegate", ; rel="first memento"; datetime="Sat, 16 Jan 2021 11:47:52 GMT", ; rel="memento"; datetime="Sat, 16 Jan 2021 11:47:52 GMT", ; rel="last memento"; datetime="Sat, 16 Jan 2021 11:47:52 GMT"
content-security-policy: default-src 'self' 'unsafe-eval' 'unsafe-inline' data: blob: archive.org web.archive.org web-static.archive.org wayback-api.archive.org athena.archive.org analytics.archive.org pragma.archivelab.org wwwb-events.archive.org
x-archive-src: CC-MAIN-2021-04-1610703506640.22-0007/CC-MAIN-20210116104719-20210116134719-00143.warc.gz
server-timing: captures_list;dur=1.140844, exclusion.robots;dur=0.026667, exclusion.robots.policy;dur=0.011878, esindex;dur=0.023257, cdx.remote;dur=30.641269, LoadShardBlock;dur=294.308685, PetaboxLoader3.datanode;dur=395.193968, PetaboxLoader3.resolve;dur=200.473914, load_resource;dur=452.350419
x-app-server: wwwb-app216
x-ts: 200
x-tr: 3387
server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0
x-location: All
x-rl: 0
x-na: 0
x-page-cache: MISS
server-timing: MISS
x-nid: DigitalOcean
referrer-policy: no-referrer-when-downgrade
permissions-policy: interest-cohort=()
perl5.git.perl.org Git - perl5.git/blob - pp_hot.c
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 */
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 */
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 */
34 #include "EXTERN.h"
35 #define PERL_IN_PP_HOT_C
36 #include "perl.h"
37 #include "regcomp.h"
39 /* Hot code. */
41 PP(pp_const)
42 {
43 dSP;
44 XPUSHs(cSVOP_sv);
45 RETURN;
46 }
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 }
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 }
70 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
72 PP(pp_null)
73 {
74 return NORMAL;
75 }
77 /* This is sometimes called directly by pp_coreargs, pp_grepstart and
78 amagic_call. */
79 PP(pp_pushmark)
80 {
81 PUSHMARK(PL_stack_sp);
82 return NORMAL;
83 }
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 }
96 PP(pp_gv)
97 {
98 dSP;
99 XPUSHs(MUTABLE_SV(cGVOP_gv));
100 RETURN;
101 }
104 /* also used for: pp_andassign() */
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 }
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;
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;
148 if (!got_coderef) {
149 assert(SvROK(cv));
150 }
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);
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 }
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 }
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
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);
210 assert(source);
211 assert(CvFLAGS(source) & CVf_CONST);
213 SvREFCNT_inc_simple_void_NN(source);
214 SvREFCNT_dec_NN(upgraded);
215 SvRV_set(right, MUTABLE_SV(source));
216 }
217 }
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 }
232 PP(pp_cond_expr)
233 {
234 dSP;
235 SV *sv;
237 PERL_ASYNC_CHECK();
238 sv = POPs;
239 RETURNOP(SvTRUE_NN(sv) ? cLOGOP->op_other : cLOGOP->op_next);
240 }
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 }
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 */
265 PERL_STATIC_INLINE void
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;
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 }
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 }
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 }
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 }
340 /* pp_multiconcat()
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.
346 Several op_flags and/or op_private bits indicate what the target is, and
347 whether it's appended to. Valid permutations are:
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....)
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.
359 In addition:
361 OPpMULTICONCAT_FAKE: not a real concat, instead an optimised
362 sprintf "...%s...". Don't call '.'
363 overloading: only use '""' overloading.
365 OPpMULTICONCAT_STRINGIFY: the RHS was of the form
366 "...$a...$b..." rather than
367 "..." . $a . "..." . $b . "..."
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:
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
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"
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.
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.
397 */
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 */
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);
433 /* get targ from the stack or pad */
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 }
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;
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 */
485 for (; SP <= toparg; SP++, svpv_end++) {
486 U32 utf8;
487 STRLEN len;
488 SV *sv;
490 assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
492 sv = *SP;
494 /* this if/else chain is arranged so that common/simple cases
495 * take few conditionals */
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 }
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 */
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 }
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 */
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;
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;
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;
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);
612 phase3:
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 */
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 }
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 }
677 const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
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;
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;
696 len = svpv_p->len;
697 if (len <= 0) {
698 svpv_p->len = -len;
699 continue;
700 }
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;
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));
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 */
753 svpv_base = svpv_buf;
755 if (targ_len) {
756 struct multiconcat_svpv *tc_stop;
757 char *targ_buf = targ_pv; /* ptr to original targ string */
759 assert(is_append || targ_count);
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 */
774 UNOP_AUX_item *lens = const_lens;
775 /* length of first const string segment */
776 STRLEN offset = lens->ssize > 0 ? lens->ssize : 0;
778 assert(targ_chain);
779 svpv_p = svpv_base;
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 }
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 }
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 }
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 }
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 */
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;
866 for (;;) {
867 SSize_t len = (const_lens++)->ssize;
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 }
876 if (++svpv_p == svpv_end)
877 break;
879 /* append next arg */
880 len = svpv_p->len;
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 }
904 }
905 }
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);
912 /* --------------------------------------------------------------
913 * Phase 6:
914 *
915 * return result
916 */
918 SP -= stack_adj;
919 SvTAINT(targ);
920 SETTARG;
921 RETURN;
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 */
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 */
954 if (!cpv) {
955 cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
956 utf8 = SVf_UTF8;
957 }
959 svp = toparg - nargs + 1;
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 */
967 n = nargs *2 + 1;
968 for (i = 0; i <= n; i++) {
969 SSize_t len;
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 }
1000 /* do one extra iteration to handle $targ in $targ .= ... */
1001 if (i == n && !is_append)
1002 break;
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 }
1020 arg_count++;
1022 if (arg_count <= 1) {
1023 left = right;
1024 continue; /* need at least two SVs to concat together */
1025 }
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 }
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 */
1048 if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) {
1049 SvGETMAGIC(left);
1050 if (left != right)
1051 SvGETMAGIC(right);
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 }
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_setsv_flags(left, &PL_sv_no, 0);
1087 }
1088 else
1089 sv_setsv_flags(left, right, 0);
1090 SvGETMAGIC(right);
1091 }
1092 }
1094 /* nexttarg = left . right */
1095 S_do_concat(aTHX_ left, right, nexttarg, 0);
1096 left = nexttarg;
1097 }
1099 SP = toparg - stack_adj + 1;
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 }
1121 /* push the elements of av onto the stack.
1122 * Returns PL_op->op_next to allow tail-call optimisation of its callers */
1124 STATIC OP*
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 }
1158 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
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 }
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;
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;
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 }
1198 for (i = 0; i <count; i++)
1199 SvPADSTALE_off(*svp++); /* mark lexical as active */
1200 }
1201 RETURN;
1202 }
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 }
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 }
1261 PP(pp_eq)
1262 {
1263 dSP;
1264 SV *left, *right;
1265 U32 flags_and, flags_or;
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);
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 }
1284 /* also used for: pp_i_preinc() */
1286 PP(pp_preinc)
1287 {
1288 SV *sv = *PL_stack_sp;
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 }
1305 /* also used for: pp_i_predec() */
1307 PP(pp_predec)
1308 {
1309 SV *sv = *PL_stack_sp;
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 }
1326 /* also used for: pp_orassign() */
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 }
1344 /* also used for: pp_dor() pp_dorassign() */
1346 PP(pp_defined)
1347 {
1348 dSP;
1349 SV* sv;
1350 bool defined;
1351 const int op_type = PL_op->op_type;
1352 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
1354 if (is_dor) {
1355 PERL_ASYNC_CHECK();
1356 sv = TOPs;
1357 if (UNLIKELY(!sv || !SvANY(sv))) {
1358 if (op_type == OP_DOR)
1359 --SP;
1360 RETURNOP(cLOGOP->op_other);
1361 }
1362 }
1363 else {
1364 /* OP_DEFINED */
1365 sv = POPs;
1366 if (UNLIKELY(!sv || !SvANY(sv)))
1367 RETPUSHNO;
1368 }
1370 defined = FALSE;
1371 switch (SvTYPE(sv)) {
1372 case SVt_PVAV:
1373 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1374 defined = TRUE;
1375 break;
1376 case SVt_PVHV:
1377 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1378 defined = TRUE;
1379 break;
1380 case SVt_PVCV:
1381 if (CvROOT(sv) || CvXSUB(sv))
1382 defined = TRUE;
1383 break;
1384 default:
1385 SvGETMAGIC(sv);
1386 if (SvOK(sv))
1387 defined = TRUE;
1388 break;
1389 }
1391 if (is_dor) {
1392 if(defined)
1393 RETURN;
1394 if(op_type == OP_DOR)
1395 --SP;
1396 RETURNOP(cLOGOP->op_other);
1397 }
1398 /* assuming OP_DEFINED */
1399 if(defined)
1400 RETPUSHYES;
1401 RETPUSHNO;
1402 }
1406 PP(pp_add)
1407 {
1408 dSP; dATARGET; bool useleft; SV *svl, *svr;
1410 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
1411 svr = TOPs;
1412 svl = TOPm1s;
1414 #ifdef PERL_PRESERVE_IVUV
1416 /* special-case some simple common cases */
1417 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1418 IV il, ir;
1419 U32 flags = (svl->sv_flags & svr->sv_flags);
1420 if (flags & SVf_IOK) {
1421 /* both args are simple IVs */
1422 UV topl, topr;
1423 il = SvIVX(svl);
1424 ir = SvIVX(svr);
1425 do_iv:
1426 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1427 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1429 /* if both are in a range that can't under/overflow, do a
1430 * simple integer add: if the top of both numbers
1431 * are 00 or 11, then it's safe */
1432 if (!( ((topl+1) | (topr+1)) & 2)) {
1433 SP--;
1434 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1435 SETs(TARG);
1436 RETURN;
1437 }
1438 goto generic;
1439 }
1440 else if (flags & SVf_NOK) {
1441 /* both args are NVs */
1442 NV nl = SvNVX(svl);
1443 NV nr = SvNVX(svr);
1445 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1446 /* nothing was lost by converting to IVs */
1447 goto do_iv;
1448 }
1449 SP--;
1450 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1451 SETs(TARG);
1452 RETURN;
1453 }
1454 }
1456 generic:
1458 useleft = USE_LEFT(svl);
1459 /* We must see if we can perform the addition with integers if possible,
1460 as the integer code detects overflow while the NV code doesn't.
1461 If either argument hasn't had a numeric conversion yet attempt to get
1462 the IV. It's important to do this now, rather than just assuming that
1463 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1464 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1465 integer in case the second argument is IV=9223372036854775806
1466 We can (now) rely on sv_2iv to do the right thing, only setting the
1467 public IOK flag if the value in the NV (or PV) slot is truly integer.
1469 A side effect is that this also aggressively prefers integer maths over
1470 fp maths for integer values.
1472 How to detect overflow?
1474 C 99 section 6.2.6.1 says
1476 The range of nonnegative values of a signed integer type is a subrange
1477 of the corresponding unsigned integer type, and the representation of
1478 the same value in each type is the same. A computation involving
1479 unsigned operands can never overflow, because a result that cannot be
1480 represented by the resulting unsigned integer type is reduced modulo
1481 the number that is one greater than the largest value that can be
1482 represented by the resulting type.
1484 (the 9th paragraph)
1486 which I read as "unsigned ints wrap."
1488 signed integer overflow seems to be classed as "exception condition"
1490 If an exceptional condition occurs during the evaluation of an
1491 expression (that is, if the result is not mathematically defined or not
1492 in the range of representable values for its type), the behavior is
1493 undefined.
1495 (6.5, the 5th paragraph)
1497 I had assumed that on 2s complement machines signed arithmetic would
1498 wrap, hence coded pp_add and pp_subtract on the assumption that
1499 everything perl builds on would be happy. After much wailing and
1500 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1501 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
1502 unsigned code below is actually shorter than the old code. :-)
1503 */
1505 if (SvIV_please_nomg(svr)) {
1506 /* Unless the left argument is integer in range we are going to have to
1507 use NV maths. Hence only attempt to coerce the right argument if
1508 we know the left is integer. */
1509 UV auv = 0;
1510 bool auvok = FALSE;
1511 bool a_valid = 0;
1513 if (!useleft) {
1514 auv = 0;
1515 a_valid = auvok = 1;
1516 /* left operand is undef, treat as zero. + 0 is identity,
1517 Could SETi or SETu right now, but space optimise by not adding
1518 lots of code to speed up what is probably a rarish case. */
1519 } else {
1520 /* Left operand is defined, so is it IV? */
1521 if (SvIV_please_nomg(svl)) {
1522 if ((auvok = SvUOK(svl)))
1523 auv = SvUVX(svl);
1524 else {
1525 const IV aiv = SvIVX(svl);
1526 if (aiv >= 0) {
1527 auv = aiv;
1528 auvok = 1; /* Now acting as a sign flag. */
1529 } else {
1530 /* Using 0- here and later to silence bogus warning
1531 * from MS VC */
1532 auv = (UV) (0 - (UV) aiv);
1533 }
1534 }
1535 a_valid = 1;
1536 }
1537 }
1538 if (a_valid) {
1539 bool result_good = 0;
1540 UV result;
1541 UV buv;
1542 bool buvok = SvUOK(svr);
1544 if (buvok)
1545 buv = SvUVX(svr);
1546 else {
1547 const IV biv = SvIVX(svr);
1548 if (biv >= 0) {
1549 buv = biv;
1550 buvok = 1;
1551 } else
1552 buv = (UV) (0 - (UV) biv);
1553 }
1554 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1555 else "IV" now, independent of how it came in.
1556 if a, b represents positive, A, B negative, a maps to -A etc
1557 a + b => (a + b)
1558 A + b => -(a - b)
1559 a + B => (a - b)
1560 A + B => -(a + b)
1561 all UV maths. negate result if A negative.
1562 add if signs same, subtract if signs differ. */
1564 if (auvok ^ buvok) {
1565 /* Signs differ. */
1566 if (auv >= buv) {
1567 result = auv - buv;
1568 /* Must get smaller */
1569 if (result <= auv)
1570 result_good = 1;
1571 } else {
1572 result = buv - auv;
1573 if (result <= buv) {
1574 /* result really should be -(auv-buv). as its negation
1575 of true value, need to swap our result flag */
1576 auvok = !auvok;
1577 result_good = 1;
1578 }
1579 }
1580 } else {
1581 /* Signs same */
1582 result = auv + buv;
1583 if (result >= auv)
1584 result_good = 1;
1585 }
1586 if (result_good) {
1587 SP--;
1588 if (auvok)
1589 SETu( result );
1590 else {
1591 /* Negate result */
1592 if (result <= (UV)IV_MIN)
1593 SETi(result == (UV)IV_MIN
1594 ? IV_MIN : -(IV)result);
1595 else {
1596 /* result valid, but out of range for IV. */
1597 SETn( -(NV)result );
1598 }
1599 }
1600 RETURN;
1601 } /* Overflow, drop through to NVs. */
1602 }
1603 }
1605 #else
1606 useleft = USE_LEFT(svl);
1607 #endif
1609 {
1610 NV value = SvNV_nomg(svr);
1611 (void)POPs;
1612 if (!useleft) {
1613 /* left operand is undef, treat as zero. + 0.0 is identity. */
1614 SETn(value);
1615 RETURN;
1616 }
1617 SETn( value + SvNV_nomg(svl) );
1618 RETURN;
1619 }
1620 }
1623 /* also used for: pp_aelemfast_lex() */
1625 PP(pp_aelemfast)
1626 {
1627 dSP;
1628 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
1629 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
1630 const U32 lval = PL_op->op_flags & OPf_MOD;
1631 const I8 key = (I8)PL_op->op_private;
1632 SV** svp;
1633 SV *sv;
1635 assert(SvTYPE(av) == SVt_PVAV);
1637 EXTEND(SP, 1);
1639 /* inlined av_fetch() for simple cases ... */
1640 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1641 sv = AvARRAY(av)[key];
1642 if (sv) {
1643 PUSHs(sv);
1644 RETURN;
1645 }
1646 }
1648 /* ... else do it the hard way */
1649 svp = av_fetch(av, key, lval);
1650 sv = (svp ? *svp : &PL_sv_undef);
1652 if (UNLIKELY(!svp && lval))
1653 DIE(aTHX_ PL_no_aelem, (int)key);
1655 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
1656 mg_get(sv);
1657 PUSHs(sv);
1658 RETURN;
1659 }
1661 PP(pp_join)
1662 {
1663 dSP; dMARK; dTARGET;
1664 MARK++;
1665 do_join(TARG, *MARK, MARK, SP);
1666 SP = MARK;
1667 SETs(TARG);
1668 RETURN;
1669 }
1671 /* Oversized hot code. */
1673 /* also used for: pp_say() */
1675 PP(pp_print)
1676 {
1677 dSP; dMARK; dORIGMARK;
1678 PerlIO *fp;
1679 MAGIC *mg;
1680 GV * const gv
1681 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1682 IO *io = GvIO(gv);
1684 if (io
1685 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1686 {
1687 had_magic:
1688 if (MARK == ORIGMARK) {
1689 /* If using default handle then we need to make space to
1690 * pass object as 1st arg, so move other args up ...
1691 */
1692 MEXTEND(SP, 1);
1693 ++MARK;
1694 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1695 ++SP;
1696 }
1697 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
1698 mg,
1699 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1700 | (PL_op->op_type == OP_SAY
1701 ? TIED_METHOD_SAY : 0)), sp - mark);
1702 }
1703 if (!io) {
1704 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
1705 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1706 goto had_magic;
1707 report_evil_fh(gv);
1708 SETERRNO(EBADF,RMS_IFI);
1709 goto just_say_no;
1710 }
1711 else if (!(fp = IoOFP(io))) {
1712 if (IoIFP(io))
1713 report_wrongway_fh(gv, '<');
1714 else
1715 report_evil_fh(gv);
1716 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1717 goto just_say_no;
1718 }
1719 else {
1720 SV * const ofs = GvSV(PL_ofsgv); /* $, */
1721 MARK++;
1722 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
1723 while (MARK <= SP) {
1724 if (!do_print(*MARK, fp))
1725 break;
1726 MARK++;
1727 if (MARK <= SP) {
1728 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
1729 if (!do_print(GvSV(PL_ofsgv), fp)) {
1730 MARK--;
1731 break;
1732 }
1733 }
1734 }
1735 }
1736 else {
1737 while (MARK <= SP) {
1738 if (!do_print(*MARK, fp))
1739 break;
1740 MARK++;
1741 }
1742 }
1743 if (MARK <= SP)
1744 goto just_say_no;
1745 else {
1746 if (PL_op->op_type == OP_SAY) {
1747 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
1748 goto just_say_no;
1749 }
1750 else if (PL_ors_sv && SvOK(PL_ors_sv))
1751 if (!do_print(PL_ors_sv, fp)) /* $\ */
1752 goto just_say_no;
1754 if (IoFLAGS(io) & IOf_FLUSH)
1755 if (PerlIO_flush(fp) == EOF)
1756 goto just_say_no;
1757 }
1758 }
1759 SP = ORIGMARK;
1760 XPUSHs(&PL_sv_yes);
1761 RETURN;
1763 just_say_no:
1764 SP = ORIGMARK;
1765 XPUSHs(&PL_sv_undef);
1766 RETURN;
1767 }
1770 /* do the common parts of pp_padhv() and pp_rv2hv()
1771 * It assumes the caller has done EXTEND(SP, 1) or equivalent.
1772 * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
1773 * 'has_targ' indicates that the op has a target - this should
1774 * be a compile-time constant so that the code can constant-folded as
1775 * appropriate
1776 * */
1778 PERL_STATIC_INLINE OP*
1779 S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
1780 {
1781 bool is_tied;
1782 bool is_bool;
1783 MAGIC *mg;
1784 dSP;
1785 IV i;
1786 SV *sv;
1788 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
1790 if (gimme == G_ARRAY) {
1791 hv_pushkv(hv, 3);
1792 return NORMAL;
1793 }
1795 if (is_keys)
1796 /* 'keys %h' masquerading as '%h': reset iterator */
1797 (void)hv_iterinit(hv);
1799 if (gimme == G_VOID)
1800 return NORMAL;
1802 is_bool = ( PL_op->op_private & OPpTRUEBOOL
1803 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
1804 && block_gimme() == G_VOID));
1805 is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
1807 if (UNLIKELY(is_tied)) {
1808 if (is_keys && !is_bool) {
1809 i = 0;
1810 while (hv_iternext(hv))
1811 i++;
1812 goto push_i;
1813 }
1814 else {
1815 sv = magic_scalarpack(hv, mg);
1816 goto push_sv;
1817 }
1818 }
1819 else {
1820 i = HvUSEDKEYS(hv);
1821 if (is_bool) {
1822 sv = i ? &PL_sv_yes : &PL_sv_zero;
1823 push_sv:
1824 PUSHs(sv);
1825 }
1826 else {
1827 push_i:
1828 if (has_targ) {
1829 dTARGET;
1830 PUSHi(i);
1831 }
1832 else
1833 if (is_keys) {
1834 /* parent op should be an unused OP_KEYS whose targ we can
1835 * use */
1836 dTARG;
1837 OP *k;
1839 assert(!OpHAS_SIBLING(PL_op));
1840 k = PL_op->op_sibparent;
1841 assert(k->op_type == OP_KEYS);
1842 TARG = PAD_SV(k->op_targ);
1843 PUSHi(i);
1844 }
1845 else
1846 mPUSHi(i);
1847 }
1848 }
1850 PUTBACK;
1851 return NORMAL;
1852 }
1855 /* This is also called directly by pp_lvavref. */
1856 PP(pp_padav)
1857 {
1858 dSP; dTARGET;
1859 U8 gimme;
1860 assert(SvTYPE(TARG) == SVt_PVAV);
1861 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1862 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1863 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1864 EXTEND(SP, 1);
1866 if (PL_op->op_flags & OPf_REF) {
1867 PUSHs(TARG);
1868 RETURN;
1869 }
1870 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1871 const I32 flags = is_lvalue_sub();
1872 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1873 if (GIMME_V == G_SCALAR)
1874 /* diag_listed_as: Can't return %s to lvalue scalar context */
1875 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1876 PUSHs(TARG);
1877 RETURN;
1878 }
1879 }
1881 gimme = GIMME_V;
1882 if (gimme == G_ARRAY)
1883 return S_pushav(aTHX_ (AV*)TARG);
1885 if (gimme == G_SCALAR) {
1886 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
1887 if (!maxarg)
1888 PUSHs(&PL_sv_zero);
1889 else if (PL_op->op_private & OPpTRUEBOOL)
1890 PUSHs(&PL_sv_yes);
1891 else
1892 mPUSHi(maxarg);
1893 }
1894 RETURN;
1895 }
1898 PP(pp_padhv)
1899 {
1900 dSP; dTARGET;
1901 U8 gimme;
1903 assert(SvTYPE(TARG) == SVt_PVHV);
1904 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1905 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1906 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1908 EXTEND(SP, 1);
1910 if (PL_op->op_flags & OPf_REF) {
1911 PUSHs(TARG);
1912 RETURN;
1913 }
1914 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1915 const I32 flags = is_lvalue_sub();
1916 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1917 if (GIMME_V == G_SCALAR)
1918 /* diag_listed_as: Can't return %s to lvalue scalar context */
1919 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
1920 PUSHs(TARG);
1921 RETURN;
1922 }
1923 }
1925 gimme = GIMME_V;
1927 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
1928 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
1929 0 /* has_targ*/);
1930 }
1933 /* also used for: pp_rv2hv() */
1934 /* also called directly by pp_lvavref */
1936 PP(pp_rv2av)
1937 {
1938 dSP; dTOPss;
1939 const U8 gimme = GIMME_V;
1940 static const char an_array[] = "an ARRAY";
1941 static const char a_hash[] = "a HASH";
1942 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
1943 || PL_op->op_type == OP_LVAVREF;
1944 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
1946 SvGETMAGIC(sv);
1947 if (SvROK(sv)) {
1948 if (UNLIKELY(SvAMAGIC(sv))) {
1949 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
1950 }
1951 sv = SvRV(sv);
1952 if (UNLIKELY(SvTYPE(sv) != type))
1953 /* diag_listed_as: Not an ARRAY reference */
1954 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
1955 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
1956 && PL_op->op_private & OPpLVAL_INTRO))
1957 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
1958 }
1959 else if (UNLIKELY(SvTYPE(sv) != type)) {
1960 GV *gv;
1962 if (!isGV_with_GP(sv)) {
1963 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
1964 type, &sp);
1965 if (!gv)
1966 RETURN;
1967 }
1968 else {
1969 gv = MUTABLE_GV(sv);
1970 }
1971 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
1972 if (PL_op->op_private & OPpLVAL_INTRO)
1973 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
1974 }
1975 if (PL_op->op_flags & OPf_REF) {
1976 SETs(sv);
1977 RETURN;
1978 }
1979 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
1980 const I32 flags = is_lvalue_sub();
1981 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1982 if (gimme != G_ARRAY)
1983 goto croak_cant_return;
1984 SETs(sv);
1985 RETURN;
1986 }
1987 }
1989 if (is_pp_rv2av) {
1990 AV *const av = MUTABLE_AV(sv);
1992 if (gimme == G_ARRAY) {
1993 SP--;
1994 PUTBACK;
1995 return S_pushav(aTHX_ av);
1996 }
1998 if (gimme == G_SCALAR) {
1999 const SSize_t maxarg = AvFILL(av) + 1;
2000 if (PL_op->op_private & OPpTRUEBOOL)
2001 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
2002 else {
2003 dTARGET;
2004 SETi(maxarg);
2005 }
2006 }
2007 }
2008 else {
2009 SP--; PUTBACK;
2010 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
2011 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2012 1 /* has_targ*/);
2013 }
2014 RETURN;
2016 croak_cant_return:
2017 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
2018 is_pp_rv2av ? "array" : "hash");
2019 RETURN;
2020 }
2022 STATIC void
2023 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
2024 {
2025 PERL_ARGS_ASSERT_DO_ODDBALL;
2027 if (*oddkey) {
2028 if (ckWARN(WARN_MISC)) {
2029 const char *err;
2030 if (oddkey == firstkey &&
2031 SvROK(*oddkey) &&
2032 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2033 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
2034 {
2035 err = "Reference found where even-sized list expected";
2036 }
2037 else
2038 err = "Odd number of elements in hash assignment";
2039 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
2040 }
2042 }
2043 }
2046 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2047 * are common to both the LHS and RHS of an aassign, and replace them
2048 * with copies. All these copies are made before the actual list assign is
2049 * done.
2050 *
2051 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2052 * element ($b) to the first LH element ($a), modifies $a; when the
2053 * second assignment is done, the second RH element now has the wrong
2054 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
2055 * Note that we don't need to make a mortal copy of $b.
2056 *
2057 * The algorithm below works by, for every RHS element, mark the
2058 * corresponding LHS target element with SVf_BREAK. Then if the RHS
2059 * element is found with SVf_BREAK set, it means it would have been
2060 * modified, so make a copy.
2061 * Note that by scanning both LHS and RHS in lockstep, we avoid
2062 * unnecessary copies (like $b above) compared with a naive
2063 * "mark all LHS; copy all marked RHS; unmark all LHS".
2064 *
2065 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2066 * it can't be common and can be skipped.
2067 *
2068 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2069 * that we thought we didn't need to call S_aassign_copy_common(), but we
2070 * have anyway for sanity checking. If we find we need to copy, then panic.
2071 */
2073 PERL_STATIC_INLINE void
2074 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
2075 SV **firstrelem, SV **lastrelem
2076 #ifdef DEBUGGING
2077 , bool fake
2078 #endif
2079 )
2080 {
2081 SV **relem;
2082 SV **lelem;
2083 SSize_t lcount = lastlelem - firstlelem + 1;
2084 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
2085 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
2086 bool copy_all = FALSE;
2088 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
2089 assert(firstlelem < lastlelem); /* at least 2 LH elements */
2090 assert(firstrelem < lastrelem); /* at least 2 RH elements */
2093 lelem = firstlelem;
2094 /* we never have to copy the first RH element; it can't be corrupted
2095 * by assigning something to the corresponding first LH element.
2096 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
2097 */
2098 relem = firstrelem + 1;
2100 for (; relem <= lastrelem; relem++) {
2101 SV *svr;
2103 /* mark next LH element */
2105 if (--lcount >= 0) {
2106 SV *svl = *lelem++;
2108 if (UNLIKELY(!svl)) {/* skip AV alias marker */
2109 assert (lelem <= lastlelem);
2110 svl = *lelem++;
2111 lcount--;
2112 }
2114 assert(svl);
2115 if (SvSMAGICAL(svl)) {
2116 copy_all = TRUE;
2117 }
2118 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
2119 if (!marked)
2120 return;
2121 /* this LH element will consume all further args;
2122 * no need to mark any further LH elements (if any).
2123 * But we still need to scan any remaining RHS elements;
2124 * set lcount negative to distinguish from lcount == 0,
2125 * so the loop condition continues being true
2126 */
2127 lcount = -1;
2128 lelem--; /* no need to unmark this element */
2129 }
2130 else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
2131 SvFLAGS(svl) |= SVf_BREAK;
2132 marked = TRUE;
2133 }
2134 else if (!marked) {
2135 /* don't check RH element if no SVf_BREAK flags set yet */
2136 if (!lcount)
2137 break;
2138 continue;
2139 }
2140 }
2142 /* see if corresponding RH element needs copying */
2144 assert(marked);
2145 svr = *relem;
2146 assert(svr);
2148 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
2149 U32 brk = (SvFLAGS(svr) & SVf_BREAK);
2151 #ifdef DEBUGGING
2152 if (fake) {
2153 /* op_dump(PL_op); */
2154 Perl_croak(aTHX_
2155 "panic: aassign skipped needed copy of common RH elem %"
2156 UVuf, (UV)(relem - firstrelem));
2157 }
2158 #endif
2160 TAINT_NOT; /* Each item is independent */
2162 /* Dear TODO test in t/op/sort.t, I love you.
2163 (It's relying on a panic, not a "semi-panic" from newSVsv()
2164 and then an assertion failure below.) */
2165 if (UNLIKELY(SvIS_FREED(svr))) {
2166 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
2167 (void*)svr);
2168 }
2169 /* avoid break flag while copying; otherwise COW etc
2170 * disabled... */
2171 SvFLAGS(svr) &= ~SVf_BREAK;
2172 /* Not newSVsv(), as it does not allow copy-on-write,
2173 resulting in wasteful copies.
2174 Also, we use SV_NOSTEAL in case the SV is used more than
2175 once, e.g. (...) = (f())[0,0]
2176 Where the same SV appears twice on the RHS without a ref
2177 count bump. (Although I suspect that the SV won't be
2178 stealable here anyway - DAPM).
2179 */
2180 *relem = sv_mortalcopy_flags(svr,
2181 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2182 /* ... but restore afterwards in case it's needed again,
2183 * e.g. ($a,$b,$c) = (1,$a,$a)
2184 */
2185 SvFLAGS(svr) |= brk;
2186 }
2188 if (!lcount)
2189 break;
2190 }
2192 if (!marked)
2193 return;
2195 /*unmark LHS */
2197 while (lelem > firstlelem) {
2198 SV * const svl = *(--lelem);
2199 if (svl)
2200 SvFLAGS(svl) &= ~SVf_BREAK;
2201 }
2202 }
2206 PP(pp_aassign)
2207 {
2208 dSP;
2209 SV **lastlelem = PL_stack_sp;
2210 SV **lastrelem = PL_stack_base + POPMARK;
2211 SV **firstrelem = PL_stack_base + POPMARK + 1;
2212 SV **firstlelem = lastrelem + 1;
2214 SV **relem;
2215 SV **lelem;
2216 U8 gimme;
2217 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
2218 * only need to save locally, not on the save stack */
2219 U16 old_delaymagic = PL_delaymagic;
2220 #ifdef DEBUGGING
2221 bool fake = 0;
2222 #endif
2224 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
2226 /* If there's a common identifier on both sides we have to take
2227 * special care that assigning the identifier on the left doesn't
2228 * clobber a value on the right that's used later in the list.
2229 */
2231 /* at least 2 LH and RH elements, or commonality isn't an issue */
2232 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2233 for (relem = firstrelem+1; relem <= lastrelem; relem++) {
2234 if (SvGMAGICAL(*relem))
2235 goto do_scan;
2236 }
2237 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2238 if (*lelem && SvSMAGICAL(*lelem))
2239 goto do_scan;
2240 }
2241 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
2242 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
2243 /* skip the scan if all scalars have a ref count of 1 */
2244 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2245 SV *sv = *lelem;
2246 if (!sv || SvREFCNT(sv) == 1)
2247 continue;
2248 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
2249 goto do_scan;
2250 break;
2251 }
2252 }
2253 else {
2254 do_scan:
2255 S_aassign_copy_common(aTHX_
2256 firstlelem, lastlelem, firstrelem, lastrelem
2257 #ifdef DEBUGGING
2258 , fake
2259 #endif
2260 );
2261 }
2262 }
2263 }
2264 #ifdef DEBUGGING
2265 else {
2266 /* on debugging builds, do the scan even if we've concluded we
2267 * don't need to, then panic if we find commonality. Note that the
2268 * scanner assumes at least 2 elements */
2269 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2270 fake = 1;
2271 goto do_scan;
2272 }
2273 }
2274 #endif
2276 gimme = GIMME_V;
2277 relem = firstrelem;
2278 lelem = firstlelem;
2280 if (relem > lastrelem)
2281 goto no_relems;
2283 /* first lelem loop while there are still relems */
2284 while (LIKELY(lelem <= lastlelem)) {
2285 bool alias = FALSE;
2286 SV *lsv = *lelem++;
2288 TAINT_NOT; /* Each item stands on its own, taintwise. */
2290 assert(relem <= lastrelem);
2291 if (UNLIKELY(!lsv)) {
2292 alias = TRUE;
2293 lsv = *lelem++;
2294 ASSUME(SvTYPE(lsv) == SVt_PVAV);
2295 }
2297 switch (SvTYPE(lsv)) {
2298 case SVt_PVAV: {
2299 SV **svp;
2300 SSize_t i;
2301 SSize_t tmps_base;
2302 SSize_t nelems = lastrelem - relem + 1;
2303 AV *ary = MUTABLE_AV(lsv);
2305 /* Assigning to an aggregate is tricky. First there is the
2306 * issue of commonality, e.g. @a = ($a[0]). Since the
2307 * stack isn't refcounted, clearing @a prior to storing
2308 * elements will free $a[0]. Similarly with
2309 * sub FETCH { $status[$_[1]] } @status = @tied[0,1];
2310 *
2311 * The way to avoid these issues is to make the copy of each
2312 * SV (and we normally store a *copy* in the array) *before*
2313 * clearing the array. But this has a problem in that
2314 * if the code croaks during copying, the not-yet-stored copies
2315 * could leak. One way to avoid this is to make all the copies
2316 * mortal, but that's quite expensive.
2317 *
2318 * The current solution to these issues is to use a chunk
2319 * of the tmps stack as a temporary refcounted-stack. SVs
2320 * will be put on there during processing to avoid leaks,
2321 * but will be removed again before the end of this block,
2322 * so free_tmps() is never normally called. Also, the
2323 * sv_refcnt of the SVs doesn't have to be manipulated, since
2324 * the ownership of 1 reference count is transferred directly
2325 * from the tmps stack to the AV when the SV is stored.
2326 *
2327 * We disarm slots in the temps stack by storing PL_sv_undef
2328 * there: it doesn't matter if that SV's refcount is
2329 * repeatedly decremented during a croak. But usually this is
2330 * only an interim measure. By the end of this code block
2331 * we try where possible to not leave any PL_sv_undef's on the
2332 * tmps stack e.g. by shuffling newer entries down.
2333 *
2334 * There is one case where we don't copy: non-magical
2335 * SvTEMP(sv)'s with a ref count of 1. The only owner of these
2336 * is on the tmps stack, so its safe to directly steal the SV
2337 * rather than copying. This is common in things like function
2338 * returns, map etc, which all return a list of such SVs.
2339 *
2340 * Note however something like @a = (f())[0,0], where there is
2341 * a danger of the same SV being shared: this avoided because
2342 * when the SV is stored as $a[0], its ref count gets bumped,
2343 * so the RC==1 test fails and the second element is copied
2344 * instead.
2345 *
2346 * We also use one slot in the tmps stack to hold an extra
2347 * ref to the array, to ensure it doesn't get prematurely
2348 * freed. Again, this is removed before the end of this block.
2349 *
2350 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
2351 * @a = ($a[0]) case, but the current implementation uses the
2352 * same algorithm regardless, so ignores that flag. (It *is*
2353 * used in the hash branch below, however).
2354 */
2356 /* Reserve slots for ary, plus the elems we're about to copy,
2357 * then protect ary and temporarily void the remaining slots
2358 * with &PL_sv_undef */
2359 EXTEND_MORTAL(nelems + 1);
2360 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
2361 tmps_base = PL_tmps_ix + 1;
2362 for (i = 0; i < nelems; i++)
2363 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2364 PL_tmps_ix += nelems;
2366 /* Make a copy of each RHS elem and save on the tmps_stack
2367 * (or pass through where we can optimise away the copy) */
2369 if (UNLIKELY(alias)) {
2370 U32 lval = (gimme == G_ARRAY)
2371 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
2372 for (svp = relem; svp <= lastrelem; svp++) {
2373 SV *rsv = *svp;
2375 SvGETMAGIC(rsv);
2376 if (!SvROK(rsv))
2377 DIE(aTHX_ "Assigned value is not a reference");
2378 if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
2379 /* diag_listed_as: Assigned value is not %s reference */
2380 DIE(aTHX_
2381 "Assigned value is not a SCALAR reference");
2382 if (lval)
2383 *svp = rsv = sv_mortalcopy(rsv);
2384 /* XXX else check for weak refs? */
2385 rsv = SvREFCNT_inc_NN(SvRV(rsv));
2386 assert(tmps_base <= PL_tmps_max);
2387 PL_tmps_stack[tmps_base++] = rsv;
2388 }
2389 }
2390 else {
2391 for (svp = relem; svp <= lastrelem; svp++) {
2392 SV *rsv = *svp;
2394 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2395 /* can skip the copy */
2396 SvREFCNT_inc_simple_void_NN(rsv);
2397 SvTEMP_off(rsv);
2398 }
2399 else {
2400 SV *nsv;
2401 /* do get before newSV, in case it dies and leaks */
2402 SvGETMAGIC(rsv);
2403 nsv = newSV(0);
2404 /* see comment in S_aassign_copy_common about
2405 * SV_NOSTEAL */
2406 sv_setsv_flags(nsv, rsv,
2407 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2408 rsv = *svp = nsv;
2409 }
2411 assert(tmps_base <= PL_tmps_max);
2412 PL_tmps_stack[tmps_base++] = rsv;
2413 }
2414 }
2416 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
2417 av_clear(ary);
2419 /* store in the array, the SVs that are in the tmps stack */
2421 tmps_base -= nelems;
2423 if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
2424 /* for arrays we can't cheat with, use the official API */
2425 av_extend(ary, nelems - 1);
2426 for (i = 0; i < nelems; i++) {
2427 SV **svp = &(PL_tmps_stack[tmps_base + i]);
2428 SV *rsv = *svp;
2429 /* A tied store won't take ownership of rsv, so keep
2430 * the 1 refcnt on the tmps stack; otherwise disarm
2431 * the tmps stack entry */
2432 if (av_store(ary, i, rsv))
2433 *svp = &PL_sv_undef;
2434 /* av_store() may have added set magic to rsv */;
2435 SvSETMAGIC(rsv);
2436 }
2437 /* disarm ary refcount: see comments below about leak */
2438 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2439 }
2440 else {
2441 /* directly access/set the guts of the AV */
2442 SSize_t fill = nelems - 1;
2443 if (fill > AvMAX(ary))
2444 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
2445 &AvARRAY(ary));
2446 AvFILLp(ary) = fill;
2447 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
2448 /* Quietly remove all the SVs from the tmps stack slots,
2449 * since ary has now taken ownership of the refcnt.
2450 * Also remove ary: which will now leak if we die before
2451 * the SvREFCNT_dec_NN(ary) below */
2452 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2453 Move(&PL_tmps_stack[tmps_base + nelems],
2454 &PL_tmps_stack[tmps_base - 1],
2455 PL_tmps_ix - (tmps_base + nelems) + 1,
2456 SV*);
2457 PL_tmps_ix -= (nelems + 1);
2458 }
2460 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2461 /* its assumed @ISA set magic can't die and leak ary */
2462 SvSETMAGIC(MUTABLE_SV(ary));
2463 SvREFCNT_dec_NN(ary);
2465 relem = lastrelem + 1;
2466 goto no_relems;
2467 }
2469 case SVt_PVHV: { /* normal hash */
2471 SV **svp;
2472 bool dirty_tmps;
2473 SSize_t i;
2474 SSize_t tmps_base;
2475 SSize_t nelems = lastrelem - relem + 1;
2476 HV *hash = MUTABLE_HV(lsv);
2478 if (UNLIKELY(nelems & 1)) {
2479 do_oddball(lastrelem, relem);
2480 /* we have firstlelem to reuse, it's not needed any more */
2481 *++lastrelem = &PL_sv_undef;
2482 nelems++;
2483 }
2485 /* See the SVt_PVAV branch above for a long description of
2486 * how the following all works. The main difference for hashes
2487 * is that we treat keys and values separately (and have
2488 * separate loops for them): as for arrays, values are always
2489 * copied (except for the SvTEMP optimisation), since they
2490 * need to be stored in the hash; while keys are only
2491 * processed where they might get prematurely freed or
2492 * whatever. */
2494 /* tmps stack slots:
2495 * * reserve a slot for the hash keepalive;
2496 * * reserve slots for the hash values we're about to copy;
2497 * * preallocate for the keys we'll possibly copy or refcount bump
2498 * later;
2499 * then protect hash and temporarily void the remaining
2500 * value slots with &PL_sv_undef */
2501 EXTEND_MORTAL(nelems + 1);
2503 /* convert to number of key/value pairs */
2504 nelems >>= 1;
2506 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
2507 tmps_base = PL_tmps_ix + 1;
2508 for (i = 0; i < nelems; i++)
2509 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2510 PL_tmps_ix += nelems;
2512 /* Make a copy of each RHS hash value and save on the tmps_stack
2513 * (or pass through where we can optimise away the copy) */
2515 for (svp = relem + 1; svp <= lastrelem; svp += 2) {
2516 SV *rsv = *svp;
2518 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2519 /* can skip the copy */
2520 SvREFCNT_inc_simple_void_NN(rsv);
2521 SvTEMP_off(rsv);
2522 }
2523 else {
2524 SV *nsv;
2525 /* do get before newSV, in case it dies and leaks */
2526 SvGETMAGIC(rsv);
2527 nsv = newSV(0);
2528 /* see comment in S_aassign_copy_common about
2529 * SV_NOSTEAL */
2530 sv_setsv_flags(nsv, rsv,
2531 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2532 rsv = *svp = nsv;
2533 }
2535 assert(tmps_base <= PL_tmps_max);
2536 PL_tmps_stack[tmps_base++] = rsv;
2537 }
2538 tmps_base -= nelems;
2541 /* possibly protect keys */
2543 if (UNLIKELY(gimme == G_ARRAY)) {
2544 /* handle e.g.
2545 * @a = ((%h = ($$r, 1)), $r = "x");
2546 * $_++ for %h = (1,2,3,4);
2547 */
2548 EXTEND_MORTAL(nelems);
2549 for (svp = relem; svp <= lastrelem; svp += 2)
2550 *svp = sv_mortalcopy_flags(*svp,
2551 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2552 }
2553 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
2554 /* for possible commonality, e.g.
2555 * %h = ($h{a},1)
2556 * avoid premature freeing RHS keys by mortalising
2557 * them.
2558 * For a magic element, make a copy so that its magic is
2559 * called *before* the hash is emptied (which may affect
2560 * a tied value for example).
2561 * In theory we should check for magic keys in all
2562 * cases, not just under OPpASSIGN_COMMON_AGG, but in
2563 * practice, !OPpASSIGN_COMMON_AGG implies only
2564 * constants or padtmps on the RHS.
2565 */
2566 EXTEND_MORTAL(nelems);
2567 for (svp = relem; svp <= lastrelem; svp += 2) {
2568 SV *rsv = *svp;
2569 if (UNLIKELY(SvGMAGICAL(rsv))) {
2570 SSize_t n;
2571 *svp = sv_mortalcopy_flags(*svp,
2572 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2573 /* allow other branch to continue pushing
2574 * onto tmps stack without checking each time */
2575 n = (lastrelem - relem) >> 1;
2576 EXTEND_MORTAL(n);
2577 }
2578 else
2579 PL_tmps_stack[++PL_tmps_ix] =
2580 SvREFCNT_inc_simple_NN(rsv);
2581 }
2582 }
2584 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
2585 hv_clear(hash);
2587 /* now assign the keys and values to the hash */
2589 dirty_tmps = FALSE;
2591 if (UNLIKELY(gimme == G_ARRAY)) {
2592 /* @a = (%h = (...)) etc */
2593 SV **svp;
2594 SV **topelem = relem;
2596 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2597 SV *key = *svp++;
2598 SV *val = *svp;
2599 /* remove duplicates from list we return */
2600 if (!hv_exists_ent(hash, key, 0)) {
2601 /* copy key back: possibly to an earlier
2602 * stack location if we encountered dups earlier,
2603 * The values will be updated later
2604 */
2605 *topelem = key;
2606 topelem += 2;
2607 }
2608 /* A tied store won't take ownership of val, so keep
2609 * the 1 refcnt on the tmps stack; otherwise disarm
2610 * the tmps stack entry */
2611 if (hv_store_ent(hash, key, val, 0))
2612 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2613 else
2614 dirty_tmps = TRUE;
2615 /* hv_store_ent() may have added set magic to val */;
2616 SvSETMAGIC(val);
2617 }
2618 if (topelem < svp) {
2619 /* at this point we have removed the duplicate key/value
2620 * pairs from the stack, but the remaining values may be
2621 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
2622 * the (a 2), but the stack now probably contains
2623 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
2624 * obliterates the earlier key. So refresh all values. */
2625 lastrelem = topelem - 1;
2626 while (relem < lastrelem) {
2627 HE *he;
2628 he = hv_fetch_ent(hash, *relem++, 0, 0);
2629 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
2630 }
2631 }
2632 }
2633 else {
2634 SV **svp;
2635 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2636 SV *key = *svp++;
2637 SV *val = *svp;
2638 if (hv_store_ent(hash, key, val, 0))
2639 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2640 else
2641 dirty_tmps = TRUE;
2642 /* hv_store_ent() may have added set magic to val */;
2643 SvSETMAGIC(val);
2644 }
2645 }
2647 if (dirty_tmps) {
2648 /* there are still some 'live' recounts on the tmps stack
2649 * - usually caused by storing into a tied hash. So let
2650 * free_tmps() do the proper but slow job later.
2651 * Just disarm hash refcount: see comments below about leak
2652 */
2653 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2654 }
2655 else {
2656 /* Quietly remove all the SVs from the tmps stack slots,
2657 * since hash has now taken ownership of the refcnt.
2658 * Also remove hash: which will now leak if we die before
2659 * the SvREFCNT_dec_NN(hash) below */
2660 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2661 Move(&PL_tmps_stack[tmps_base + nelems],
2662 &PL_tmps_stack[tmps_base - 1],
2663 PL_tmps_ix - (tmps_base + nelems) + 1,
2664 SV*);
2665 PL_tmps_ix -= (nelems + 1);
2666 }
2668 SvREFCNT_dec_NN(hash);
2670 relem = lastrelem + 1;
2671 goto no_relems;
2672 }
2674 default:
2675 if (!SvIMMORTAL(lsv)) {
2676 SV *ref;
2678 if (UNLIKELY(
2679 SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
2680 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
2681 ))
2682 Perl_warner(aTHX_
2683 packWARN(WARN_MISC),
2684 "Useless assignment to a temporary"
2685 );
2687 /* avoid freeing $$lsv if it might be needed for further
2688 * elements, e.g. ($ref, $foo) = (1, $$ref) */
2689 if ( SvROK(lsv)
2690 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
2691 && lelem <= lastlelem
2692 ) {
2693 SSize_t ix;
2694 SvREFCNT_inc_simple_void_NN(ref);
2695 /* an unrolled sv_2mortal */
2696 ix = ++PL_tmps_ix;
2697 if (UNLIKELY(ix >= PL_tmps_max))
2698 /* speculatively grow enough to cover other
2699 * possible refs */
2700 (void)tmps_grow_p(ix + (lastlelem - lelem));
2701 PL_tmps_stack[ix] = ref;
2702 }
2704 sv_setsv(lsv, *relem);
2705 *relem = lsv;
2706 SvSETMAGIC(lsv);
2707 }
2708 if (++relem > lastrelem)
2709 goto no_relems;
2710 break;
2711 } /* switch */
2712 } /* while */
2715 no_relems:
2717 /* simplified lelem loop for when there are no relems left */
2718 while (LIKELY(lelem <= lastlelem)) {
2719 SV *lsv = *lelem++;
2721 TAINT_NOT; /* Each item stands on its own, taintwise. */
2723 if (UNLIKELY(!lsv)) {
2724 lsv = *lelem++;
2725 ASSUME(SvTYPE(lsv) == SVt_PVAV);
2726 }
2728 switch (SvTYPE(lsv)) {
2729 case SVt_PVAV:
2730 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
2731 av_clear((AV*)lsv);
2732 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2733 SvSETMAGIC(lsv);
2734 }
2735 break;
2737 case SVt_PVHV:
2738 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
2739 hv_clear((HV*)lsv);
2740 break;
2742 default:
2743 if (!SvIMMORTAL(lsv)) {
2744 sv_set_undef(lsv);
2745 SvSETMAGIC(lsv);
2746 }
2747 *relem++ = lsv;
2748 break;
2749 } /* switch */
2750 } /* while */
2752 TAINT_NOT; /* result of list assign isn't tainted */
2754 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
2755 /* Will be used to set PL_tainting below */
2756 Uid_t tmp_uid = PerlProc_getuid();
2757 Uid_t tmp_euid = PerlProc_geteuid();
2758 Gid_t tmp_gid = PerlProc_getgid();
2759 Gid_t tmp_egid = PerlProc_getegid();
2761 /* XXX $> et al currently silently ignore failures */
2762 if (PL_delaymagic & DM_UID) {
2763 #ifdef HAS_SETRESUID
2764 PERL_UNUSED_RESULT(
2765 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2766 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
2767 (Uid_t)-1));
2768 #elif defined(HAS_SETREUID)
2769 PERL_UNUSED_RESULT(
2770 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2771 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
2772 #else
2773 # ifdef HAS_SETRUID
2774 if ((PL_delaymagic & DM_UID) == DM_RUID) {
2775 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
2776 PL_delaymagic &= ~DM_RUID;
2777 }
2778 # endif /* HAS_SETRUID */
2779 # ifdef HAS_SETEUID
2780 if ((PL_delaymagic & DM_UID) == DM_EUID) {
2781 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
2782 PL_delaymagic &= ~DM_EUID;
2783 }
2784 # endif /* HAS_SETEUID */
2785 if (PL_delaymagic & DM_UID) {
2786 if (PL_delaymagic_uid != PL_delaymagic_euid)
2787 DIE(aTHX_ "No setreuid available");
2788 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
2789 }
2790 #endif /* HAS_SETRESUID */
2792 tmp_uid = PerlProc_getuid();
2793 tmp_euid = PerlProc_geteuid();
2794 }
2795 /* XXX $> et al currently silently ignore failures */
2796 if (PL_delaymagic & DM_GID) {
2797 #ifdef HAS_SETRESGID
2798 PERL_UNUSED_RESULT(
2799 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2800 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
2801 (Gid_t)-1));
2802 #elif defined(HAS_SETREGID)
2803 PERL_UNUSED_RESULT(
2804 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2805 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
2806 #else
2807 # ifdef HAS_SETRGID
2808 if ((PL_delaymagic & DM_GID) == DM_RGID) {
2809 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
2810 PL_delaymagic &= ~DM_RGID;
2811 }
2812 # endif /* HAS_SETRGID */
2813 # ifdef HAS_SETEGID
2814 if ((PL_delaymagic & DM_GID) == DM_EGID) {
2815 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
2816 PL_delaymagic &= ~DM_EGID;
2817 }
2818 # endif /* HAS_SETEGID */
2819 if (PL_delaymagic & DM_GID) {
2820 if (PL_delaymagic_gid != PL_delaymagic_egid)
2821 DIE(aTHX_ "No setregid available");
2822 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
2823 }
2824 #endif /* HAS_SETRESGID */
2826 tmp_gid = PerlProc_getgid();
2827 tmp_egid = PerlProc_getegid();
2828 }
2829 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
2830 #ifdef NO_TAINT_SUPPORT
2831 PERL_UNUSED_VAR(tmp_uid);
2832 PERL_UNUSED_VAR(tmp_euid);
2833 PERL_UNUSED_VAR(tmp_gid);
2834 PERL_UNUSED_VAR(tmp_egid);
2835 #endif
2836 }
2837 PL_delaymagic = old_delaymagic;
2839 if (gimme == G_VOID)
2840 SP = firstrelem - 1;
2841 else if (gimme == G_SCALAR) {
2842 SP = firstrelem;
2843 EXTEND(SP,1);
2844 if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
2845 SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
2846 else {
2847 dTARGET;
2848 SETi(firstlelem - firstrelem);
2849 }
2850 }
2851 else
2852 SP = relem - 1;
2854 RETURN;
2855 }
2857 PP(pp_qr)
2858 {
2859 dSP;
2860 PMOP * const pm = cPMOP;
2861 REGEXP * rx = PM_GETRE(pm);
2862 regexp *prog = ReANY(rx);
2863 SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
2864 SV * const rv = sv_newmortal();
2865 CV **cvp;
2866 CV *cv;
2868 SvUPGRADE(rv, SVt_IV);
2869 /* For a subroutine describing itself as "This is a hacky workaround" I'm
2870 loathe to use it here, but it seems to be the right fix. Or close.
2871 The key part appears to be that it's essential for pp_qr to return a new
2872 object (SV), which implies that there needs to be an effective way to
2873 generate a new SV from the existing SV that is pre-compiled in the
2874 optree. */
2875 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
2876 SvROK_on(rv);
2878 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
2879 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
2880 *cvp = cv_clone(cv);
2881 SvREFCNT_dec_NN(cv);
2882 }
2884 if (pkg) {
2885 HV *const stash = gv_stashsv(pkg, GV_ADD);
2886 SvREFCNT_dec_NN(pkg);
2887 (void)sv_bless(rv, stash);
2888 }
2890 if (UNLIKELY(RXp_ISTAINTED(prog))) {
2891 SvTAINTED_on(rv);
2892 SvTAINTED_on(SvRV(rv));
2893 }
2894 XPUSHs(rv);
2895 RETURN;
2896 }
2898 STATIC bool
2899 S_are_we_in_Debug_EXECUTE_r(pTHX)
2900 {
2901 /* Given a 'use re' is in effect, does it ask for outputting execution
2902 * debug info?
2903 *
2904 * This is separated from the sole place it's called, an inline function,
2905 * because it is the large-ish slow portion of the function */
2907 DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX;
2909 return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK));
2910 }
2912 PERL_STATIC_INLINE bool
2913 S_should_we_output_Debug_r(pTHX_ regexp *prog)
2914 {
2915 PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R;
2917 /* pp_match can output regex debugging info. This function returns a
2918 * boolean as to whether or not it should.
2919 *
2920 * Under -Dr, it should. Any reasonable compiler will optimize this bit of
2921 * code away on non-debugging builds. */
2922 if (UNLIKELY(DEBUG_r_TEST)) {
2923 return TRUE;
2924 }
2926 /* If the regex engine is using the non-debugging execution routine, then
2927 * no debugging should be output. Same if the field is NULL that pluggable
2928 * engines are not supposed to fill. */
2929 if ( LIKELY(prog->engine->exec == &Perl_regexec_flags)
2930 || UNLIKELY(prog->engine->op_comp == NULL))
2931 {
2932 return FALSE;
2933 }
2935 /* Otherwise have to check */
2936 return S_are_we_in_Debug_EXECUTE_r(aTHX);
2937 }
2939 PP(pp_match)
2940 {
2941 dSP; dTARG;
2942 PMOP *pm = cPMOP;
2943 PMOP *dynpm = pm;
2944 const char *s;
2945 const char *strend;
2946 SSize_t curpos = 0; /* initial pos() or current $+[0] */
2947 I32 global;
2948 U8 r_flags = 0;
2949 const char *truebase; /* Start of string */
2950 REGEXP *rx = PM_GETRE(pm);
2951 regexp *prog = ReANY(rx);
2952 bool rxtainted;
2953 const U8 gimme = GIMME_V;
2954 STRLEN len;
2955 const I32 oldsave = PL_savestack_ix;
2956 I32 had_zerolen = 0;
2957 MAGIC *mg = NULL;
2959 if (PL_op->op_flags & OPf_STACKED)
2960 TARG = POPs;
2961 else {
2962 if (ARGTARG)
2963 GETTARGET;
2964 else {
2965 TARG = DEFSV;
2966 }
2967 EXTEND(SP,1);
2968 }
2970 PUTBACK; /* EVAL blocks need stack_sp. */
2971 /* Skip get-magic if this is a qr// clone, because regcomp has
2972 already done it. */
2973 truebase = prog->mother_re
2974 ? SvPV_nomg_const(TARG, len)
2975 : SvPV_const(TARG, len);
2976 if (!truebase)
2977 DIE(aTHX_ "panic: pp_match");
2978 strend = truebase + len;
2979 rxtainted = (RXp_ISTAINTED(prog) ||
2980 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
2981 TAINT_NOT;
2983 /* We need to know this in case we fail out early - pos() must be reset */
2984 global = dynpm->op_pmflags & PMf_GLOBAL;
2986 /* PMdf_USED is set after a ?? matches once */
2987 if (
2988 #ifdef USE_ITHREADS
2989 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
2990 #else
2991 pm->op_pmflags & PMf_USED
2992 #endif
2993 ) {
2994 if (UNLIKELY(should_we_output_Debug_r(prog))) {
2995 PerlIO_printf(Perl_debug_log, "?? already matched once");
2996 }
2997 goto nope;
2998 }
3000 /* handle the empty pattern */
3001 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
3002 if (PL_curpm == PL_reg_curpm) {
3003 if (PL_curpm_under) {
3004 if (PL_curpm_under == PL_reg_curpm) {
3005 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3006 } else {
3007 pm = PL_curpm_under;
3008 }
3009 }
3010 } else {
3011 pm = PL_curpm;
3012 }
3013 rx = PM_GETRE(pm);
3014 prog = ReANY(rx);
3015 }
3017 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
3018 if (UNLIKELY(should_we_output_Debug_r(prog))) {
3019 PerlIO_printf(Perl_debug_log,
3020 "String shorter than min possible regex match (%zd < %zd)\n",
3021 len, RXp_MINLEN(prog));
3022 }
3023 goto nope;
3024 }
3026 /* get pos() if //g */
3027 if (global) {
3028 mg = mg_find_mglob(TARG);
3029 if (mg && mg->mg_len >= 0) {
3030 curpos = MgBYTEPOS(mg, TARG, truebase, len);
3031 /* last time pos() was set, it was zero-length match */
3032 if (mg->mg_flags & MGf_MINMATCH)
3033 had_zerolen = 1;
3034 }
3035 }
3037 #ifdef PERL_SAWAMPERSAND
3038 if ( RXp_NPARENS(prog)
3039 || PL_sawampersand
3040 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3041 || (dynpm->op_pmflags & PMf_KEEPCOPY)
3042 )
3043 #endif
3044 {
3045 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
3046 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
3047 * only on the first iteration. Therefore we need to copy $' as well
3048 * as $&, to make the rest of the string available for captures in
3049 * subsequent iterations */
3050 if (! (global && gimme == G_ARRAY))
3051 r_flags |= REXEC_COPY_SKIP_POST;
3052 };
3053 #ifdef PERL_SAWAMPERSAND
3054 if (dynpm->op_pmflags & PMf_KEEPCOPY)
3055 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3056 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3057 #endif
3059 s = truebase;
3061 play_it_again:
3062 if (global)
3063 s = truebase + curpos;
3065 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
3066 had_zerolen, TARG, NULL, r_flags))
3067 goto nope;
3069 PL_curpm = pm;
3070 if (dynpm->op_pmflags & PMf_ONCE)
3071 #ifdef USE_ITHREADS
3072 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
3073 #else
3074 dynpm->op_pmflags |= PMf_USED;
3075 #endif
3077 if (rxtainted)
3078 RXp_MATCH_TAINTED_on(prog);
3079 TAINT_IF(RXp_MATCH_TAINTED(prog));
3081 /* update pos */
3083 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
3084 if (!mg)
3085 mg = sv_magicext_mglob(TARG);
3086 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
3087 if (RXp_ZERO_LEN(prog))
3088 mg->mg_flags |= MGf_MINMATCH;
3089 else
3090 mg->mg_flags &= ~MGf_MINMATCH;
3091 }
3093 if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
3094 LEAVE_SCOPE(oldsave);
3095 RETPUSHYES;
3096 }
3098 /* push captures on stack */
3100 {
3101 const I32 nparens = RXp_NPARENS(prog);
3102 I32 i = (global && !nparens) ? 1 : 0;
3104 SPAGAIN; /* EVAL blocks could move the stack. */
3105 EXTEND(SP, nparens + i);
3106 EXTEND_MORTAL(nparens + i);
3107 for (i = !i; i <= nparens; i++) {
3108 PUSHs(sv_newmortal());
3109 if (LIKELY((RXp_OFFS(prog)[i].start != -1)
3110 && RXp_OFFS(prog)[i].end != -1 ))
3111 {
3112 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
3113 const char * const s = RXp_OFFS(prog)[i].start + truebase;
3114 if (UNLIKELY( RXp_OFFS(prog)[i].end < 0
3115 || RXp_OFFS(prog)[i].start < 0
3116 || len < 0
3117 || len > strend - s)
3118 )
3119 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
3120 "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
3121 (long) i, (long) RXp_OFFS(prog)[i].start,
3122 (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
3123 sv_setpvn(*SP, s, len);
3124 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
3125 SvUTF8_on(*SP);
3126 }
3127 }
3128 if (global) {
3129 curpos = (UV)RXp_OFFS(prog)[0].end;
3130 had_zerolen = RXp_ZERO_LEN(prog);
3131 PUTBACK; /* EVAL blocks may use stack */
3132 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
3133 goto play_it_again;
3134 }
3135 LEAVE_SCOPE(oldsave);
3136 RETURN;
3137 }
3138 NOT_REACHED; /* NOTREACHED */
3140 nope:
3141 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
3142 if (!mg)
3143 mg = mg_find_mglob(TARG);
3144 if (mg)
3145 mg->mg_len = -1;
3146 }
3147 LEAVE_SCOPE(oldsave);
3148 if (gimme == G_ARRAY)
3149 RETURN;
3150 RETPUSHNO;
3151 }
3153 OP *
3154 Perl_do_readline(pTHX)
3155 {
3156 dSP; dTARGETSTACKED;
3157 SV *sv;
3158 STRLEN tmplen = 0;
3159 STRLEN offset;
3160 PerlIO *fp;
3161 IO * const io = GvIO(PL_last_in_gv);
3162 const I32 type = PL_op->op_type;
3163 const U8 gimme = GIMME_V;
3165 if (io) {
3166 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
3167 if (mg) {
3168 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
3169 if (gimme == G_SCALAR) {
3170 SPAGAIN;
3171 SvSetSV_nosteal(TARG, TOPs);
3172 SETTARG;
3173 }
3174 return NORMAL;
3175 }
3176 }
3177 fp = NULL;
3178 if (io) {
3179 fp = IoIFP(io);
3180 if (!fp) {
3181 if (IoFLAGS(io) & IOf_ARGV) {
3182 if (IoFLAGS(io) & IOf_START) {
3183 IoLINES(io) = 0;
3184 if (av_count(GvAVn(PL_last_in_gv)) == 0) {
3185 IoFLAGS(io) &= ~IOf_START;
3186 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
3187 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
3188 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3189 SvSETMAGIC(GvSV(PL_last_in_gv));
3190 fp = IoIFP(io);
3191 goto have_fp;
3192 }
3193 }
3194 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3195 if (!fp) { /* Note: fp != IoIFP(io) */
3196 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
3197 }
3198 }
3199 else if (type == OP_GLOB)
3200 fp = Perl_start_glob(aTHX_ POPs, io);
3201 }
3202 else if (type == OP_GLOB)
3203 SP--;
3204 else if (IoTYPE(io) == IoTYPE_WRONLY) {
3205 report_wrongway_fh(PL_last_in_gv, '>');
3206 }
3207 }
3208 if (!fp) {
3209 if ((!io || !(IoFLAGS(io) & IOf_START))
3210 && ckWARN(WARN_CLOSED)
3211 && type != OP_GLOB)
3212 {
3213 report_evil_fh(PL_last_in_gv);
3214 }
3215 if (gimme == G_SCALAR) {
3216 /* undef TARG, and push that undefined value */
3217 if (type != OP_RCATLINE) {
3218 sv_set_undef(TARG);
3219 }
3220 PUSHTARG;
3221 }
3222 RETURN;
3223 }
3224 have_fp:
3225 if (gimme == G_SCALAR) {
3226 sv = TARG;
3227 if (type == OP_RCATLINE && SvGMAGICAL(sv))
3228 mg_get(sv);
3229 if (SvROK(sv)) {
3230 if (type == OP_RCATLINE)
3231 SvPV_force_nomg_nolen(sv);
3232 else
3233 sv_unref(sv);
3234 }
3235 else if (isGV_with_GP(sv)) {
3236 SvPV_force_nomg_nolen(sv);
3237 }
3238 SvUPGRADE(sv, SVt_PV);
3239 tmplen = SvLEN(sv); /* remember if already alloced */
3240 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
3241 /* try short-buffering it. Please update t/op/readline.t
3242 * if you change the growth length.
3243 */
3244 Sv_Grow(sv, 80);
3245 }
3246 offset = 0;
3247 if (type == OP_RCATLINE && SvOK(sv)) {
3248 if (!SvPOK(sv)) {
3249 SvPV_force_nomg_nolen(sv);
3250 }
3251 offset = SvCUR(sv);
3252 }
3253 }
3254 else {
3255 sv = sv_2mortal(newSV(80));
3256 offset = 0;
3257 }
3259 /* This should not be marked tainted if the fp is marked clean */
3260 #define MAYBE_TAINT_LINE(io, sv) \
3261 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
3262 TAINT; \
3263 SvTAINTED_on(sv); \
3264 }
3266 /* delay EOF state for a snarfed empty file */
3267 #define SNARF_EOF(gimme,rs,io,sv) \
3268 (gimme != G_SCALAR || SvCUR(sv) \
3269 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
3271 for (;;) {
3272 PUTBACK;
3273 if (!sv_gets(sv, fp, offset)
3274 && (type == OP_GLOB
3275 || SNARF_EOF(gimme, PL_rs, io, sv)
3276 || PerlIO_error(fp)))
3277 {
3278 PerlIO_clearerr(fp);
3279 if (IoFLAGS(io) & IOf_ARGV) {
3280 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3281 if (fp)
3282 continue;
3283 (void)do_close(PL_last_in_gv, FALSE);
3284 }
3285 else if (type == OP_GLOB) {
3286 if (!do_close(PL_last_in_gv, FALSE)) {
3287 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
3288 "glob failed (child exited with status %d%s)",
3289 (int)(STATUS_CURRENT >> 8),
3290 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
3291 }
3292 }
3293 if (gimme == G_SCALAR) {
3294 if (type != OP_RCATLINE) {
3295 SV_CHECK_THINKFIRST_COW_DROP(TARG);
3296 SvOK_off(TARG);
3297 }
3298 SPAGAIN;
3299 PUSHTARG;
3300 }
3301 MAYBE_TAINT_LINE(io, sv);
3302 RETURN;
3303 }
3304 MAYBE_TAINT_LINE(io, sv);
3305 IoLINES(io)++;
3306 IoFLAGS(io) |= IOf_NOLINE;
3307 SvSETMAGIC(sv);
3308 SPAGAIN;
3309 XPUSHs(sv);
3310 if (type == OP_GLOB) {
3311 const char *t1;
3312 Stat_t statbuf;
3314 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
3315 char * const tmps = SvEND(sv) - 1;
3316 if (*tmps == *SvPVX_const(PL_rs)) {
3317 *tmps = '\0';
3318 SvCUR_set(sv, SvCUR(sv) - 1);
3319 }
3320 }
3321 for (t1 = SvPVX_const(sv); *t1; t1++)
3322 #ifdef __VMS
3323 if (memCHRs("*%?", *t1))
3324 #else
3325 if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1))
3326 #endif
3327 break;
3328 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
3329 (void)POPs; /* Unmatched wildcard? Chuck it... */
3330 continue;
3331 }
3332 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
3333 if (ckWARN(WARN_UTF8)) {
3334 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
3335 const STRLEN len = SvCUR(sv) - offset;
3336 const U8 *f;
3338 if (!is_utf8_string_loc(s, len, &f))
3339 /* Emulate :encoding(utf8) warning in the same case. */
3340 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3341 "utf8 \"\\x%02X\" does not map to Unicode",
3342 f < (U8*)SvEND(sv) ? *f : 0);
3343 }
3344 }
3345 if (gimme == G_ARRAY) {
3346 if (SvLEN(sv) - SvCUR(sv) > 20) {
3347 SvPV_shrink_to_cur(sv);
3348 }
3349 sv = sv_2mortal(newSV(80));
3350 continue;
3351 }
3352 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
3353 /* try to reclaim a bit of scalar space (only on 1st alloc) */
3354 const STRLEN new_len
3355 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
3356 SvPV_renew(sv, new_len);
3357 }
3358 RETURN;
3359 }
3360 }
3362 PP(pp_helem)
3363 {
3364 dSP;
3365 HE* he;
3366 SV **svp;
3367 SV * const keysv = POPs;
3368 HV * const hv = MUTABLE_HV(POPs);
3369 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3370 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3371 SV *sv;
3372 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3373 bool preeminent = TRUE;
3375 if (SvTYPE(hv) != SVt_PVHV)
3376 RETPUSHUNDEF;
3378 if (localizing) {
3379 MAGIC *mg;
3380 HV *stash;
3382 /* If we can determine whether the element exist,
3383 * Try to preserve the existenceness of a tied hash
3384 * element by using EXISTS and DELETE if possible.
3385 * Fallback to FETCH and STORE otherwise. */
3386 if (SvCANEXISTDELETE(hv))
3387 preeminent = hv_exists_ent(hv, keysv, 0);
3388 }
3390 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3391 svp = he ? &HeVAL(he) : NULL;
3392 if (lval) {
3393 if (!svp || !*svp || *svp == &PL_sv_undef) {
3394 SV* lv;
3395 SV* key2;
3396 if (!defer) {
3397 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3398 }
3399 lv = sv_newmortal();
3400 sv_upgrade(lv, SVt_PVLV);
3401 LvTYPE(lv) = 'y';
3402 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
3403 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
3404 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3405 LvTARGLEN(lv) = 1;
3406 PUSHs(lv);
3407 RETURN;
3408 }
3409 if (localizing) {
3410 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
3411 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
3412 else if (preeminent)
3413 save_helem_flags(hv, keysv, svp,
3414 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
3415 else
3416 SAVEHDELETE(hv, keysv);
3417 }
3418 else if (PL_op->op_private & OPpDEREF) {
3419 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3420 RETURN;
3421 }
3422 }
3423 sv = (svp && *svp ? *svp : &PL_sv_undef);
3424 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
3425 * was to make C<local $tied{foo} = $tied{foo}> possible.
3426 * However, it seems no longer to be needed for that purpose, and
3427 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
3428 * would loop endlessly since the pos magic is getting set on the
3429 * mortal copy and lost. However, the copy has the effect of
3430 * triggering the get magic, and losing it altogether made things like
3431 * c<$tied{foo};> in void context no longer do get magic, which some
3432 * code relied on. Also, delayed triggering of magic on @+ and friends
3433 * meant the original regex may be out of scope by now. So as a
3434 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
3435 * being called too many times). */
3436 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
3437 mg_get(sv);
3438 PUSHs(sv);
3439 RETURN;
3440 }
3443 /* a stripped-down version of Perl_softref2xv() for use by
3444 * pp_multideref(), which doesn't use PL_op->op_flags */
3446 STATIC GV *
3447 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
3448 const svtype type)
3449 {
3450 if (PL_op->op_private & HINT_STRICT_REFS) {
3451 if (SvOK(sv))
3452 Perl_die(aTHX_ PL_no_symref_sv, sv,
3453 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
3454 else
3455 Perl_die(aTHX_ PL_no_usym, what);
3456 }
3457 if (!SvOK(sv))
3458 Perl_die(aTHX_ PL_no_usym, what);
3459 return gv_fetchsv_nomg(sv, GV_ADD, type);
3460 }
3463 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
3464 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
3465 *
3466 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
3467 * Each of these either contains a set of actions, or an argument, such as
3468 * an IV to use as an array index, or a lexical var to retrieve.
3469 * Several actions re stored per UV; we keep shifting new actions off the
3470 * one UV, and only reload when it becomes zero.
3471 */
3473 PP(pp_multideref)
3474 {
3475 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
3476 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3477 UV actions = items->uv;
3479 assert(actions);
3480 /* this tells find_uninit_var() where we're up to */
3481 PL_multideref_pc = items;
3483 while (1) {
3484 /* there are three main classes of action; the first retrieve
3485 * the initial AV or HV from a variable or the stack; the second
3486 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
3487 * the third an unrolled (/DREFHV, rv2hv, helem).
3488 */
3489 switch (actions & MDEREF_ACTION_MASK) {
3491 case MDEREF_reload:
3492 actions = (++items)->uv;
3493 continue;
3495 case MDEREF_AV_padav_aelem: /* $lex[...] */
3496 sv = PAD_SVl((++items)->pad_offset);
3497 goto do_AV_aelem;
3499 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
3500 sv = UNOP_AUX_item_sv(++items);
3501 assert(isGV_with_GP(sv));
3502 sv = (SV*)GvAVn((GV*)sv);
3503 goto do_AV_aelem;
3505 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
3506 {
3507 dSP;
3508 sv = POPs;
3509 PUTBACK;
3510 goto do_AV_rv2av_aelem;
3511 }
3513 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
3514 sv = UNOP_AUX_item_sv(++items);
3515 assert(isGV_with_GP(sv));
3516 sv = GvSVn((GV*)sv);
3517 goto do_AV_vivify_rv2av_aelem;
3519 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
3520 sv = PAD_SVl((++items)->pad_offset);
3521 /* FALLTHROUGH */
3523 do_AV_vivify_rv2av_aelem:
3524 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
3525 /* this is the OPpDEREF action normally found at the end of
3526 * ops like aelem, helem, rv2sv */
3527 sv = vivify_ref(sv, OPpDEREF_AV);
3528 /* FALLTHROUGH */
3530 do_AV_rv2av_aelem:
3531 /* this is basically a copy of pp_rv2av when it just has the
3532 * sKR/1 flags */
3533 SvGETMAGIC(sv);
3534 if (LIKELY(SvROK(sv))) {
3535 if (UNLIKELY(SvAMAGIC(sv))) {
3536 sv = amagic_deref_call(sv, to_av_amg);
3537 }
3538 sv = SvRV(sv);
3539 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
3540 DIE(aTHX_ "Not an ARRAY reference");
3541 }
3542 else if (SvTYPE(sv) != SVt_PVAV) {
3543 if (!isGV_with_GP(sv))
3544 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
3545 sv = MUTABLE_SV(GvAVn((GV*)sv));
3546 }
3547 /* FALLTHROUGH */
3549 do_AV_aelem:
3550 {
3551 /* retrieve the key; this may be either a lexical or package
3552 * var (whose index/ptr is stored as an item) or a signed
3553 * integer constant stored as an item.
3554 */
3555 SV *elemsv;
3556 IV elem = 0; /* to shut up stupid compiler warnings */
3559 assert(SvTYPE(sv) == SVt_PVAV);
3561 switch (actions & MDEREF_INDEX_MASK) {
3562 case MDEREF_INDEX_none:
3563 goto finish;
3564 case MDEREF_INDEX_const:
3565 elem = (++items)->iv;
3566 break;
3567 case MDEREF_INDEX_padsv:
3568 elemsv = PAD_SVl((++items)->pad_offset);
3569 goto check_elem;
3570 case MDEREF_INDEX_gvsv:
3571 elemsv = UNOP_AUX_item_sv(++items);
3572 assert(isGV_with_GP(elemsv));
3573 elemsv = GvSVn((GV*)elemsv);
3574 check_elem:
3575 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
3576 && ckWARN(WARN_MISC)))
3577 Perl_warner(aTHX_ packWARN(WARN_MISC),
3578 "Use of reference \"%" SVf "\" as array index",
3579 SVfARG(elemsv));
3580 /* the only time that S_find_uninit_var() needs this
3581 * is to determine which index value triggered the
3582 * undef warning. So just update it here. Note that
3583 * since we don't save and restore this var (e.g. for
3584 * tie or overload execution), its value will be
3585 * meaningless apart from just here */
3586 PL_multideref_pc = items;
3587 elem = SvIV(elemsv);
3588 break;
3589 }
3592 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
3594 if (!(actions & MDEREF_FLAG_last)) {
3595 SV** svp = av_fetch((AV*)sv, elem, 1);
3596 if (!svp || ! (sv=*svp))
3597 DIE(aTHX_ PL_no_aelem, elem);
3598 break;
3599 }
3601 if (PL_op->op_private &
3602 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3603 {
3604 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3605 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
3606 }
3607 else {
3608 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3609 sv = av_delete((AV*)sv, elem, discard);
3610 if (discard)
3611 return NORMAL;
3612 if (!sv)
3613 sv = &PL_sv_undef;
3614 }
3615 }
3616 else {
3617 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3618 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3619 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3620 bool preeminent = TRUE;
3621 AV *const av = (AV*)sv;
3622 SV** svp;
3624 if (UNLIKELY(localizing)) {
3625 MAGIC *mg;
3626 HV *stash;
3628 /* If we can determine whether the element exist,
3629 * Try to preserve the existenceness of a tied array
3630 * element by using EXISTS and DELETE if possible.
3631 * Fallback to FETCH and STORE otherwise. */
3632 if (SvCANEXISTDELETE(av))
3633 preeminent = av_exists(av, elem);
3634 }
3636 svp = av_fetch(av, elem, lval && !defer);
3638 if (lval) {
3639 if (!svp || !(sv = *svp)) {
3640 IV len;
3641 if (!defer)
3642 DIE(aTHX_ PL_no_aelem, elem);
3643 len = av_top_index(av);
3644 /* Resolve a negative index that falls within
3645 * the array. Leave it negative it if falls
3646 * outside the array. */
3647 if (elem < 0 && len + elem >= 0)
3648 elem = len + elem;
3649 if (elem >= 0 && elem <= len)
3650 /* Falls within the array. */
3651 sv = av_nonelem(av,elem);
3652 else
3653 /* Falls outside the array. If it is neg-
3654 ative, magic_setdefelem will use the
3655 index for error reporting. */
3656 sv = sv_2mortal(newSVavdefelem(av,elem,1));
3657 }
3658 else {
3659 if (UNLIKELY(localizing)) {
3660 if (preeminent) {
3661 save_aelem(av, elem, svp);
3662 sv = *svp; /* may have changed */
3663 }
3664 else
3665 SAVEADELETE(av, elem);
3666 }
3667 }
3668 }
3669 else {
3670 sv = (svp ? *svp : &PL_sv_undef);
3671 /* see note in pp_helem() */
3672 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
3673 mg_get(sv);
3674 }
3675 }
3677 }
3678 finish:
3679 {
3680 dSP;
3681 XPUSHs(sv);
3682 RETURN;
3683 }
3684 /* NOTREACHED */
3689 case MDEREF_HV_padhv_helem: /* $lex{...} */
3690 sv = PAD_SVl((++items)->pad_offset);
3691 goto do_HV_helem;
3693 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
3694 sv = UNOP_AUX_item_sv(++items);
3695 assert(isGV_with_GP(sv));
3696 sv = (SV*)GvHVn((GV*)sv);
3697 goto do_HV_helem;
3699 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
3700 {
3701 dSP;
3702 sv = POPs;
3703 PUTBACK;
3704 goto do_HV_rv2hv_helem;
3705 }
3707 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
3708 sv = UNOP_AUX_item_sv(++items);
3709 assert(isGV_with_GP(sv));
3710 sv = GvSVn((GV*)sv);
3711 goto do_HV_vivify_rv2hv_helem;
3713 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
3714 sv = PAD_SVl((++items)->pad_offset);
3715 /* FALLTHROUGH */
3717 do_HV_vivify_rv2hv_helem:
3718 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
3719 /* this is the OPpDEREF action normally found at the end of
3720 * ops like aelem, helem, rv2sv */
3721 sv = vivify_ref(sv, OPpDEREF_HV);
3722 /* FALLTHROUGH */
3724 do_HV_rv2hv_helem:
3725 /* this is basically a copy of pp_rv2hv when it just has the
3726 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
3728 SvGETMAGIC(sv);
3729 if (LIKELY(SvROK(sv))) {
3730 if (UNLIKELY(SvAMAGIC(sv))) {
3731 sv = amagic_deref_call(sv, to_hv_amg);
3732 }
3733 sv = SvRV(sv);
3734 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
3735 DIE(aTHX_ "Not a HASH reference");
3736 }
3737 else if (SvTYPE(sv) != SVt_PVHV) {
3738 if (!isGV_with_GP(sv))
3739 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
3740 sv = MUTABLE_SV(GvHVn((GV*)sv));
3741 }
3742 /* FALLTHROUGH */
3744 do_HV_helem:
3745 {
3746 /* retrieve the key; this may be either a lexical / package
3747 * var or a string constant, whose index/ptr is stored as an
3748 * item
3749 */
3750 SV *keysv = NULL; /* to shut up stupid compiler warnings */
3752 assert(SvTYPE(sv) == SVt_PVHV);
3754 switch (actions & MDEREF_INDEX_MASK) {
3755 case MDEREF_INDEX_none:
3756 goto finish;
3758 case MDEREF_INDEX_const:
3759 keysv = UNOP_AUX_item_sv(++items);
3760 break;
3762 case MDEREF_INDEX_padsv:
3763 keysv = PAD_SVl((++items)->pad_offset);
3764 break;
3766 case MDEREF_INDEX_gvsv:
3767 keysv = UNOP_AUX_item_sv(++items);
3768 keysv = GvSVn((GV*)keysv);
3769 break;
3770 }
3772 /* see comment above about setting this var */
3773 PL_multideref_pc = items;
3776 /* ensure that candidate CONSTs have been HEKified */
3777 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
3778 || SvTYPE(keysv) >= SVt_PVMG
3779 || !SvOK(keysv)
3780 || SvROK(keysv)
3781 || SvIsCOW_shared_hash(keysv));
3783 /* this is basically a copy of pp_helem with OPpDEREF skipped */
3785 if (!(actions & MDEREF_FLAG_last)) {
3786 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
3787 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
3788 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3789 break;
3790 }
3792 if (PL_op->op_private &
3793 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3794 {
3795 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3796 sv = hv_exists_ent((HV*)sv, keysv, 0)
3797 ? &PL_sv_yes : &PL_sv_no;
3798 }
3799 else {
3800 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3801 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
3802 if (discard)
3803 return NORMAL;
3804 if (!sv)
3805 sv = &PL_sv_undef;
3806 }
3807 }
3808 else {
3809 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3810 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3811 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3812 bool preeminent = TRUE;
3813 SV **svp;
3814 HV * const hv = (HV*)sv;
3815 HE* he;
3817 if (UNLIKELY(localizing)) {
3818 MAGIC *mg;
3819 HV *stash;
3821 /* If we can determine whether the element exist,
3822 * Try to preserve the existenceness of a tied hash
3823 * element by using EXISTS and DELETE if possible.
3824 * Fallback to FETCH and STORE otherwise. */
3825 if (SvCANEXISTDELETE(hv))
3826 preeminent = hv_exists_ent(hv, keysv, 0);
3827 }
3829 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3830 svp = he ? &HeVAL(he) : NULL;
3833 if (lval) {
3834 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
3835 SV* lv;
3836 SV* key2;
3837 if (!defer)
3838 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3839 lv = sv_newmortal();
3840 sv_upgrade(lv, SVt_PVLV);
3841 LvTYPE(lv) = 'y';
3842 sv_magic(lv, key2 = newSVsv(keysv),
3843 PERL_MAGIC_defelem, NULL, 0);
3844 /* sv_magic() increments refcount */
3845 SvREFCNT_dec_NN(key2);
3846 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3847 LvTARGLEN(lv) = 1;
3848 sv = lv;
3849 }
3850 else {
3851 if (localizing) {
3852 if (HvNAME_get(hv) && isGV_or_RVCV(sv))
3853 save_gp(MUTABLE_GV(sv),
3854 !(PL_op->op_flags & OPf_SPECIAL));
3855 else if (preeminent) {
3856 save_helem_flags(hv, keysv, svp,
3857 (PL_op->op_flags & OPf_SPECIAL)
3858 ? 0 : SAVEf_SETMAGIC);
3859 sv = *svp; /* may have changed */
3860 }
3861 else
3862 SAVEHDELETE(hv, keysv);
3863 }
3864 }
3865 }
3866 else {
3867 sv = (svp && *svp ? *svp : &PL_sv_undef);
3868 /* see note in pp_helem() */
3869 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
3870 mg_get(sv);
3871 }
3872 }
3873 goto finish;
3874 }
3876 } /* switch */
3878 actions >>= MDEREF_SHIFT;
3879 } /* while */
3880 /* NOTREACHED */
3881 }
3884 PP(pp_iter)
3885 {
3886 PERL_CONTEXT *cx;
3887 SV *oldsv;
3888 SV **itersvp;
3890 SV *sv;
3891 AV *av;
3892 IV ix;
3893 IV inc;
3895 cx = CX_CUR();
3896 itersvp = CxITERVAR(cx);
3897 assert(itersvp);
3899 switch (CxTYPE(cx)) {
3901 case CXt_LOOP_LAZYSV: /* string increment */
3902 {
3903 SV* cur = cx->blk_loop.state_u.lazysv.cur;
3904 SV *end = cx->blk_loop.state_u.lazysv.end;
3905 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
3906 It has SvPVX of "" and SvCUR of 0, which is what we want. */
3907 STRLEN maxlen = 0;
3908 const char *max = SvPV_const(end, maxlen);
3909 if (DO_UTF8(end) && IN_UNI_8_BIT)
3910 maxlen = sv_len_utf8_nomg(end);
3911 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
3912 goto retno;
3914 oldsv = *itersvp;
3915 /* NB: on the first iteration, oldsv will have a ref count of at
3916 * least 2 (one extra from blk_loop.itersave), so the GV or pad
3917 * slot will get localised; on subsequent iterations the RC==1
3918 * optimisation may kick in and the SV will be reused. */
3919 if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3920 /* safe to reuse old SV */
3921 sv_setsv(oldsv, cur);
3922 }
3923 else
3924 {
3925 /* we need a fresh SV every time so that loop body sees a
3926 * completely new SV for closures/references to work as
3927 * they used to */
3928 *itersvp = newSVsv(cur);
3929 SvREFCNT_dec(oldsv);
3930 }
3931 if (strEQ(SvPVX_const(cur), max))
3932 sv_setiv(cur, 0); /* terminate next time */
3933 else
3934 sv_inc(cur);
3935 break;
3936 }
3938 case CXt_LOOP_LAZYIV: /* integer increment */
3939 {
3940 IV cur = cx->blk_loop.state_u.lazyiv.cur;
3941 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
3942 goto retno;
3944 oldsv = *itersvp;
3945 /* see NB comment above */
3946 if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3947 /* safe to reuse old SV */
3949 if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
3950 == SVt_IV)
3951 {
3952 /* Cheap SvIOK_only().
3953 * Assert that flags which SvIOK_only() would test or
3954 * clear can't be set, because we're SVt_IV */
3955 assert(!(SvFLAGS(oldsv) &
3956 (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
3957 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
3958 /* SvIV_set() where sv_any points to head */
3959 oldsv->sv_u.svu_iv = cur;
3961 }
3962 else
3963 sv_setiv(oldsv, cur);
3964 }
3965 else
3966 {
3967 /* we need a fresh SV every time so that loop body sees a
3968 * completely new SV for closures/references to work as they
3969 * used to */
3970 *itersvp = newSViv(cur);
3971 SvREFCNT_dec(oldsv);
3972 }
3974 if (UNLIKELY(cur == IV_MAX)) {
3975 /* Handle end of range at IV_MAX */
3976 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
3977 } else
3978 ++cx->blk_loop.state_u.lazyiv.cur;
3979 break;
3980 }
3982 case CXt_LOOP_LIST: /* for (1,2,3) */
3984 assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
3985 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
3986 ix = (cx->blk_loop.state_u.stack.ix += inc);
3987 if (UNLIKELY(inc > 0
3988 ? ix > cx->blk_oldsp
3989 : ix <= cx->blk_loop.state_u.stack.basesp)
3990 )
3991 goto retno;
3993 sv = PL_stack_base[ix];
3994 av = NULL;
3995 goto loop_ary_common;
3997 case CXt_LOOP_ARY: /* for (@ary) */
3999 av = cx->blk_loop.state_u.ary.ary;
4000 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
4001 ix = (cx->blk_loop.state_u.ary.ix += inc);
4002 if (UNLIKELY(inc > 0
4003 ? ix > AvFILL(av)
4004 : ix < 0)
4005 )
4006 goto retno;
4008 if (UNLIKELY(SvRMAGICAL(av))) {
4009 SV * const * const svp = av_fetch(av, ix, FALSE);
4010 sv = svp ? *svp : NULL;
4011 }
4012 else {
4013 sv = AvARRAY(av)[ix];
4014 }
4016 loop_ary_common:
4018 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
4019 SvSetMagicSV(*itersvp, sv);
4020 break;
4021 }
4023 if (LIKELY(sv)) {
4024 if (UNLIKELY(SvIS_FREED(sv))) {
4025 *itersvp = NULL;
4026 Perl_croak(aTHX_ "Use of freed value in iteration");
4027 }
4028 if (SvPADTMP(sv)) {
4029 sv = newSVsv(sv);
4030 }
4031 else {
4032 SvTEMP_off(sv);
4033 SvREFCNT_inc_simple_void_NN(sv);
4034 }
4035 }
4036 else if (av) {
4037 sv = newSVavdefelem(av, ix, 0);
4038 }
4039 else
4040 sv = &PL_sv_undef;
4042 oldsv = *itersvp;
4043 *itersvp = sv;
4044 SvREFCNT_dec(oldsv);
4045 break;
4047 default:
4048 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
4049 }
4051 /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead
4052 * jump straight to the AND op's op_other */
4053 assert(PL_op->op_next->op_type == OP_AND);
4054 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
4055 return cLOGOPx(PL_op->op_next)->op_other;
4056 }
4057 else {
4058 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
4059 * obvious way. */
4060 /* pp_enteriter should have pre-extended the stack */
4061 EXTEND_SKIP(PL_stack_sp, 1);
4062 *++PL_stack_sp = &PL_sv_yes;
4063 return PL_op->op_next;
4064 }
4066 retno:
4067 /* Try to bypass pushing &PL_sv_no and calling pp_and(); instead
4068 * jump straight to the AND op's op_next */
4069 assert(PL_op->op_next->op_type == OP_AND);
4070 /* pp_enteriter should have pre-extended the stack */
4071 EXTEND_SKIP(PL_stack_sp, 1);
4072 /* we only need this for the rare case where the OP_AND isn't
4073 * in void context, e.g. $x = do { for (..) {...} };
4074 * (or for when an XS module has replaced the op_ppaddr)
4075 * but it's cheaper to just push it rather than testing first
4076 */
4077 *++PL_stack_sp = &PL_sv_no;
4078 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
4079 return PL_op->op_next->op_next;
4080 }
4081 else {
4082 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
4083 * obvious way. */
4084 return PL_op->op_next;
4085 }
4086 }
4089 /*
4090 A description of how taint works in pattern matching and substitution.
4092 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
4093 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
4095 While the pattern is being assembled/concatenated and then compiled,
4096 PL_tainted will get set (via TAINT_set) if any component of the pattern
4097 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
4098 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
4099 TAINT_get). It will also be set if any component of the pattern matches
4100 based on locale-dependent behavior.
4102 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
4103 the pattern is marked as tainted. This means that subsequent usage, such
4104 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
4105 on the new pattern too.
4107 RXf_TAINTED_SEEN is used post-execution by the get magic code
4108 of $1 et al to indicate whether the returned value should be tainted.
4109 It is the responsibility of the caller of the pattern (i.e. pp_match,
4110 pp_subst etc) to set this flag for any other circumstances where $1 needs
4111 to be tainted.
4113 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
4115 There are three possible sources of taint
4116 * the source string
4117 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
4118 * the replacement string (or expression under /e)
4120 There are four destinations of taint and they are affected by the sources
4121 according to the rules below:
4123 * the return value (not including /r):
4124 tainted by the source string and pattern, but only for the
4125 number-of-iterations case; boolean returns aren't tainted;
4126 * the modified string (or modified copy under /r):
4127 tainted by the source string, pattern, and replacement strings;
4128 * $1 et al:
4129 tainted by the pattern, and under 'use re "taint"', by the source
4130 string too;
4131 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
4132 should always be unset before executing subsequent code.
4134 The overall action of pp_subst is:
4136 * at the start, set bits in rxtainted indicating the taint status of
4137 the various sources.
4139 * After each pattern execution, update the SUBST_TAINT_PAT bit in
4140 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
4141 pattern has subsequently become tainted via locale ops.
4143 * If control is being passed to pp_substcont to execute a /e block,
4144 save rxtainted in the CXt_SUBST block, for future use by
4145 pp_substcont.
4147 * Whenever control is being returned to perl code (either by falling
4148 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
4149 use the flag bits in rxtainted to make all the appropriate types of
4150 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
4151 et al will appear tainted.
4153 pp_match is just a simpler version of the above.
4155 */
4157 PP(pp_subst)
4158 {
4159 dSP; dTARG;
4160 PMOP *pm = cPMOP;
4161 PMOP *rpm = pm;
4162 char *s;
4163 char *strend;
4164 const char *c;
4165 STRLEN clen;
4166 SSize_t iters = 0;
4167 SSize_t maxiters;
4168 bool once;
4169 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
4170 See "how taint works" above */
4171 char *orig;
4172 U8 r_flags;
4173 REGEXP *rx = PM_GETRE(pm);
4174 regexp *prog = ReANY(rx);
4175 STRLEN len;
4176 int force_on_match = 0;
4177 const I32 oldsave = PL_savestack_ix;
4178 STRLEN slen;
4179 bool doutf8 = FALSE; /* whether replacement is in utf8 */
4180 #ifdef PERL_ANY_COW
4181 bool was_cow;
4182 #endif
4183 SV *nsv = NULL;
4184 /* known replacement string? */
4185 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
4187 PERL_ASYNC_CHECK();
4189 if (PL_op->op_flags & OPf_STACKED)
4190 TARG = POPs;
4191 else {
4192 if (ARGTARG)
4193 GETTARGET;
4194 else {
4195 TARG = DEFSV;
4196 }
4197 EXTEND(SP,1);
4198 }
4200 SvGETMAGIC(TARG); /* must come before cow check */
4201 #ifdef PERL_ANY_COW
4202 /* note that a string might get converted to COW during matching */
4203 was_cow = cBOOL(SvIsCOW(TARG));
4204 #endif
4205 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4206 #ifndef PERL_ANY_COW
4207 if (SvIsCOW(TARG))
4208 sv_force_normal_flags(TARG,0);
4209 #endif
4210 if ((SvREADONLY(TARG)
4211 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
4212 || SvTYPE(TARG) > SVt_PVLV)
4213 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
4214 Perl_croak_no_modify();
4215 }
4216 PUTBACK;
4218 orig = SvPV_nomg(TARG, len);
4219 /* note we don't (yet) force the var into being a string; if we fail
4220 * to match, we leave as-is; on successful match however, we *will*
4221 * coerce into a string, then repeat the match */
4222 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
4223 force_on_match = 1;
4225 /* only replace once? */
4226 once = !(rpm->op_pmflags & PMf_GLOBAL);
4228 /* See "how taint works" above */
4229 if (TAINTING_get) {
4230 rxtainted = (
4231 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
4232 | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
4233 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
4234 | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4235 || (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0));
4236 TAINT_NOT;
4237 }
4239 force_it:
4240 if (!pm || !orig)
4241 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
4243 strend = orig + len;
4244 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
4245 maxiters = 2 * slen + 10; /* We can match twice at each
4246 position, once with zero-length,
4247 second time with non-zero. */
4249 /* handle the empty pattern */
4250 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
4251 if (PL_curpm == PL_reg_curpm) {
4252 if (PL_curpm_under) {
4253 if (PL_curpm_under == PL_reg_curpm) {
4254 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
4255 } else {
4256 pm = PL_curpm_under;
4257 }
4258 }
4259 } else {
4260 pm = PL_curpm;
4261 }
4262 rx = PM_GETRE(pm);
4263 prog = ReANY(rx);
4264 }
4266 #ifdef PERL_SAWAMPERSAND
4267 r_flags = ( RXp_NPARENS(prog)
4268 || PL_sawampersand
4269 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
4270 || (rpm->op_pmflags & PMf_KEEPCOPY)
4271 )
4272 ? REXEC_COPY_STR
4273 : 0;
4274 #else
4275 r_flags = REXEC_COPY_STR;
4276 #endif
4278 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
4279 {
4280 SPAGAIN;
4281 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
4282 LEAVE_SCOPE(oldsave);
4283 RETURN;
4284 }
4285 PL_curpm = pm;
4287 /* known replacement string? */
4288 if (dstr) {
4289 /* replacement needing upgrading? */
4290 if (DO_UTF8(TARG) && !doutf8) {
4291 nsv = sv_newmortal();
4292 SvSetSV(nsv, dstr);
4293 sv_utf8_upgrade(nsv);
4294 c = SvPV_const(nsv, clen);
4295 doutf8 = TRUE;
4296 }
4297 else {
4298 c = SvPV_const(dstr, clen);
4299 doutf8 = DO_UTF8(dstr);
4300 }
4302 if (UNLIKELY(TAINT_get))
4303 rxtainted |= SUBST_TAINT_REPL;
4304 }
4305 else {
4306 c = NULL;
4307 doutf8 = FALSE;
4308 }
4310 /* can do inplace substitution? */
4311 if (c
4312 #ifdef PERL_ANY_COW
4313 && !was_cow
4314 #endif
4315 && (I32)clen <= RXp_MINLENRET(prog)
4316 && ( once
4317 || !(r_flags & REXEC_COPY_STR)
4318 || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
4319 )
4320 && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
4321 && (!doutf8 || SvUTF8(TARG))
4322 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4323 {
4325 #ifdef PERL_ANY_COW
4326 /* string might have got converted to COW since we set was_cow */
4327 if (SvIsCOW(TARG)) {
4328 if (!force_on_match)
4329 goto have_a_cow;
4330 assert(SvVOK(TARG));
4331 }
4332 #endif
4333 if (force_on_match) {
4334 /* redo the first match, this time with the orig var
4335 * forced into being a string */
4336 force_on_match = 0;
4337 orig = SvPV_force_nomg(TARG, len);
4338 goto force_it;
4339 }
4341 if (once) {
4342 char *d, *m;
4343 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4344 rxtainted |= SUBST_TAINT_PAT;
4345 m = orig + RXp_OFFS(prog)[0].start;
4346 d = orig + RXp_OFFS(prog)[0].end;
4347 s = orig;
4348 if (m - s > strend - d) { /* faster to shorten from end */
4349 I32 i;
4350 if (clen) {
4351 Copy(c, m, clen, char);
4352 m += clen;
4353 }
4354 i = strend - d;
4355 if (i > 0) {
4356 Move(d, m, i, char);
4357 m += i;
4358 }
4359 *m = '\0';
4360 SvCUR_set(TARG, m - s);
4361 }
4362 else { /* faster from front */
4363 I32 i = m - s;
4364 d -= clen;
4365 if (i > 0)
4366 Move(s, d - i, i, char);
4367 sv_chop(TARG, d-i);
4368 if (clen)
4369 Copy(c, d, clen, char);
4370 }
4371 SPAGAIN;
4372 PUSHs(&PL_sv_yes);
4373 }
4374 else {
4375 char *d, *m;
4376 d = s = RXp_OFFS(prog)[0].start + orig;
4377 do {
4378 I32 i;
4379 if (UNLIKELY(iters++ > maxiters))
4380 DIE(aTHX_ "Substitution loop");
4381 /* run time pattern taint, eg locale */
4382 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4383 rxtainted |= SUBST_TAINT_PAT;
4384 m = RXp_OFFS(prog)[0].start + orig;
4385 if ((i = m - s)) {
4386 if (s != d)
4387 Move(s, d, i, char);
4388 d += i;
4389 }
4390 if (clen) {
4391 Copy(c, d, clen, char);
4392 d += clen;
4393 }
4394 s = RXp_OFFS(prog)[0].end + orig;
4395 } while (CALLREGEXEC(rx, s, strend, orig,
4396 s == m, /* don't match same null twice */
4397 TARG, NULL,
4398 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4399 if (s != d) {
4400 I32 i = strend - s;
4401 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
4402 Move(s, d, i+1, char); /* include the NUL */
4403 }
4404 SPAGAIN;
4405 assert(iters);
4406 if (PL_op->op_private & OPpTRUEBOOL)
4407 PUSHs(&PL_sv_yes);
4408 else
4409 mPUSHi(iters);
4410 }
4411 }
4412 else {
4413 bool first;
4414 char *m;
4415 SV *repl;
4416 if (force_on_match) {
4417 /* redo the first match, this time with the orig var
4418 * forced into being a string */
4419 force_on_match = 0;
4420 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4421 /* I feel that it should be possible to avoid this mortal copy
4422 given that the code below copies into a new destination.
4423 However, I suspect it isn't worth the complexity of
4424 unravelling the C<goto force_it> for the small number of
4425 cases where it would be viable to drop into the copy code. */
4426 TARG = sv_2mortal(newSVsv(TARG));
4427 }
4428 orig = SvPV_force_nomg(TARG, len);
4429 goto force_it;
4430 }
4431 #ifdef PERL_ANY_COW
4432 have_a_cow:
4433 #endif
4434 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4435 rxtainted |= SUBST_TAINT_PAT;
4436 repl = dstr;
4437 s = RXp_OFFS(prog)[0].start + orig;
4438 dstr = newSVpvn_flags(orig, s-orig,
4439 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
4440 if (!c) {
4441 PERL_CONTEXT *cx;
4442 SPAGAIN;
4443 m = orig;
4444 /* note that a whole bunch of local vars are saved here for
4445 * use by pp_substcont: here's a list of them in case you're
4446 * searching for places in this sub that uses a particular var:
4447 * iters maxiters r_flags oldsave rxtainted orig dstr targ
4448 * s m strend rx once */
4449 CX_PUSHSUBST(cx);
4450 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
4451 }
4452 first = TRUE;
4453 do {
4454 if (UNLIKELY(iters++ > maxiters))
4455 DIE(aTHX_ "Substitution loop");
4456 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4457 rxtainted |= SUBST_TAINT_PAT;
4458 if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
4459 char *old_s = s;
4460 char *old_orig = orig;
4461 assert(RXp_SUBOFFSET(prog) == 0);
4463 orig = RXp_SUBBEG(prog);
4464 s = orig + (old_s - old_orig);
4465 strend = s + (strend - old_s);
4466 }
4467 m = RXp_OFFS(prog)[0].start + orig;
4468 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
4469 s = RXp_OFFS(prog)[0].end + orig;
4470 if (first) {
4471 /* replacement already stringified */
4472 if (clen)
4473 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
4474 first = FALSE;
4475 }
4476 else {
4477 sv_catsv(dstr, repl);
4478 }
4479 if (once)
4480 break;
4481 } while (CALLREGEXEC(rx, s, strend, orig,
4482 s == m, /* Yields minend of 0 or 1 */
4483 TARG, NULL,
4484 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4485 assert(strend >= s);
4486 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
4488 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4489 /* From here on down we're using the copy, and leaving the original
4490 untouched. */
4491 TARG = dstr;
4492 SPAGAIN;
4493 PUSHs(dstr);
4494 } else {
4495 #ifdef PERL_ANY_COW
4496 /* The match may make the string COW. If so, brilliant, because
4497 that's just saved us one malloc, copy and free - the regexp has
4498 donated the old buffer, and we malloc an entirely new one, rather
4499 than the regexp malloc()ing a buffer and copying our original,
4500 only for us to throw it away here during the substitution. */
4501 if (SvIsCOW(TARG)) {
4502 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
4503 } else
4504 #endif
4505 {
4506 SvPV_free(TARG);
4507 }
4508 SvPV_set(TARG, SvPVX(dstr));
4509 SvCUR_set(TARG, SvCUR(dstr));
4510 SvLEN_set(TARG, SvLEN(dstr));
4511 SvFLAGS(TARG) |= SvUTF8(dstr);
4512 SvPV_set(dstr, NULL);
4514 SPAGAIN;
4515 if (PL_op->op_private & OPpTRUEBOOL)
4516 PUSHs(&PL_sv_yes);
4517 else
4518 mPUSHi(iters);
4519 }
4520 }
4522 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4523 (void)SvPOK_only_UTF8(TARG);
4524 }
4526 /* See "how taint works" above */
4527 if (TAINTING_get) {
4528 if ((rxtainted & SUBST_TAINT_PAT) ||
4529 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
4530 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
4531 )
4532 (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
4534 if (!(rxtainted & SUBST_TAINT_BOOLRET)
4535 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
4536 )
4537 SvTAINTED_on(TOPs); /* taint return value */
4538 else
4539 SvTAINTED_off(TOPs); /* may have got tainted earlier */
4541 /* needed for mg_set below */
4542 TAINT_set(
4543 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
4544 );
4545 SvTAINT(TARG);
4546 }
4547 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
4548 TAINT_NOT;
4549 LEAVE_SCOPE(oldsave);
4550 RETURN;
4551 }
4553 PP(pp_grepwhile)
4554 {
4555 dSP;
4556 dPOPss;
4558 if (SvTRUE_NN(sv))
4559 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
4560 ++*PL_markstack_ptr;
4561 FREETMPS;
4562 LEAVE_with_name("grep_item"); /* exit inner scope */
4564 /* All done yet? */
4565 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
4566 I32 items;
4567 const U8 gimme = GIMME_V;
4569 LEAVE_with_name("grep"); /* exit outer scope */
4570 (void)POPMARK; /* pop src */
4571 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
4572 (void)POPMARK; /* pop dst */
4573 SP = PL_stack_base + POPMARK; /* pop original mark */
4574 if (gimme == G_SCALAR) {
4575 if (PL_op->op_private & OPpTRUEBOOL)
4576 PUSHs(items ? &PL_sv_yes : &PL_sv_zero);
4577 else {
4578 dTARGET;
4579 PUSHi(items);
4580 }
4581 }
4582 else if (gimme == G_ARRAY)
4583 SP += items;
4584 RETURN;
4585 }
4586 else {
4587 SV *src;
4589 ENTER_with_name("grep_item"); /* enter inner scope */
4590 SAVEVPTR(PL_curpm);
4592 src = PL_stack_base[TOPMARK];
4593 if (SvPADTMP(src)) {
4594 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
4595 PL_tmps_floor++;
4596 }
4597 SvTEMP_off(src);
4598 DEFSV_set(src);
4600 RETURNOP(cLOGOP->op_other);
4601 }
4602 }
4604 /* leave_adjust_stacks():
4605 *
4606 * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
4607 * positioning them at to_sp+1 onwards, and do the equivalent of a
4608 * FREEMPS and TAINT_NOT.
4609 *
4610 * Not intended to be called in void context.
4611 *
4612 * When leaving a sub, eval, do{} or other scope, the things that need
4613 * doing to process the return args are:
4614 * * in scalar context, only return the last arg (or PL_sv_undef if none);
4615 * * for the types of return that return copies of their args (such
4616 * as rvalue sub return), make a mortal copy of every return arg,
4617 * except where we can optimise the copy away without it being
4618 * semantically visible;
4619 * * make sure that the arg isn't prematurely freed; in the case of an
4620 * arg not copied, this may involve mortalising it. For example, in
4621 * C<sub f { my $x = ...; $x }>, $x would be freed when we do
4622 * CX_LEAVE_SCOPE(cx) unless it's protected or copied.
4623 *
4624 * What condition to use when deciding whether to pass the arg through
4625 * or make a copy, is determined by the 'pass' arg; its valid values are:
4626 * 0: rvalue sub/eval exit
4627 * 1: other rvalue scope exit
4628 * 2: :lvalue sub exit in rvalue context
4629 * 3: :lvalue sub exit in lvalue context and other lvalue scope exits
4630 *
4631 * There is a big issue with doing a FREETMPS. We would like to free any
4632 * temps created by the last statement which the sub executed, rather than
4633 * leaving them for the caller. In a situation where a sub call isn't
4634 * soon followed by a nextstate (e.g. nested recursive calls, a la
4635 * fibonacci()), temps can accumulate, causing memory and performance
4636 * issues.
4637 *
4638 * On the other hand, we don't want to free any TEMPs which are keeping
4639 * alive any return args that we skipped copying; nor do we wish to undo
4640 * any mortalising done here.
4641 *
4642 * The solution is to split the temps stack frame into two, with a cut
4643 * point delineating the two halves. We arrange that by the end of this
4644 * function, all the temps stack frame entries we wish to keep are in the
4645 * range PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
4646 * the range tmps_base .. PL_tmps_ix. During the course of this
4647 * function, tmps_base starts off as PL_tmps_floor+1, then increases
4648 * whenever we find or create a temp that we know should be kept. In
4649 * general the stuff above tmps_base is undecided until we reach the end,
4650 * and we may need a sort stage for that.
4651 *
4652 * To determine whether a TEMP is keeping a return arg alive, every
4653 * arg that is kept rather than copied and which has the SvTEMP flag
4654 * set, has the flag temporarily unset, to mark it. At the end we scan
4655 * the temps stack frame above the cut for entries without SvTEMP and
4656 * keep them, while turning SvTEMP on again. Note that if we die before
4657 * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
4658 * those SVs may be slightly less efficient.
4659 *
4660 * In practice various optimisations for some common cases mean we can
4661 * avoid most of the scanning and swapping about with the temps stack.
4662 */
4664 void
4665 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
4666 {
4667 dSP;
4668 SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
4669 SSize_t nargs;
4671 PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
4673 TAINT_NOT;
4675 if (gimme == G_ARRAY) {
4676 nargs = SP - from_sp;
4677 from_sp++;
4678 }
4679 else {
4680 assert(gimme == G_SCALAR);
4681 if (UNLIKELY(from_sp >= SP)) {
4682 /* no return args */
4683 assert(from_sp == SP);
4684 EXTEND(SP, 1);
4685 *++SP = &PL_sv_undef;
4686 to_sp = SP;
4687 nargs = 0;
4688 }
4689 else {
4690 from_sp = SP;
4691 nargs = 1;
4692 }
4693 }
4695 /* common code for G_SCALAR and G_ARRAY */
4697 tmps_base = PL_tmps_floor + 1;
4699 assert(nargs >= 0);
4700 if (nargs) {
4701 /* pointer version of tmps_base. Not safe across temp stack
4702 * reallocs. */
4703 SV **tmps_basep;
4705 EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
4706 tmps_basep = PL_tmps_stack + tmps_base;
4708 /* process each return arg */
4710 do {
4711 SV *sv = *from_sp++;
4713 assert(PL_tmps_ix + nargs < PL_tmps_max);
4714 #ifdef DEBUGGING
4715 /* PADTMPs with container set magic shouldn't appear in the
4716 * wild. This assert is more important for pp_leavesublv(),
4717 * but by testing for it here, we're more likely to catch
4718 * bad cases (what with :lvalue subs not being widely
4719 * deployed). The two issues are that for something like
4720 * sub :lvalue { $tied{foo} }
4721 * or
4722 * sub :lvalue { substr($foo,1,2) }
4723 * pp_leavesublv() will croak if the sub returns a PADTMP,
4724 * and currently functions like pp_substr() return a mortal
4725 * rather than using their PADTMP when returning a PVLV.
4726 * This is because the PVLV will hold a ref to $foo,
4727 * so $foo would get delayed in being freed while
4728 * the PADTMP SV remained in the PAD.
4729 * So if this assert fails it means either:
4730 * 1) there is pp code similar to pp_substr that is
4731 * returning a PADTMP instead of a mortal, and probably
4732 * needs fixing, or
4733 * 2) pp_leavesublv is making unwarranted assumptions
4734 * about always croaking on a PADTMP
4735 */
4736 if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
4737 MAGIC *mg;
4738 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
4739 assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
4740 }
4741 }
4742 #endif
4744 if (
4745 pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
4746 : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
4747 : pass == 2 ? (!SvPADTMP(sv))
4748 : 1)
4749 {
4750 /* pass through: skip copy for logic or optimisation
4751 * reasons; instead mortalise it, except that ... */
4752 *++to_sp = sv;
4754 if (SvTEMP(sv)) {
4755 /* ... since this SV is an SvTEMP , we don't need to
4756 * re-mortalise it; instead we just need to ensure
4757 * that its existing entry in the temps stack frame
4758 * ends up below the cut and so avoids being freed
4759 * this time round. We mark it as needing to be kept
4760 * by temporarily unsetting SvTEMP; then at the end,
4761 * we shuffle any !SvTEMP entries on the tmps stack
4762 * back below the cut.
4763 * However, there's a significant chance that there's
4764 * a 1:1 correspondence between the first few (or all)
4765 * elements in the return args stack frame and those
4766 * in the temps stack frame; e,g.:
4767 * sub f { ....; map {...} .... },
4768 * or if we're exiting multiple scopes and one of the
4769 * inner scopes has already made mortal copies of each
4770 * return arg.
4771 *
4772 * If so, this arg sv will correspond to the next item
4773 * on the tmps stack above the cut, and so can be kept
4774 * merely by moving the cut boundary up one, rather
4775 * than messing with SvTEMP. If all args are 1:1 then
4776 * we can avoid the sorting stage below completely.
4777 *
4778 * If there are no items above the cut on the tmps
4779 * stack, then the SvTEMP must comne from an item
4780 * below the cut, so there's nothing to do.
4781 */
4782 if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
4783 if (sv == *tmps_basep)
4784 tmps_basep++;
4785 else
4786 SvTEMP_off(sv);
4787 }
4788 }
4789 else if (!SvPADTMP(sv)) {
4790 /* mortalise arg to avoid it being freed during save
4791 * stack unwinding. Pad tmps don't need mortalising as
4792 * they're never freed. This is the equivalent of
4793 * sv_2mortal(SvREFCNT_inc(sv)), except that:
4794 * * it assumes that the temps stack has already been
4795 * extended;
4796 * * it puts the new item at the cut rather than at
4797 * ++PL_tmps_ix, moving the previous occupant there
4798 * instead.
4799 */
4800 if (!SvIMMORTAL(sv)) {
4801 SvREFCNT_inc_simple_void_NN(sv);
4802 SvTEMP_on(sv);
4803 /* Note that if there's nothing above the cut,
4804 * this copies the garbage one slot above
4805 * PL_tmps_ix onto itself. This is harmless (the
4806 * stack's already been extended), but might in
4807 * theory trigger warnings from tools like ASan
4808 */
4809 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
4810 *tmps_basep++ = sv;
4811 }
4812 }
4813 }
4814 else {
4815 /* Make a mortal copy of the SV.
4816 * The following code is the equivalent of sv_mortalcopy()
4817 * except that:
4818 * * it assumes the temps stack has already been extended;
4819 * * it optimises the copying for some simple SV types;
4820 * * it puts the new item at the cut rather than at
4821 * ++PL_tmps_ix, moving the previous occupant there
4822 * instead.
4823 */
4824 SV *newsv = newSV(0);
4826 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
4827 /* put it on the tmps stack early so it gets freed if we die */
4828 *tmps_basep++ = newsv;
4829 *++to_sp = newsv;
4831 if (SvTYPE(sv) <= SVt_IV) {
4832 /* arg must be one of undef, IV/UV, or RV: skip
4833 * sv_setsv_flags() and do the copy directly */
4834 U32 dstflags;
4835 U32 srcflags = SvFLAGS(sv);
4837 assert(!SvGMAGICAL(sv));
4838 if (srcflags & (SVf_IOK|SVf_ROK)) {
4839 SET_SVANY_FOR_BODYLESS_IV(newsv);
4841 if (srcflags & SVf_ROK) {
4842 newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
4843 /* SV type plus flags */
4844 dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
4845 }
4846 else {
4847 /* both src and dst are <= SVt_IV, so sv_any
4848 * points to the head; so access the heads
4849 * directly rather than going via sv_any.
4850 */
4851 assert( &(sv->sv_u.svu_iv)
4852 == &(((XPVIV*) SvANY(sv))->xiv_iv));
4853 assert( &(newsv->sv_u.svu_iv)
4854 == &(((XPVIV*) SvANY(newsv))->xiv_iv));
4855 newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
4856 /* SV type plus flags */
4857 dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
4858 |(srcflags & SVf_IVisUV));
4859 }
4860 }
4861 else {
4862 assert(!(srcflags & SVf_OK));
4863 dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
4864 }
4865 SvFLAGS(newsv) = dstflags;
4867 }
4868 else {
4869 /* do the full sv_setsv() */
4870 SSize_t old_base;
4872 SvTEMP_on(newsv);
4873 old_base = tmps_basep - PL_tmps_stack;
4874 SvGETMAGIC(sv);
4875 sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
4876 /* the mg_get or sv_setsv might have created new temps
4877 * or realloced the tmps stack; regrow and reload */
4878 EXTEND_MORTAL(nargs);
4879 tmps_basep = PL_tmps_stack + old_base;
4880 TAINT_NOT; /* Each item is independent */
4881 }
4883 }
4884 } while (--nargs);
4886 /* If there are any temps left above the cut, we need to sort
4887 * them into those to keep and those to free. The only ones to
4888 * keep are those for which we've temporarily unset SvTEMP.
4889 * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
4890 * swapping pairs as necessary. Stop when we meet in the middle.
4891 */
4892 {
4893 SV **top = PL_tmps_stack + PL_tmps_ix;
4894 while (tmps_basep <= top) {
4895 SV *sv = *top;
4896 if (SvTEMP(sv))
4897 top--;
4898 else {
4899 SvTEMP_on(sv);
4900 *top = *tmps_basep;
4901 *tmps_basep = sv;
4902 tmps_basep++;
4903 }
4904 }
4905 }
4907 tmps_base = tmps_basep - PL_tmps_stack;
4908 }
4910 PL_stack_sp = to_sp;
4912 /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
4913 while (PL_tmps_ix >= tmps_base) {
4914 SV* const sv = PL_tmps_stack[PL_tmps_ix--];
4915 #ifdef PERL_POISON
4916 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
4917 #endif
4918 if (LIKELY(sv)) {
4919 SvTEMP_off(sv);
4920 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
4921 }
4922 }
4923 }
4926 /* also tail-called by pp_return */
4928 PP(pp_leavesub)
4929 {
4930 U8 gimme;
4931 PERL_CONTEXT *cx;
4932 SV **oldsp;
4933 OP *retop;
4935 cx = CX_CUR();
4936 assert(CxTYPE(cx) == CXt_SUB);
4938 if (CxMULTICALL(cx)) {
4939 /* entry zero of a stack is always PL_sv_undef, which
4940 * simplifies converting a '()' return into undef in scalar context */
4941 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
4942 return 0;
4943 }
4945 gimme = cx->blk_gimme;
4946 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
4948 if (gimme == G_VOID)
4949 PL_stack_sp = oldsp;
4950 else
4951 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4953 CX_LEAVE_SCOPE(cx);
4954 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
4955 cx_popblock(cx);
4956 retop = cx->blk_sub.retop;
4957 CX_POP(cx);
4959 return retop;
4960 }
4963 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
4964 * forces an abandon */
4966 void
4967 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
4968 {
4969 const SSize_t fill = AvFILLp(av);
4971 PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
4973 if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) {
4974 av_clear(av);
4975 AvREIFY_only(av);
4976 }
4977 else {
4978 AV *newav = newAV();
4979 av_extend(newav, fill);
4980 AvREIFY_only(newav);
4981 PAD_SVl(0) = MUTABLE_SV(newav);
4982 SvREFCNT_dec_NN(av);
4983 }
4984 }
4987 PP(pp_entersub)
4988 {
4989 dSP; dPOPss;
4990 GV *gv;
4991 CV *cv;
4992 PERL_CONTEXT *cx;
4993 I32 old_savestack_ix;
4995 if (UNLIKELY(!sv))
4996 goto do_die;
4998 /* Locate the CV to call:
4999 * - most common case: RV->CV: f(), $ref->():
5000 * note that if a sub is compiled before its caller is compiled,
5001 * the stash entry will be a ref to a CV, rather than being a GV.
5002 * - second most common case: CV: $ref->method()
5003 */
5005 /* a non-magic-RV -> CV ? */
5006 if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
5007 cv = MUTABLE_CV(SvRV(sv));
5008 if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
5009 goto do_ref;
5010 }
5011 else
5012 cv = MUTABLE_CV(sv);
5014 /* a CV ? */
5015 if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
5016 /* handle all the weird cases */
5017 switch (SvTYPE(sv)) {
5018 case SVt_PVLV:
5019 if (!isGV_with_GP(sv))
5020 goto do_default;
5021 /* FALLTHROUGH */
5022 case SVt_PVGV:
5023 cv = GvCVu((const GV *)sv);
5024 if (UNLIKELY(!cv)) {
5025 HV *stash;
5026 cv = sv_2cv(sv, &stash, &gv, 0);
5027 if (!cv) {
5028 old_savestack_ix = PL_savestack_ix;
5029 goto try_autoload;
5030 }
5031 }
5032 break;
5034 default:
5035 do_default:
5036 SvGETMAGIC(sv);
5037 if (SvROK(sv)) {
5038 do_ref:
5039 if (UNLIKELY(SvAMAGIC(sv))) {
5040 sv = amagic_deref_call(sv, to_cv_amg);
5041 /* Don't SPAGAIN here. */
5042 }
5043 }
5044 else {
5045 const char *sym;
5046 STRLEN len;
5047 if (UNLIKELY(!SvOK(sv)))
5048 DIE(aTHX_ PL_no_usym, "a subroutine");
5050 sym = SvPV_nomg_const(sv, len);
5051 if (PL_op->op_private & HINT_STRICT_REFS)
5052 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
5053 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
5054 break;
5055 }
5056 cv = MUTABLE_CV(SvRV(sv));
5057 if (LIKELY(SvTYPE(cv) == SVt_PVCV))
5058 break;
5059 /* FALLTHROUGH */
5060 case SVt_PVHV:
5061 case SVt_PVAV:
5062 do_die:
5063 DIE(aTHX_ "Not a CODE reference");
5064 }
5065 }
5067 /* At this point we want to save PL_savestack_ix, either by doing a
5068 * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
5069 * CV we will be using (so we don't know whether its XS, so we can't
5070 * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
5071 * the save stack. So remember where we are currently on the save
5072 * stack, and later update the CX or scopestack entry accordingly. */
5073 old_savestack_ix = PL_savestack_ix;
5075 /* these two fields are in a union. If they ever become separate,
5076 * we have to test for both of them being null below */
5077 assert(cv);
5078 assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
5079 while (UNLIKELY(!CvROOT(cv))) {
5080 GV* autogv;
5081 SV* sub_name;
5083 /* anonymous or undef'd function leaves us no recourse */
5084 if (CvLEXICAL(cv) && CvHASGV(cv))
5085 DIE(aTHX_ "Undefined subroutine &%" SVf " called",
5086 SVfARG(cv_name(cv, NULL, 0)));
5087 if (CvANON(cv) || !CvHASGV(cv)) {
5088 DIE(aTHX_ "Undefined subroutine called");
5089 }
5091 /* autoloaded stub? */
5092 if (cv != GvCV(gv = CvGV(cv))) {
5093 cv = GvCV(gv);
5094 }
5095 /* should call AUTOLOAD now? */
5096 else {
5097 try_autoload:
5098 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
5099 (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
5100 n