This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
configpm: fix duplicate 'our' declaration
[perl5.git] / pp_hot.c
CommitLineData
a0d0e21e
LW
1/* pp_hot.c
2 *
1129b882
NC
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
a0d0e21e
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
13 * shaking the air.
14 *
4ac71550
TC
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"]
a0d0e21e
LW
19 */
20
166f8a29
DM
21/* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
26 *
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
31 * performance.
32 */
33
a0d0e21e 34#include "EXTERN.h"
864dbfa3 35#define PERL_IN_PP_HOT_C
a0d0e21e
LW
36#include "perl.h"
37
38/* Hot code. */
39
40PP(pp_const)
41{
39644a26 42 dSP;
996c9baa 43 XPUSHs(cSVOP_sv);
a0d0e21e
LW
44 RETURN;
45}
46
47PP(pp_nextstate)
48{
533c011a 49 PL_curcop = (COP*)PL_op;
a0d0e21e 50 TAINT_NOT; /* Each statement is presumed innocent */
4ebe6e95 51 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
a0d0e21e 52 FREETMPS;
f410a211 53 PERL_ASYNC_CHECK();
a0d0e21e
LW
54 return NORMAL;
55}
56
57PP(pp_gvsv)
58{
39644a26 59 dSP;
924508f0 60 EXTEND(SP,1);
5d9574c1 61 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
1d7c1841 62 PUSHs(save_scalar(cGVOP_gv));
a0d0e21e 63 else
c69033f2 64 PUSHs(GvSVn(cGVOP_gv));
a0d0e21e
LW
65 RETURN;
66}
67
b1c05ba5
DM
68
69/* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
70
a0d0e21e
LW
71PP(pp_null)
72{
73 return NORMAL;
74}
75
3dd9d4e4
FC
76/* This is sometimes called directly by pp_coreargs, pp_grepstart and
77 amagic_call. */
a0d0e21e
LW
78PP(pp_pushmark)
79{
3280af22 80 PUSHMARK(PL_stack_sp);
a0d0e21e
LW
81 return NORMAL;
82}
83
84PP(pp_stringify)
85{
20b7effb 86 dSP; dTARGET;
4cc783ef
DD
87 SV * const sv = TOPs;
88 SETs(TARG);
89 sv_copypv(TARG, sv);
90 SvSETMAGIC(TARG);
91 /* no PUTBACK, SETs doesn't inc/dec SP */
92 return NORMAL;
a0d0e21e
LW
93}
94
95PP(pp_gv)
96{
20b7effb 97 dSP;
ad64d0ec 98 XPUSHs(MUTABLE_SV(cGVOP_gv));
a0d0e21e
LW
99 RETURN;
100}
101
b1c05ba5
DM
102
103/* also used for: pp_andassign() */
104
a0d0e21e
LW
105PP(pp_and)
106{
f410a211 107 PERL_ASYNC_CHECK();
4cc783ef
DD
108 {
109 /* SP is not used to remove a variable that is saved across the
110 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
111 register or load/store vs direct mem ops macro is introduced, this
112 should be a define block between direct PL_stack_sp and dSP operations,
113 presently, using PL_stack_sp is bias towards CISC cpus */
114 SV * const sv = *PL_stack_sp;
115 if (!SvTRUE_NN(sv))
116 return NORMAL;
117 else {
118 if (PL_op->op_type == OP_AND)
119 --PL_stack_sp;
120 return cLOGOP->op_other;
121 }
a0d0e21e
LW
122 }
123}
124
125PP(pp_sassign)
126{
20b7effb 127 dSP;
3e75a3c4
RU
128 /* sassign keeps its args in the optree traditionally backwards.
129 So we pop them differently.
130 */
131 SV *left = POPs; SV *right = TOPs;
748a9306 132
354eabfa 133 if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
0bd48802
AL
134 SV * const temp = left;
135 left = right; right = temp;
a0d0e21e 136 }
d48c660d
DM
137 assert(TAINTING_get || !TAINT_get);
138 if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
a0d0e21e 139 TAINT_NOT;
5d9574c1
DM
140 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
141 /* *foo =\&bar */
3e75a3c4 142 SV * const cv = SvRV(right);
e26df76a 143 const U32 cv_type = SvTYPE(cv);
3e75a3c4 144 const bool is_gv = isGV_with_GP(left);
6136c704 145 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
e26df76a
NC
146
147 if (!got_coderef) {
148 assert(SvROK(cv));
149 }
150
3e75a3c4
RU
151 /* Can do the optimisation if left (LVALUE) is not a typeglob,
152 right (RVALUE) is a reference to something, and we're in void
e26df76a 153 context. */
13be902c 154 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
e26df76a 155 /* Is the target symbol table currently empty? */
3e75a3c4 156 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
bb112e5a 157 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
e26df76a
NC
158 /* Good. Create a new proxy constant subroutine in the target.
159 The gv becomes a(nother) reference to the constant. */
160 SV *const value = SvRV(cv);
161
ad64d0ec 162 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
1ccdb730 163 SvPCS_IMPORTED_on(gv);
e26df76a 164 SvRV_set(gv, value);
b37c2d43 165 SvREFCNT_inc_simple_void(value);
3e75a3c4 166 SETs(left);
e26df76a
NC
167 RETURN;
168 }
169 }
170
171 /* Need to fix things up. */
13be902c 172 if (!is_gv) {
e26df76a 173 /* Need to fix GV. */
3e75a3c4 174 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
e26df76a
NC
175 }
176
177 if (!got_coderef) {
178 /* We've been returned a constant rather than a full subroutine,
179 but they expect a subroutine reference to apply. */
53a42478 180 if (SvROK(cv)) {
d343c3ef 181 ENTER_with_name("sassign_coderef");
53a42478
NC
182 SvREFCNT_inc_void(SvRV(cv));
183 /* newCONSTSUB takes a reference count on the passed in SV
184 from us. We set the name to NULL, otherwise we get into
185 all sorts of fun as the reference to our new sub is
186 donated to the GV that we're about to assign to.
187 */
3e75a3c4 188 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
ad64d0ec 189 SvRV(cv))));
fc2b2dca 190 SvREFCNT_dec_NN(cv);
d343c3ef 191 LEAVE_with_name("sassign_coderef");
53a42478
NC
192 } else {
193 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
194 is that
195 First: ops for \&{"BONK"}; return us the constant in the
196 symbol table
197 Second: ops for *{"BONK"} cause that symbol table entry
198 (and our reference to it) to be upgraded from RV
199 to typeblob)
200 Thirdly: We get here. cv is actually PVGV now, and its
201 GvCV() is actually the subroutine we're looking for
202
203 So change the reference so that it points to the subroutine
204 of that typeglob, as that's what they were after all along.
205 */
159b6efe 206 GV *const upgraded = MUTABLE_GV(cv);
53a42478
NC
207 CV *const source = GvCV(upgraded);
208
209 assert(source);
210 assert(CvFLAGS(source) & CVf_CONST);
211
0ad694a7 212 SvREFCNT_inc_simple_void_NN(source);
fc2b2dca 213 SvREFCNT_dec_NN(upgraded);
3e75a3c4 214 SvRV_set(right, MUTABLE_SV(source));
53a42478 215 }
e26df76a 216 }
53a42478 217
e26df76a 218 }
8fe85e3f 219 if (
5d9574c1 220 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
3e75a3c4 221 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
8fe85e3f
FC
222 )
223 Perl_warner(aTHX_
224 packWARN(WARN_MISC), "Useless assignment to a temporary"
225 );
3e75a3c4
RU
226 SvSetMagicSV(left, right);
227 SETs(left);
a0d0e21e
LW
228 RETURN;
229}
230
231PP(pp_cond_expr)
232{
20b7effb 233 dSP;
f4c975aa
DM
234 SV *sv;
235
f410a211 236 PERL_ASYNC_CHECK();
f4c975aa
DM
237 sv = POPs;
238 RETURNOP(SvTRUE_NN(sv) ? cLOGOP->op_other : cLOGOP->op_next);
a0d0e21e
LW
239}
240
241PP(pp_unstack)
242{
f5319de9 243 PERL_CONTEXT *cx;
8f3964af 244 PERL_ASYNC_CHECK();
a0d0e21e 245 TAINT_NOT; /* Each statement is presumed innocent */
4ebe6e95 246 cx = CX_CUR();
f5319de9 247 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
a0d0e21e 248 FREETMPS;
eae48c89 249 if (!(PL_op->op_flags & OPf_SPECIAL)) {
93661e56 250 assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
dfe0f39b 251 CX_LEAVE_SCOPE(cx);
eae48c89 252 }
a0d0e21e
LW
253 return NORMAL;
254}
255
a0d0e21e
LW
256PP(pp_concat)
257{
20b7effb 258 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
748a9306
LW
259 {
260 dPOPTOPssrl;
8d6d96c1
HS
261 bool lbyte;
262 STRLEN rlen;
d4c19fe8 263 const char *rpv = NULL;
a6b599c7 264 bool rbyte = FALSE;
a9c4fd4e 265 bool rcopied = FALSE;
8d6d96c1 266
6f1401dc
DM
267 if (TARG == right && right != left) { /* $r = $l.$r */
268 rpv = SvPV_nomg_const(right, rlen);
c75ab21a 269 rbyte = !DO_UTF8(right);
59cd0e26 270 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
349d4f2f 271 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
db79b45b 272 rcopied = TRUE;
8d6d96c1 273 }
7889fe52 274
89734059 275 if (TARG != left) { /* not $l .= $r */
a9c4fd4e 276 STRLEN llen;
6f1401dc 277 const char* const lpv = SvPV_nomg_const(left, llen);
90f5826e 278 lbyte = !DO_UTF8(left);
8d6d96c1
HS
279 sv_setpvn(TARG, lpv, llen);
280 if (!lbyte)
281 SvUTF8_on(TARG);
282 else
283 SvUTF8_off(TARG);
284 }
18ea7bf2
SM
285 else { /* $l .= $r and left == TARG */
286 if (!SvOK(left)) {
51f69a24
AC
287 if ((left == right /* $l .= $l */
288 || (PL_op->op_private & OPpTARGET_MY)) /* $l = $l . $r */
289 && ckWARN(WARN_UNINITIALIZED)
290 )
291 report_uninit(left);
adf14ec6 292 SvPVCLEAR(left);
c75ab21a 293 }
18ea7bf2
SM
294 else {
295 SvPV_force_nomg_nolen(left);
296 }
583a5589 297 lbyte = !DO_UTF8(left);
90f5826e 298 if (IN_BYTES)
18ea7bf2 299 SvUTF8_off(left);
8d6d96c1 300 }
a12c0f56 301
c75ab21a 302 if (!rcopied) {
6f1401dc 303 rpv = SvPV_nomg_const(right, rlen);
c75ab21a
RH
304 rbyte = !DO_UTF8(right);
305 }
8d6d96c1
HS
306 if (lbyte != rbyte) {
307 if (lbyte)
308 sv_utf8_upgrade_nomg(TARG);
309 else {
db79b45b 310 if (!rcopied)
59cd0e26 311 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
8d6d96c1 312 sv_utf8_upgrade_nomg(right);
6f1401dc 313 rpv = SvPV_nomg_const(right, rlen);
69b47968 314 }
a0d0e21e 315 }
8d6d96c1 316 sv_catpvn_nomg(TARG, rpv, rlen);
43ebc500 317
a0d0e21e
LW
318 SETTARG;
319 RETURN;
748a9306 320 }
a0d0e21e
LW
321}
322
e839e6ed
DM
323
324/* pp_multiconcat()
325
326Concatenate one or more args, possibly interleaved with constant string
327segments. The result may be assigned to, or appended to, a variable or
328expression.
329
330Several op_flags and/or op_private bits indicate what the target is, and
331whether it's appended to. Valid permutations are:
332
333 - (PADTMP) = (A.B.C....)
334 OPpTARGET_MY $lex = (A.B.C....)
335 OPpTARGET_MY,OPpLVAL_INTRO my $lex = (A.B.C....)
336 OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex .= (A.B.C....)
337 OPf_STACKED expr = (A.B.C....)
338 OPf_STACKED,OPpMULTICONCAT_APPEND expr .= (A.B.C....)
339
340Other combinations like (A.B).(C.D) are not optimised into a multiconcat
341op, as it's too hard to get the correct ordering of ties, overload etc.
342
343In addition:
344
345 OPpMULTICONCAT_FAKE: not a real concat, instead an optimised
346 sprintf "...%s...". Don't call '.'
347 overloading: only use '""' overloading.
348
349 OPpMULTICONCAT_STRINGIFY: (for Deparse's benefit) the RHS was of the
350 form "...$a...$b..." rather than
351 "..." . $a . "..." . $b . "..."
352
353An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are
354defined with PERL_MULTICONCAT_IX_FOO constants, where:
355
356
357 FOO index description
358 -------- ----- ----------------------------------
359 NARGS 0 number of arguments
360 PLAIN_PV 1 non-utf8 constant string
361 PLAIN_LEN 2 non-utf8 constant string length
362 UTF8_PV 3 utf8 constant string
363 UTF8_LEN 4 utf8 constant string length
364 LENGTHS 5 first of nargs+1 const segment lengths
365
366The idea is that a general string concatenation will have a fixed (known
367at compile time) number of variable args, interspersed with constant
368strings, e.g. "a=$a b=$b\n"
369
370All the constant string segments "a=", " b=" and "\n" are stored as a
371single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along
372with a series of segment lengths: e.g. 2,3,1. In the case where the
373constant string is plain but has a different utf8 representation, both
374variants are stored, and two sets of (nargs+1) segments lengths are stored
375in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS.
376
377A segment length of -1 indicates that there is no constant string at that
378point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which
379have differing overloading behaviour.
380
381*/
382
383PP(pp_multiconcat)
384{
385 dSP;
386 SV *targ; /* The SV to be assigned or appended to */
387 SV *dsv; /* the SV to concat args to (often == targ) */
388 char *dsv_pv; /* where within SvPVX(dsv) we're writing to */
389 STRLEN targ_len; /* SvCUR(targ) */
390 SV **toparg; /* the highest arg position on the stack */
391 UNOP_AUX_item *aux; /* PL_op->op_aux buffer */
392 UNOP_AUX_item *const_lens; /* the segment length array part of aux */
393 const char *const_pv; /* the current segment of the const string buf */
394 UV nargs; /* how many args were expected */
395 UV stack_adj; /* how much to adjust SP on return */
396 STRLEN grow; /* final size of destination string (dsv) */
397 UV targ_count; /* how many times targ has appeared on the RHS */
398 bool is_append; /* OPpMULTICONCAT_APPEND flag is set */
399 bool slow_concat; /* args too complex for quick concat */
400 U32 dst_utf8; /* the result will be utf8 (indicate this with
401 SVf_UTF8 in a U32, rather than using bool,
402 for ease of testing and setting) */
403 /* for each arg, holds the result of an SvPV() call */
404 struct multiconcat_svpv {
405 char *pv;
406 SSize_t len;
407 }
408 *targ_chain, /* chain of slots where targ has appeared on RHS */
409 *svpv_p, /* ptr for looping through svpv_buf */
410 *svpv_base, /* first slot (may be greater than svpv_buf), */
411 *svpv_end, /* and slot after highest result so far, of: */
412 svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */
413
414 aux = cUNOP_AUXx(PL_op)->op_aux;
415 stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].uv;
416 is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND);
417
418 /* get targ from the stack or pad */
419
420 if (PL_op->op_flags & OPf_STACKED) {
421 if (is_append) {
422 /* for 'expr .= ...', expr is the bottom item on the stack */
423 targ = SP[-nargs];
424 stack_adj++;
425 }
426 else
427 /* for 'expr = ...', expr is the top item on the stack */
428 targ = POPs;
429 }
430 else {
431 SV **svp = &(PAD_SVl(PL_op->op_targ));
432 targ = *svp;
433 if (PL_op->op_private & OPpLVAL_INTRO) {
434 assert(PL_op->op_private & OPpTARGET_MY);
435 save_clearsv(svp);
436 }
437 if (!nargs)
438 /* $lex .= "const" doesn't cause anything to be pushed */
439 EXTEND(SP,1);
440 }
441
442 toparg = SP;
443 SP -= (nargs - 1);
444 dsv = targ; /* Set the destination for all concats. This is
445 initially targ; later on, dsv may be switched
446 to point to a TEMP SV if overloading is
447 encountered. */
448 grow = 1; /* allow for '\0' at minimum */
449 targ_count = 0;
450 targ_chain = NULL;
451 targ_len = 0;
452 svpv_end = svpv_buf;
453 /* only utf8 variants of the const strings? */
454 dst_utf8 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8;
455
456
457 /* --------------------------------------------------------------
458 * Phase 1:
459 *
460 * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8
461 * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths.
462 *
463 * utf8 is indicated by storing a negative length.
464 *
465 * Where an arg is actually targ, the stringification is deferred:
466 * the length is set to 0, and the slot is added to targ_chain.
467 *
468 * If an overloaded arg is found, the loop is abandoned at that point,
469 * and dsv is set to an SvTEMP SV where the results-so-far will be
470 * accumulated.
471 */
472
473 for (; SP <= toparg; SP++, svpv_end++) {
474 bool simple_flags;
475 U32 utf8;
476 STRLEN len;
477 SV *sv;
478
479 assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
480
481 sv = *SP;
482 simple_flags = (SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK;
483
484 /* this if/else chain is arranged so that common/simple cases
485 * take few conditionals */
486
487 if (LIKELY(simple_flags && (sv != targ))) {
488 /* common case: sv is a simple PV and not the targ */
489 svpv_end->pv = SvPVX(sv);
490 len = SvCUR(sv);
491 }
492 else if (simple_flags) {
493 /* sv is targ (but can't be magic or overloaded).
494 * Delay storing PV pointer; instead, add slot to targ_chain
495 * so it can be populated later, after targ has been grown and
496 * we know its final SvPVX() address.
497 */
498 targ_on_rhs:
499 svpv_end->len = 0; /* zerojng here means we can skip
500 updating later if targ_len == 0 */
501 svpv_end->pv = (char*)targ_chain;
502 targ_chain = svpv_end;
503 targ_count++;
504 continue;
505 }
506 else {
507 if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK))) {
508 /* its got magic, is tied, and/or is overloaded */
509 SvGETMAGIC(sv);
510
511 if (UNLIKELY(SvAMAGIC(sv))
512 && !(PL_op->op_private & OPpMULTICONCAT_FAKE))
513 {
514 /* One of the RHS args is overloaded. Abandon stringifying
515 * the args at this point, then in the concat loop later
516 * on, concat the plain args stringified so far into a
517 * TEMP SV. At the end of this function the remaining
518 * args (including the current one) will be handled
519 * specially, using overload calls.
520 * FAKE implies an optimised sprintf which doesn't use
521 * concat overloading, only "" overloading.
522 */
b3ab0375
DM
523
524 if ( svpv_end == svpv_buf + 1
525 /* no const string segments */
526 && aux[PERL_MULTICONCAT_IX_LENGTHS].size == -1
527 && aux[PERL_MULTICONCAT_IX_LENGTHS + 1].size == -1
528 ) {
529 /* special case: if the overloaded sv is the
530 * second arg in the concat chain, stop at the
531 * first arg rather than this, so that
532 *
533 * $arg1 . $arg2
534 *
535 * invokes overloading as
536 *
537 * concat($arg2, $arg1, 1)
538 *
539 * rather than
540 *
541 * concat($arg2, "$arg1", 1)
542 *
543 * This means that if for example arg1 is a ref,
544 * it gets passed as-is to the concat method
545 * rather than a stringified copy. If it's not the
546 * first arg, it doesn't matter, as in $arg0 .
547 * $arg1 . $arg2, where the result of ($arg0 .
548 * $arg1) will already be a string.
549 * THis isn't perfect: we'll have already
550 * done SvPV($arg1) on the previous iteration;
551 * and are now throwing away that result and
552 * hoping arg1 hasn;t been affected.
553 */
554 svpv_end--;
555 SP--;
556 }
557
e839e6ed
DM
558 setup_overload:
559 dsv = newSVpvn_flags("", 0, SVs_TEMP);
560
561 if (targ_chain) {
562 /* Get the string value of targ and populate any
563 * RHS slots which use it */
564 char *pv = SvPV_nomg(targ, len);
565 dst_utf8 |= (SvFLAGS(targ) & SVf_UTF8);
566 grow += len * targ_count;
567 do {
568 struct multiconcat_svpv *p = targ_chain;
569 targ_chain = (struct multiconcat_svpv *)(p->pv);
570 p->pv = pv;
571 p->len = len;
572 } while (targ_chain);
573 }
574 else if (is_append)
575 SvGETMAGIC(targ);
576
577 goto phase3;
578 }
579
580 if (SvFLAGS(sv) & SVs_RMG) {
581 /* probably tied; copy it to guarantee separate values
582 * each time it's used, e.g. "-$tied-$tied-$tied-",
583 * since FETCH() isn't necessarily idempotent */
584 SV *nsv = newSV(0);
585 sv_setsv_flags(nsv, sv, SV_NOSTEAL);
586 sv_2mortal(nsv);
587 if ( sv == targ
588 && is_append
589 && nargs == 1
590 /* no const string segments */
591 && aux[PERL_MULTICONCAT_IX_LENGTHS].size == -1
592 && aux[PERL_MULTICONCAT_IX_LENGTHS+1].size == -1)
593 {
594 /* special-case $tied .= $tied.
595 *
596 * For something like
597 * sub FETCH { $i++ }
598 * then
599 * $tied .= $tied . $tied . $tied;
600 * will STORE "4123"
601 * while
602 * $tied .= $tied
603 * will STORE "12"
604 *
605 * i.e. for a single mutator concat, the LHS is
606 * retrieved first; in all other cases it is
607 * retrieved last. Whether this is sane behaviour
608 * is open to debate; but for now, multiconcat (as
609 * it is an optimisation) tries to reproduce
610 * existing behaviour.
611 */
612 sv_catsv(nsv, sv);
613 sv_setsv(sv,nsv);
614 SP++;
615 goto phase7; /* just return targ as-is */
616 }
617
618 sv = nsv;
619 }
620 }
621
622 if (sv == targ) {
623 /* must warn for each RH usage of targ, except that
624 * we will later get one warning when doing
625 * SvPV_force(targ), *except* on '.=' */
626 if ( !SvOK(sv)
627 && (targ_chain || is_append)
628 && ckWARN(WARN_UNINITIALIZED)
629 )
630 report_uninit(sv);
631 goto targ_on_rhs;
632 }
633
634 /* stringify general SV */
635 svpv_end->pv = sv_2pv_flags(sv, &len, 0);
636 }
637
638 utf8 = (SvFLAGS(sv) & SVf_UTF8);
639 dst_utf8 |= utf8;
640 ASSUME(len < SSize_t_MAX);
641 svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len;
642 grow += len;
643 }
644
645 /* --------------------------------------------------------------
646 * Phase 2:
647 *
648 * Stringify targ:
649 *
650 * if targ appears on the RHS or is appended to, force stringify it;
651 * otherwise set it to "". Then set targ_len.
652 */
653
654 if (is_append) {
655 if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK))) {
656 SvGETMAGIC(targ); /* must do before SvAMAGIC() check */
657 if (UNLIKELY(SvAMAGIC(targ))) {
658 /* $overloaded .= ....;
659 * accumulate RHS in a temp SV rather than targ,
660 * then append tmp to targ at the end using overload
661 */
662 assert(!targ_chain);
663 dsv = newSVpvn_flags("", 0, SVs_TEMP);
664 goto phase3;
665 }
666 }
667
668 if (SvOK(targ)) {
669 U32 targ_utf8;
670 stringify_targ:
671 SvPV_force_nomg_nolen(targ);
672 targ_utf8 = SvFLAGS(targ) & SVf_UTF8;
673 if (UNLIKELY(dst_utf8 & ~targ_utf8)) {
674 if (LIKELY(!IN_BYTES))
675 sv_utf8_upgrade_nomg(targ);
676 }
677 else
678 dst_utf8 |= targ_utf8;
679
680 targ_len = SvCUR(targ);
681 grow += targ_len * (targ_count + is_append);
682 goto phase3;
683 }
684 }
685 else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) {
686 /* Assigning to some weird LHS type. Don't force the LHS to be an
687 * empty string; instead, do things 'long hand' by using the
688 * overload code path, which concats to a TEMP sv and does
689 * sv_catsv() calls rather than COPY()s. This ensures that even
690 * bizarre code like this doesn't break or crash:
691 * *F = *F . *F.
692 * (which makes the 'F' typeglob an alias to the
693 * '*main::F*main::F' typeglob).
694 */
695 goto setup_overload;
696 }
697 else if (targ_chain) {
698 /* targ was found on RHS.
699 * We don't need the SvGETMAGIC() call and SvAMAGIC() test as
700 * both were already done earlier in the SvPV() loop; other
701 * than that we can share the same code with the append
702 * branch below.
703 * Note that this goto jumps directly into the SvOK() branch
704 * even if targ isn't SvOK(), to force an 'uninitialised'
705 * warning; e.g.
706 * $undef .= .... targ only on LHS: don't warn
707 * $undef .= $undef .... targ on RHS too: warn
708 */
709 assert(!SvAMAGIC(targ));
710 goto stringify_targ;
711 }
712
713
714 /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
715 * those will be done later. */
716 assert(targ == dsv);
717 SV_CHECK_THINKFIRST_COW_DROP(targ);
718 SvUPGRADE(targ, SVt_PV);
719 SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
720 SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8);
721
722 phase3:
723
724 /* --------------------------------------------------------------
725 * Phase 3:
726 *
727 * UTF-8 tweaks and grow dsv:
728 *
729 * Now that we know the length and utf8-ness of both the targ and
730 * args, grow dsv to the size needed to accumulate all the args, based
731 * on whether targ appears on the RHS, whether we're appending, and
732 * whether any non-utf8 args expand in size if converted to utf8.
733 *
734 * For the latter, if dst_utf8 we scan non-utf8 args looking for
735 * variant chars, and adjust the svpv->len value of those args to the
736 * utf8 size and negate it to flag them. At the same time we un-negate
737 * the lens of any utf8 args since after this phase we no longer care
738 * whether an arg is utf8 or not.
739 *
740 * Finally, initialise const_lens and const_pv based on utf8ness.
741 * Note that there are 3 permutations:
742 *
743 * * If the constant string is invariant whether utf8 or not (e.g. "abc"),
744 * then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as
745 * aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of
746 * segment lengths.
747 *
748 * * If the string is fully utf8, e.g. "\x{100}", then
749 * aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is
750 * one set of segment lengths.
751 *
752 * * If the string has different plain and utf8 representations
753 * (e.g. "\x80"), then then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
754 * holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
755 * holds the utf8 rep, and there are 2 sets of segment lengths,
756 * with the utf8 set following after the plain set.
757 *
758 * On entry to this section the (pv,len) pairs in svpv_buf have the
759 * following meanings:
760 * (pv, len) a plain string
761 * (pv, -len) a utf8 string
762 * (NULL, 0) left-most targ \ linked together R-to-L
763 * (next, 0) other targ / in targ_chain
764 */
765
766 /* turn off utf8 handling if 'use bytes' is in scope */
767 if (UNLIKELY(dst_utf8 && IN_BYTES)) {
768 dst_utf8 = 0;
769 SvUTF8_off(dsv);
770 /* undo all the negative lengths which flag utf8-ness */
771 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
772 SSize_t len = svpv_p->len;
773 if (len < 0)
774 svpv_p->len = -len;
775 }
776 }
777
778 /* grow += total of lengths of constant string segments */
779 {
780 SSize_t len;
781 len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN
782 : PERL_MULTICONCAT_IX_PLAIN_LEN].size;
783 slow_concat = cBOOL(len);
784 grow += len;
785 }
786
787 const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
788
789 if (dst_utf8) {
790 const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
791 if ( aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv
792 && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv)
793 /* separate sets of lengths for plain and utf8 */
794 const_lens += nargs + 1;
795
796 /* If the result is utf8 but some of the args aren't,
797 * calculate how much extra growth is needed for all the chars
798 * which will expand to two utf8 bytes.
799 * Also, if the growth is non-zero, negate the length to indicate
800 * that this this is a variant string. Conversely, un-negate the
801 * length on utf8 args (which was only needed to flag non-utf8
802 * args in this loop */
803 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
804 char *p;
805 SSize_t len, l, extra;
806
807 len = svpv_p->len;
808 if (len <= 0) {
809 svpv_p->len = -len;
810 continue;
811 }
812
813 p = svpv_p->pv;
814 extra = 0;
815 l = len;
816 while (l--)
817 extra += !UTF8_IS_INVARIANT(*p++);
818 if (UNLIKELY(extra)) {
819 grow += extra;
820 /* -ve len indicates special handling */
821 svpv_p->len = -(len + extra);
822 slow_concat = TRUE;
823 }
824 }
825 }
826 else
827 const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
828
829 /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
830 * already have been dropped */
831 assert(!SvIsCOW(dsv));
832 dsv_pv = (SvLEN(dsv) < (grow) ? sv_grow(dsv,grow) : SvPVX(dsv));
833
834
835 /* --------------------------------------------------------------
836 * Phase 4:
837 *
838 * Now that dsv (which is probably targ) has been grown, we know the
839 * final address of the targ PVX, if needed. Preserve / move targ
840 * contents if appending or if targ appears on RHS.
841 *
842 * Also update svpv_buf slots in targ_chain.
843 *
844 * Don't bother with any of this if the target length is zero:
845 * targ_len is set to zero unless we're appending or targ appears on
846 * RHS. And even if it is, we can optimise by skipping this chunk of
847 * code for zero targ_len. In the latter case, we don't need to update
848 * the slots in targ_chain with the (zero length) target string, since
849 * we set the len in such slots to 0 earlier, and since the Copy() is
850 * skipped on zero length, it doesn't matter what svpv_p->pv contains.
851 *
852 * On entry to this section the (pv,len) pairs in svpv_buf have the
853 * following meanings:
854 * (pv, len) a pure-plain or utf8 string
855 * (pv, -(len+extra)) a plain string which will expand by 'extra'
856 * bytes when converted to utf8
857 * (NULL, 0) left-most targ \ linked together R-to-L
858 * (next, 0) other targ / in targ_chain
859 *
860 * On exit, the targ contents will have been moved to the
861 * earliest place they are needed (e.g. $x = "abc$x" will shift them
862 * 3 bytes, while $x .= ... will leave them at the beginning);
863 * and dst_pv will point to the location within SvPVX(dsv) where the
864 * next arg should be copied.
865 */
866
867 svpv_base = svpv_buf;
868
869 if (targ_len) {
870 struct multiconcat_svpv *tc_stop;
871 char *targ_pv = dsv_pv;
872
873 assert(targ == dsv);
874 assert(is_append || targ_count);
875
876 if (is_append) {
877 dsv_pv += targ_len;
878 tc_stop = NULL;
879 }
880 else {
881 /* The targ appears on RHS, e.g. '$t = $a . $t . $t'.
882 * Move the current contents of targ to the first
883 * position where it's needed, and use that as the src buffer
884 * for any further uses (such as the second RHS $t above).
885 * In calculating the first position, we need to sum the
886 * lengths of all consts and args before that.
887 */
888
889 UNOP_AUX_item *lens = const_lens;
890 /* length of first const string segment */
891 STRLEN offset = lens->size > 0 ? lens->size : 0;
892
893 assert(targ_chain);
894 svpv_p = svpv_base;
895
896 for (;;) {
897 SSize_t len;
898 if (!svpv_p->pv)
899 break; /* the first targ argument */
900 /* add lengths of the next arg and const string segment */
901 len = svpv_p->len;
902 if (len < 0) /* variant args have this */
903 len = -len;
904 offset += (STRLEN)len;
905 len = (++lens)->size;
906 offset += (len >= 0) ? (STRLEN)len : 0;
907 if (!offset) {
908 /* all args and consts so far are empty; update
909 * the start position for the concat later */
910 svpv_base++;
911 const_lens++;
912 }
913 svpv_p++;
914 assert(svpv_p < svpv_end);
915 }
916
917 if (offset) {
918 targ_pv += offset;
919 Move(dsv_pv, targ_pv, targ_len, char);
920 /* a negative length implies don't Copy(), but do increment */
921 svpv_p->len = -targ_len;
922 slow_concat = TRUE;
923 }
924 else {
925 /* skip the first targ copy */
926 svpv_base++;
927 const_lens++;
928 dsv_pv += targ_len;
929 }
930
931 /* Don't populate the first targ slot in the loop below; it's
932 * either not used because we advanced svpv_base beyond it, or
933 * we already stored the special -targ_len value in it
934 */
935 tc_stop = svpv_p;
936 }
937
938 /* populate slots in svpv_buf representing targ on RHS */
939 while (targ_chain != tc_stop) {
940 struct multiconcat_svpv *p = targ_chain;
941 targ_chain = (struct multiconcat_svpv *)(p->pv);
942 p->pv = targ_pv;
943 p->len = (SSize_t)targ_len;
944 }
945 }
946
947
948 /* --------------------------------------------------------------
949 * Phase 5:
950 *
951 * Append all the args in svpv_buf, plus the const strings, to dsv.
952 *
953 * On entry to this section the (pv,len) pairs in svpv_buf have the
954 * following meanings:
955 * (pv, len) a pure-plain or utf8 string (which may be targ)
956 * (pv, -(len+extra)) a plain string which will expand by 'extra'
957 * bytes when converted to utf8
958 * (0, -len) left-most targ, whose content has already
959 * been copied. Just advance dsv_pv by len.
960 */
961
962 /* If there are no constant strings and no special case args
963 * (svpv_p->len < 0), use a simpler, more efficient concat loop
964 */
965 if (!slow_concat) {
966 for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) {
967 SSize_t len = svpv_p->len;
968 if (!len)
969 continue;
970 Copy(svpv_p->pv, dsv_pv, len, char);
971 dsv_pv += len;
972 }
973 const_lens += (svpv_end - svpv_base + 1);
974 }
975 else {
976 /* Note that we iterate the loop nargs+1 times: to append nargs
977 * arguments and nargs+1 constant strings. For example, "-$a-$b-"
978 */
979 svpv_p = svpv_base - 1;
980
981 for (;;) {
982 SSize_t len = (const_lens++)->size;
983
984 /* append next const string segment */
985 if (len > 0) {
986 Copy(const_pv, dsv_pv, len, char);
987 dsv_pv += len;
988 const_pv += len;
989 }
990
991 if (++svpv_p == svpv_end)
992 break;
993
994 /* append next arg */
995 len = svpv_p->len;
996
997 if (LIKELY(len > 0)) {
998 Copy(svpv_p->pv, dsv_pv, len, char);
999 dsv_pv += len;
1000 }
1001 else if (UNLIKELY(len < 0)) {
1002 /* negative length indicates two special cases */
1003 const char *p = svpv_p->pv;
1004 len = -len;
1005 if (UNLIKELY(p)) {
1006 /* copy plain-but-variant pv to a utf8 targ */
576915da 1007 char * end_pv = dsv_pv + len;
e839e6ed 1008 assert(dst_utf8);
576915da 1009 while (dsv_pv < end_pv) {
e839e6ed 1010 U8 c = (U8) *p++;
576915da 1011 append_utf8_from_native_byte(c, (U8**)&dsv_pv);
e839e6ed
DM
1012 }
1013 }
1014 else
1015 /* arg is already-copied targ */
1016 dsv_pv += len;
1017 }
1018
1019 }
1020 }
1021
1022 *dsv_pv = '\0';
1023 SvCUR_set(dsv, dsv_pv - SvPVX(dsv));
1024 assert(grow >= SvCUR(dsv) + 1);
1025 assert(SvLEN(dsv) >= SvCUR(dsv) + 1);
1026
1027 /* --------------------------------------------------------------
1028 * Phase 6:
1029 *
1030 * Handle overloading. If an overloaded arg or targ was detected
1031 * earlier, dsv will have been set to a new mortal, and any args and
1032 * consts to the left of the first overloaded arg will have been
1033 * accumulated to it. This section completes any further concatenation
1034 * steps with overloading handled.
1035 */
1036
1037 if (UNLIKELY(dsv != targ)) {
1038 SV *res;
1039
1040 SvFLAGS(dsv) |= dst_utf8;
1041
1042 if (SP <= toparg) {
1043 /* Stringifying the RHS was abandoned because *SP
1044 * is overloaded. dsv contains all the concatted strings
1045 * before *SP. Apply the rest of the args using overloading.
1046 */
1047 SV *left, *right, *res;
1048 int i;
1049 bool getmg = FALSE;
1050 SV *constsv = NULL;
1051 /* number of args already concatted */
1052 STRLEN n = (nargs - 1) - (toparg - SP);
1053 /* current arg is either the first
1054 * or second value to be concatted
1055 * (including constant strings), so would
1056 * form part of the first concat */
1057 bool first_concat = ( n == 0
1058 || (n == 1 && const_lens[-2].size < 0
1059 && const_lens[-1].size < 0));
1060 int f_assign = first_concat ? 0 : AMGf_assign;
1061
1062 left = dsv;
1063
1064 for (; n < nargs; n++) {
1065 /* loop twice, first applying the arg, then the const segment */
1066 for (i = 0; i < 2; i++) {
1067 if (i) {
1068 /* append next const string segment */
1069 STRLEN len = (STRLEN)((const_lens++)->size);
1070 /* a length of -1 implies no constant string
1071 * rather than a zero-length one, e.g.
1072 * ($a . $b) versus ($a . "" . $b)
1073 */
1074 if ((SSize_t)len < 0)
1075 continue;
1076
1077 /* set constsv to the next constant string segment */
1078 if (constsv) {
1079 sv_setpvn(constsv, const_pv, len);
1080 if (dst_utf8)
1081 SvUTF8_on(constsv);
1082 else
1083 SvUTF8_off(constsv);
1084 }
1085 else
1086 constsv = newSVpvn_flags(const_pv, len,
1087 (dst_utf8 | SVs_TEMP));
1088
1089 right = constsv;
1090 const_pv += len;
1091 }
1092 else {
1093 /* append next arg */
1094 right = *SP++;
1095 if (getmg)
1096 SvGETMAGIC(right);
1097 else
1098 /* SvGETMAGIC already called on this SV just
1099 * before we broke from the loop earlier */
1100 getmg = TRUE;
1101
1102 if (first_concat && n == 0 && const_lens[-1].size < 0) {
1103 /* nothing before the current arg; repeat the
1104 * loop to get a second arg */
1105 left = right;
1106 first_concat = FALSE;
1107 continue;
1108 }
1109 }
1110
1111 if ((SvAMAGIC(left) || SvAMAGIC(right))
1112 && (res = amagic_call(left, right, concat_amg, f_assign))
1113 )
1114 left = res;
1115 else {
1116 if (left != dsv) {
1117 sv_setsv(dsv, left);
1118 left = dsv;
1119 }
1120 sv_catsv_nomg(left, right);
1121 }
1122 f_assign = AMGf_assign;
1123 }
1124 }
1125 dsv = left;
1126 }
1127
1128 /* assign/append RHS (dsv) to LHS (targ) */
1129 if (is_append) {
1130 if ((SvAMAGIC(targ) || SvAMAGIC(dsv))
1131 && (res = amagic_call(targ, dsv, concat_amg, AMGf_assign))
1132 )
1133 sv_setsv(targ, res);
1134 else
1135 sv_catsv_nomg(targ, dsv);
1136 }
1137 else
1138 sv_setsv(targ, dsv);
1139 }
1140
1141 /* --------------------------------------------------------------
1142 * Phase 7:
1143 *
1144 * return result
1145 */
1146
1147 phase7:
1148
1149 SP -= stack_adj;
1150 SvTAINT(targ);
1151 SETTARG;
1152 RETURN;
1153}
1154
1155
0b5aba47
DM
1156/* push the elements of av onto the stack.
1157 * Returns PL_op->op_next to allow tail-call optimisation of its callers */
d5524600 1158
0b5aba47 1159STATIC OP*
d5524600
DM
1160S_pushav(pTHX_ AV* const av)
1161{
1162 dSP;
c70927a6 1163 const SSize_t maxarg = AvFILL(av) + 1;
d5524600 1164 EXTEND(SP, maxarg);
5d9574c1 1165 if (UNLIKELY(SvRMAGICAL(av))) {
c70927a6
FC
1166 PADOFFSET i;
1167 for (i=0; i < (PADOFFSET)maxarg; i++) {
d5524600 1168 SV ** const svp = av_fetch(av, i, FALSE);
ea710183 1169 SP[i+1] = svp ? *svp : &PL_sv_undef;
d5524600
DM
1170 }
1171 }
1172 else {
c70927a6
FC
1173 PADOFFSET i;
1174 for (i=0; i < (PADOFFSET)maxarg; i++) {
ce0d59fd 1175 SV * const sv = AvARRAY(av)[i];
5d9574c1 1176 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
ce0d59fd 1177 }
d5524600
DM
1178 }
1179 SP += maxarg;
1180 PUTBACK;
0b5aba47 1181 return NORMAL;
d5524600
DM
1182}
1183
1184
a7fd8ef6
DM
1185/* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
1186
1187PP(pp_padrange)
1188{
20b7effb 1189 dSP;
a7fd8ef6
DM
1190 PADOFFSET base = PL_op->op_targ;
1191 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
d5524600
DM
1192 if (PL_op->op_flags & OPf_SPECIAL) {
1193 /* fake the RHS of my ($x,$y,..) = @_ */
1194 PUSHMARK(SP);
0b5aba47 1195 (void)S_pushav(aTHX_ GvAVn(PL_defgv));
d5524600
DM
1196 SPAGAIN;
1197 }
1198
a7fd8ef6
DM
1199 /* note, this is only skipped for compile-time-known void cxt */
1200 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
19742f39
AL
1201 int i;
1202
a7fd8ef6
DM
1203 EXTEND(SP, count);
1204 PUSHMARK(SP);
1205 for (i = 0; i <count; i++)
1206 *++SP = PAD_SV(base+i);
1207 }
1208 if (PL_op->op_private & OPpLVAL_INTRO) {
4e09461c
DM
1209 SV **svp = &(PAD_SVl(base));
1210 const UV payload = (UV)(
1211 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1212 | (count << SAVE_TIGHT_SHIFT)
1213 | SAVEt_CLEARPADRANGE);
19742f39
AL
1214 int i;
1215
6d59e610 1216 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
d081a355
DM
1217 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1218 == (Size_t)base);
a3444cc5
DM
1219 {
1220 dSS_ADD;
1221 SS_ADD_UV(payload);
1222 SS_ADD_END(1);
1223 }
4e09461c 1224
a7fd8ef6 1225 for (i = 0; i <count; i++)
4e09461c 1226 SvPADSTALE_off(*svp++); /* mark lexical as active */
a7fd8ef6
DM
1227 }
1228 RETURN;
1229}
1230
1231
a0d0e21e
LW
1232PP(pp_padsv)
1233{
20b7effb 1234 dSP;
6c28b496
DD
1235 EXTEND(SP, 1);
1236 {
1237 OP * const op = PL_op;
1238 /* access PL_curpad once */
1239 SV ** const padentry = &(PAD_SVl(op->op_targ));
1240 {
1241 dTARG;
1242 TARG = *padentry;
1243 PUSHs(TARG);
1244 PUTBACK; /* no pop/push after this, TOPs ok */
8ec5e241 1245 }
6c28b496
DD
1246 if (op->op_flags & OPf_MOD) {
1247 if (op->op_private & OPpLVAL_INTRO)
1248 if (!(op->op_private & OPpPAD_STATE))
1249 save_clearsv(padentry);
1250 if (op->op_private & OPpDEREF) {
8f90a16d
FC
1251 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
1252 than TARG reduces the scope of TARG, so it does not
1253 span the call to save_clearsv, resulting in smaller
1254 machine code. */
6c28b496
DD
1255 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
1256 }
1257 }
1258 return op->op_next;
4633a7c4 1259 }
a0d0e21e
LW
1260}
1261
1262PP(pp_readline)
1263{
30901a8a 1264 dSP;
12dc5f94
DM
1265 /* pp_coreargs pushes a NULL to indicate no args passed to
1266 * CORE::readline() */
30901a8a
FC
1267 if (TOPs) {
1268 SvGETMAGIC(TOPs);
fc99edcf 1269 tryAMAGICunTARGETlist(iter_amg, 0);
30901a8a
FC
1270 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1271 }
1272 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
6e592b3a
BM
1273 if (!isGV_with_GP(PL_last_in_gv)) {
1274 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
159b6efe 1275 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
8efb3254 1276 else {
f5284f61 1277 dSP;
ad64d0ec 1278 XPUSHs(MUTABLE_SV(PL_last_in_gv));
f5284f61 1279 PUTBACK;
897d3989 1280 Perl_pp_rv2gv(aTHX);
159b6efe 1281 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
745e740c 1282 assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
f5284f61
IZ
1283 }
1284 }
a0d0e21e
LW
1285 return do_readline();
1286}
1287
1288PP(pp_eq)
1289{
20b7effb 1290 dSP;
33efebe6
DM
1291 SV *left, *right;
1292
a42d0242 1293 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
1294 right = POPs;
1295 left = TOPs;
1296 SETs(boolSV(
1297 (SvIOK_notUV(left) && SvIOK_notUV(right))
1298 ? (SvIVX(left) == SvIVX(right))
1299 : ( do_ncmp(left, right) == 0)
1300 ));
1301 RETURN;
a0d0e21e
LW
1302}
1303
b1c05ba5 1304
4c2c3128 1305/* also used for: pp_i_preinc() */
b1c05ba5 1306
a0d0e21e
LW
1307PP(pp_preinc)
1308{
4c2c3128
DM
1309 SV *sv = *PL_stack_sp;
1310
1311 if (LIKELY(((sv->sv_flags &
1312 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1313 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1314 == SVf_IOK))
1315 && SvIVX(sv) != IV_MAX)
1316 {
1317 SvIV_set(sv, SvIVX(sv) + 1);
1318 }
1319 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1320 sv_inc(sv);
1321 SvSETMAGIC(sv);
1322 return NORMAL;
1323}
1324
1325
1326/* also used for: pp_i_predec() */
1327
1328PP(pp_predec)
1329{
1330 SV *sv = *PL_stack_sp;
1331
1332 if (LIKELY(((sv->sv_flags &
1333 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1334 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1335 == SVf_IOK))
1336 && SvIVX(sv) != IV_MIN)
55497cff 1337 {
4c2c3128 1338 SvIV_set(sv, SvIVX(sv) - 1);
748a9306 1339 }
4c2c3128
DM
1340 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */
1341 sv_dec(sv);
1342 SvSETMAGIC(sv);
a0d0e21e
LW
1343 return NORMAL;
1344}
1345
b1c05ba5
DM
1346
1347/* also used for: pp_orassign() */
1348
a0d0e21e
LW
1349PP(pp_or)
1350{
20b7effb 1351 dSP;
f4c975aa 1352 SV *sv;
f410a211 1353 PERL_ASYNC_CHECK();
f4c975aa
DM
1354 sv = TOPs;
1355 if (SvTRUE_NN(sv))
a0d0e21e
LW
1356 RETURN;
1357 else {
c960fc3b
SP
1358 if (PL_op->op_type == OP_OR)
1359 --SP;
a0d0e21e
LW
1360 RETURNOP(cLOGOP->op_other);
1361 }
1362}
1363
b1c05ba5
DM
1364
1365/* also used for: pp_dor() pp_dorassign() */
1366
25a55bd7 1367PP(pp_defined)
c963b151 1368{
20b7effb 1369 dSP;
eb578fdb 1370 SV* sv;
6136c704 1371 bool defined;
25a55bd7 1372 const int op_type = PL_op->op_type;
ea5195b7 1373 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
c963b151 1374
6136c704 1375 if (is_dor) {
f410a211 1376 PERL_ASYNC_CHECK();
25a55bd7 1377 sv = TOPs;
5d9574c1 1378 if (UNLIKELY(!sv || !SvANY(sv))) {
2bd49cfc
NC
1379 if (op_type == OP_DOR)
1380 --SP;
25a55bd7
SP
1381 RETURNOP(cLOGOP->op_other);
1382 }
b7c44293
RGS
1383 }
1384 else {
1385 /* OP_DEFINED */
25a55bd7 1386 sv = POPs;
5d9574c1 1387 if (UNLIKELY(!sv || !SvANY(sv)))
25a55bd7 1388 RETPUSHNO;
b7c44293 1389 }
25a55bd7 1390
6136c704 1391 defined = FALSE;
c963b151
BD
1392 switch (SvTYPE(sv)) {
1393 case SVt_PVAV:
1394 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 1395 defined = TRUE;
c963b151
BD
1396 break;
1397 case SVt_PVHV:
1398 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 1399 defined = TRUE;
c963b151
BD
1400 break;
1401 case SVt_PVCV:
1402 if (CvROOT(sv) || CvXSUB(sv))
25a55bd7 1403 defined = TRUE;
c963b151
BD
1404 break;
1405 default:
5b295bef 1406 SvGETMAGIC(sv);
c963b151 1407 if (SvOK(sv))
25a55bd7 1408 defined = TRUE;
6136c704 1409 break;
c963b151 1410 }
6136c704
AL
1411
1412 if (is_dor) {
c960fc3b
SP
1413 if(defined)
1414 RETURN;
1415 if(op_type == OP_DOR)
1416 --SP;
25a55bd7 1417 RETURNOP(cLOGOP->op_other);
25a55bd7 1418 }
d9aa96a4
SP
1419 /* assuming OP_DEFINED */
1420 if(defined)
1421 RETPUSHYES;
1422 RETPUSHNO;
c963b151
BD
1423}
1424
230ee21f
DM
1425
1426
a0d0e21e
LW
1427PP(pp_add)
1428{
20b7effb 1429 dSP; dATARGET; bool useleft; SV *svl, *svr;
230ee21f 1430
6f1401dc
DM
1431 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
1432 svr = TOPs;
1433 svl = TOPm1s;
1434
28e5dec8 1435#ifdef PERL_PRESERVE_IVUV
230ee21f
DM
1436
1437 /* special-case some simple common cases */
1438 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1439 IV il, ir;
1440 U32 flags = (svl->sv_flags & svr->sv_flags);
1441 if (flags & SVf_IOK) {
1442 /* both args are simple IVs */
1443 UV topl, topr;
1444 il = SvIVX(svl);
1445 ir = SvIVX(svr);
1446 do_iv:
1447 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1448 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1449
1450 /* if both are in a range that can't under/overflow, do a
1451 * simple integer add: if the top of both numbers
1452 * are 00 or 11, then it's safe */
1453 if (!( ((topl+1) | (topr+1)) & 2)) {
1454 SP--;
1455 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1456 SETs(TARG);
1457 RETURN;
1458 }
1459 goto generic;
1460 }
1461 else if (flags & SVf_NOK) {
1462 /* both args are NVs */
1463 NV nl = SvNVX(svl);
1464 NV nr = SvNVX(svr);
1465
3336af0b
DD
1466 if (
1467#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1468 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1469 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1470#else
1471 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1472#endif
1473 )
230ee21f
DM
1474 /* nothing was lost by converting to IVs */
1475 goto do_iv;
1476 SP--;
1477 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1478 SETs(TARG);
1479 RETURN;
1480 }
1481 }
1482
1483 generic:
1484
1485 useleft = USE_LEFT(svl);
28e5dec8
JH
1486 /* We must see if we can perform the addition with integers if possible,
1487 as the integer code detects overflow while the NV code doesn't.
1488 If either argument hasn't had a numeric conversion yet attempt to get
1489 the IV. It's important to do this now, rather than just assuming that
1490 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1491 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1492 integer in case the second argument is IV=9223372036854775806
1493 We can (now) rely on sv_2iv to do the right thing, only setting the
1494 public IOK flag if the value in the NV (or PV) slot is truly integer.
1495
1496 A side effect is that this also aggressively prefers integer maths over
7dca457a
NC
1497 fp maths for integer values.
1498
a00b5bd3 1499 How to detect overflow?
7dca457a
NC
1500
1501 C 99 section 6.2.6.1 says
1502
1503 The range of nonnegative values of a signed integer type is a subrange
1504 of the corresponding unsigned integer type, and the representation of
1505 the same value in each type is the same. A computation involving
1506 unsigned operands can never overflow, because a result that cannot be
1507 represented by the resulting unsigned integer type is reduced modulo
1508 the number that is one greater than the largest value that can be
1509 represented by the resulting type.
1510
1511 (the 9th paragraph)
1512
1513 which I read as "unsigned ints wrap."
1514
1515 signed integer overflow seems to be classed as "exception condition"
1516
1517 If an exceptional condition occurs during the evaluation of an
1518 expression (that is, if the result is not mathematically defined or not
1519 in the range of representable values for its type), the behavior is
1520 undefined.
1521
1522 (6.5, the 5th paragraph)
1523
1524 I had assumed that on 2s complement machines signed arithmetic would
1525 wrap, hence coded pp_add and pp_subtract on the assumption that
1526 everything perl builds on would be happy. After much wailing and
1527 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1528 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
1529 unsigned code below is actually shorter than the old code. :-)
1530 */
1531
01f91bf2 1532 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1533 /* Unless the left argument is integer in range we are going to have to
1534 use NV maths. Hence only attempt to coerce the right argument if
1535 we know the left is integer. */
eb578fdb 1536 UV auv = 0;
9c5ffd7c 1537 bool auvok = FALSE;
7dca457a
NC
1538 bool a_valid = 0;
1539
28e5dec8 1540 if (!useleft) {
7dca457a
NC
1541 auv = 0;
1542 a_valid = auvok = 1;
1543 /* left operand is undef, treat as zero. + 0 is identity,
1544 Could SETi or SETu right now, but space optimise by not adding
1545 lots of code to speed up what is probably a rarish case. */
1546 } else {
1547 /* Left operand is defined, so is it IV? */
01f91bf2 1548 if (SvIV_please_nomg(svl)) {
800401ee
JH
1549 if ((auvok = SvUOK(svl)))
1550 auv = SvUVX(svl);
7dca457a 1551 else {
eb578fdb 1552 const IV aiv = SvIVX(svl);
7dca457a
NC
1553 if (aiv >= 0) {
1554 auv = aiv;
1555 auvok = 1; /* Now acting as a sign flag. */
53e2bfb7
DM
1556 } else {
1557 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
7dca457a
NC
1558 }
1559 }
1560 a_valid = 1;
28e5dec8
JH
1561 }
1562 }
7dca457a
NC
1563 if (a_valid) {
1564 bool result_good = 0;
1565 UV result;
eb578fdb 1566 UV buv;
800401ee 1567 bool buvok = SvUOK(svr);
a00b5bd3 1568
7dca457a 1569 if (buvok)
800401ee 1570 buv = SvUVX(svr);
7dca457a 1571 else {
eb578fdb 1572 const IV biv = SvIVX(svr);
7dca457a
NC
1573 if (biv >= 0) {
1574 buv = biv;
1575 buvok = 1;
1576 } else
53e2bfb7 1577 buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
7dca457a
NC
1578 }
1579 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1580 else "IV" now, independent of how it came in.
7dca457a
NC
1581 if a, b represents positive, A, B negative, a maps to -A etc
1582 a + b => (a + b)
1583 A + b => -(a - b)
1584 a + B => (a - b)
1585 A + B => -(a + b)
1586 all UV maths. negate result if A negative.
1587 add if signs same, subtract if signs differ. */
1588
1589 if (auvok ^ buvok) {
1590 /* Signs differ. */
1591 if (auv >= buv) {
1592 result = auv - buv;
1593 /* Must get smaller */
1594 if (result <= auv)
1595 result_good = 1;
1596 } else {
1597 result = buv - auv;
1598 if (result <= buv) {
1599 /* result really should be -(auv-buv). as its negation
1600 of true value, need to swap our result flag */
1601 auvok = !auvok;
1602 result_good = 1;
28e5dec8
JH
1603 }
1604 }
7dca457a
NC
1605 } else {
1606 /* Signs same */
1607 result = auv + buv;
1608 if (result >= auv)
1609 result_good = 1;
1610 }
1611 if (result_good) {
1612 SP--;
1613 if (auvok)
28e5dec8 1614 SETu( result );
7dca457a
NC
1615 else {
1616 /* Negate result */
1617 if (result <= (UV)IV_MIN)
53e2bfb7
DM
1618 SETi(result == (UV)IV_MIN
1619 ? IV_MIN : -(IV)result);
7dca457a
NC
1620 else {
1621 /* result valid, but out of range for IV. */
1622 SETn( -(NV)result );
28e5dec8
JH
1623 }
1624 }
7dca457a
NC
1625 RETURN;
1626 } /* Overflow, drop through to NVs. */
28e5dec8
JH
1627 }
1628 }
230ee21f
DM
1629
1630#else
1631 useleft = USE_LEFT(svl);
28e5dec8 1632#endif
230ee21f 1633
a0d0e21e 1634 {
6f1401dc 1635 NV value = SvNV_nomg(svr);
4efa5a16 1636 (void)POPs;
28e5dec8
JH
1637 if (!useleft) {
1638 /* left operand is undef, treat as zero. + 0.0 is identity. */
1639 SETn(value);
1640 RETURN;
1641 }
6f1401dc 1642 SETn( value + SvNV_nomg(svl) );
28e5dec8 1643 RETURN;
a0d0e21e
LW
1644 }
1645}
1646
b1c05ba5
DM
1647
1648/* also used for: pp_aelemfast_lex() */
1649
a0d0e21e
LW
1650PP(pp_aelemfast)
1651{
20b7effb 1652 dSP;
93bad3fd 1653 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
8f878375 1654 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
a3b680e6 1655 const U32 lval = PL_op->op_flags & OPf_MOD;
7e169e84
DM
1656 const I8 key = (I8)PL_op->op_private;
1657 SV** svp;
1658 SV *sv;
1659
1660 assert(SvTYPE(av) == SVt_PVAV);
1661
f4484b87
DM
1662 EXTEND(SP, 1);
1663
7e169e84
DM
1664 /* inlined av_fetch() for simple cases ... */
1665 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1666 sv = AvARRAY(av)[key];
9fb994be 1667 if (sv) {
7e169e84
DM
1668 PUSHs(sv);
1669 RETURN;
1670 }
1671 }
1672
1673 /* ... else do it the hard way */
1674 svp = av_fetch(av, key, lval);
1675 sv = (svp ? *svp : &PL_sv_undef);
b024352e
DM
1676
1677 if (UNLIKELY(!svp && lval))
7e169e84 1678 DIE(aTHX_ PL_no_aelem, (int)key);
b024352e 1679
39cf747a 1680 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 1681 mg_get(sv);
be6c24e0 1682 PUSHs(sv);
a0d0e21e
LW
1683 RETURN;
1684}
1685
1686PP(pp_join)
1687{
20b7effb 1688 dSP; dMARK; dTARGET;
a0d0e21e
LW
1689 MARK++;
1690 do_join(TARG, *MARK, MARK, SP);
1691 SP = MARK;
1692 SETs(TARG);
1693 RETURN;
1694}
1695
a0d0e21e
LW
1696/* Oversized hot code. */
1697
b1c05ba5
DM
1698/* also used for: pp_say() */
1699
a0d0e21e
LW
1700PP(pp_print)
1701{
20b7effb 1702 dSP; dMARK; dORIGMARK;
eb578fdb 1703 PerlIO *fp;
236988e4 1704 MAGIC *mg;
159b6efe
NC
1705 GV * const gv
1706 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 1707 IO *io = GvIO(gv);
5b468f54 1708
9c9f25b8 1709 if (io
ad64d0ec 1710 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 1711 {
01bb7c6d 1712 had_magic:
68dc0745 1713 if (MARK == ORIGMARK) {
1c846c1f 1714 /* If using default handle then we need to make space to
a60c0954
NIS
1715 * pass object as 1st arg, so move other args up ...
1716 */
4352c267 1717 MEXTEND(SP, 1);
68dc0745
PP
1718 ++MARK;
1719 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1720 ++SP;
1721 }
3e0cb5de 1722 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
94bc412f
NC
1723 mg,
1724 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1725 | (PL_op->op_type == OP_SAY
1726 ? TIED_METHOD_SAY : 0)), sp - mark);
236988e4 1727 }
9c9f25b8 1728 if (!io) {
68b590d9 1729 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
ad64d0ec 1730 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 1731 goto had_magic;
51087808 1732 report_evil_fh(gv);
93189314 1733 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
1734 goto just_say_no;
1735 }
1736 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
1737 if (IoIFP(io))
1738 report_wrongway_fh(gv, '<');
51087808 1739 else
7716c5c5 1740 report_evil_fh(gv);
93189314 1741 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
1742 goto just_say_no;
1743 }
1744 else {
e23d9e2f 1745 SV * const ofs = GvSV(PL_ofsgv); /* $, */
a0d0e21e 1746 MARK++;
e23d9e2f 1747 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
a0d0e21e
LW
1748 while (MARK <= SP) {
1749 if (!do_print(*MARK, fp))
1750 break;
1751 MARK++;
1752 if (MARK <= SP) {
e23d9e2f
CS
1753 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
1754 if (!do_print(GvSV(PL_ofsgv), fp)) {
a0d0e21e
LW
1755 MARK--;
1756 break;
1757 }
1758 }
1759 }
1760 }
1761 else {
1762 while (MARK <= SP) {
1763 if (!do_print(*MARK, fp))
1764 break;
1765 MARK++;
1766 }
1767 }
1768 if (MARK <= SP)
1769 goto just_say_no;
1770 else {
cfc4a7da
GA
1771 if (PL_op->op_type == OP_SAY) {
1772 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
1773 goto just_say_no;
1774 }
1775 else if (PL_ors_sv && SvOK(PL_ors_sv))
7889fe52 1776 if (!do_print(PL_ors_sv, fp)) /* $\ */
a0d0e21e
LW
1777 goto just_say_no;
1778
1779 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1780 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
1781 goto just_say_no;
1782 }
1783 }
1784 SP = ORIGMARK;
e52fd6f4 1785 XPUSHs(&PL_sv_yes);
a0d0e21e
LW
1786 RETURN;
1787
1788 just_say_no:
1789 SP = ORIGMARK;
e52fd6f4 1790 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
1791 RETURN;
1792}
1793
b1c05ba5 1794
aa36782f
DM
1795/* do the common parts of pp_padhv() and pp_rv2hv()
1796 * It assumes the caller has done EXTEND(SP, 1) or equivalent.
af3b1cba 1797 * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
e84e4286
DM
1798 * 'has_targ' indicates that the op has a target - this should
1799 * be a compile-time constant so that the code can constant-folded as
1800 * appropriate
aa36782f
DM
1801 * */
1802
1803PERL_STATIC_INLINE OP*
e84e4286 1804S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
aa36782f 1805{
e80717e7
DM
1806 bool is_tied;
1807 bool is_bool;
e1ad5d4c 1808 MAGIC *mg;
aa36782f 1809 dSP;
e80717e7
DM
1810 IV i;
1811 SV *sv;
aa36782f
DM
1812
1813 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
1814
1815 if (gimme == G_ARRAY) {
8dc9003f 1816 hv_pushkv(hv, 3);
af3b1cba 1817 return NORMAL;
aa36782f
DM
1818 }
1819
1820 if (is_keys)
1821 /* 'keys %h' masquerading as '%h': reset iterator */
1822 (void)hv_iterinit(hv);
1823
6f2dc9a6
DM
1824 if (gimme == G_VOID)
1825 return NORMAL;
1826
e80717e7
DM
1827 is_bool = ( PL_op->op_private & OPpTRUEBOOL
1828 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
1829 && block_gimme() == G_VOID));
1830 is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
1831
1832 if (UNLIKELY(is_tied)) {
1833 if (is_keys && !is_bool) {
1834 i = 0;
1835 while (hv_iternext(hv))
1836 i++;
1837 goto push_i;
1838 }
1839 else {
1840 sv = magic_scalarpack(hv, mg);
1841 goto push_sv;
1842 }
3cd2c7d4 1843 }
e80717e7
DM
1844 else {
1845 i = HvUSEDKEYS(hv);
1846 if (is_bool) {
1847 sv = i ? &PL_sv_yes : &PL_sv_zero;
1848 push_sv:
1849 PUSHs(sv);
1850 }
1851 else {
1852 push_i:
e84e4286
DM
1853 if (has_targ) {
1854 dTARGET;
1855 PUSHi(i);
1856 }
1857 else
6f2dc9a6
DM
1858#ifdef PERL_OP_PARENT
1859 if (is_keys) {
1860 /* parent op should be an unused OP_KEYS whose targ we can
1861 * use */
1862 dTARG;
1863 OP *k;
1864
1865 assert(!OpHAS_SIBLING(PL_op));
1866 k = PL_op->op_sibparent;
1867 assert(k->op_type == OP_KEYS);
1868 TARG = PAD_SV(k->op_targ);
1869 PUSHi(i);
1870 }
1871 else
1872#endif
e84e4286 1873 mPUSHi(i);
aa36782f 1874 }
aa36782f
DM
1875 }
1876
1877 PUTBACK;
1878 return NORMAL;
1879}
1880
1881
e855b461
DM
1882/* This is also called directly by pp_lvavref. */
1883PP(pp_padav)
1884{
1885 dSP; dTARGET;
1886 U8 gimme;
1887 assert(SvTYPE(TARG) == SVt_PVAV);
1888 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1889 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1890 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1891 EXTEND(SP, 1);
1892
1893 if (PL_op->op_flags & OPf_REF) {
1894 PUSHs(TARG);
1895 RETURN;
1896 }
1897 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1898 const I32 flags = is_lvalue_sub();
1899 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1900 if (GIMME_V == G_SCALAR)
1901 /* diag_listed_as: Can't return %s to lvalue scalar context */
1902 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1903 PUSHs(TARG);
1904 RETURN;
1905 }
1906 }
1907
1908 gimme = GIMME_V;
0b5aba47
DM
1909 if (gimme == G_ARRAY)
1910 return S_pushav(aTHX_ (AV*)TARG);
327c9b9e
DM
1911
1912 if (gimme == G_SCALAR) {
e855b461
DM
1913 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
1914 if (!maxarg)
1915 PUSHs(&PL_sv_zero);
1916 else if (PL_op->op_private & OPpTRUEBOOL)
1917 PUSHs(&PL_sv_yes);
1918 else
1919 mPUSHi(maxarg);
1920 }
1921 RETURN;
1922}
1923
1924
1925PP(pp_padhv)
1926{
1927 dSP; dTARGET;
1928 U8 gimme;
e855b461
DM
1929
1930 assert(SvTYPE(TARG) == SVt_PVHV);
e855b461
DM
1931 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1932 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1933 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1934
aa36782f
DM
1935 EXTEND(SP, 1);
1936
1937 if (PL_op->op_flags & OPf_REF) {
1938 PUSHs(TARG);
e855b461 1939 RETURN;
aa36782f 1940 }
e855b461
DM
1941 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1942 const I32 flags = is_lvalue_sub();
1943 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1944 if (GIMME_V == G_SCALAR)
1945 /* diag_listed_as: Can't return %s to lvalue scalar context */
1946 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
aa36782f 1947 PUSHs(TARG);
e855b461
DM
1948 RETURN;
1949 }
1950 }
1951
1952 gimme = GIMME_V;
e855b461 1953
aa36782f 1954 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
e84e4286
DM
1955 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
1956 0 /* has_targ*/);
e855b461
DM
1957}
1958
1959
b1c05ba5 1960/* also used for: pp_rv2hv() */
bdaf10a5 1961/* also called directly by pp_lvavref */
b1c05ba5 1962
a0d0e21e
LW
1963PP(pp_rv2av)
1964{
20b7effb 1965 dSP; dTOPss;
1c23e2bd 1966 const U8 gimme = GIMME_V;
13c59d41
MH
1967 static const char an_array[] = "an ARRAY";
1968 static const char a_hash[] = "a HASH";
bdaf10a5
FC
1969 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
1970 || PL_op->op_type == OP_LVAVREF;
d83b45b8 1971 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 1972
9026059d 1973 SvGETMAGIC(sv);
a0d0e21e 1974 if (SvROK(sv)) {
5d9574c1 1975 if (UNLIKELY(SvAMAGIC(sv))) {
93d7320b 1976 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
93d7320b 1977 }
17ab7946 1978 sv = SvRV(sv);
5d9574c1 1979 if (UNLIKELY(SvTYPE(sv) != type))
dcbac5bb 1980 /* diag_listed_as: Not an ARRAY reference */
13c59d41 1981 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
5d9574c1
DM
1982 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
1983 && PL_op->op_private & OPpLVAL_INTRO))
3da99855 1984 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e 1985 }
5d9574c1 1986 else if (UNLIKELY(SvTYPE(sv) != type)) {
67955e0c 1987 GV *gv;
1c846c1f 1988
6e592b3a 1989 if (!isGV_with_GP(sv)) {
13c59d41 1990 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
dc3c76f8
NC
1991 type, &sp);
1992 if (!gv)
1993 RETURN;
35cd451c
GS
1994 }
1995 else {
159b6efe 1996 gv = MUTABLE_GV(sv);
a0d0e21e 1997 }
ad64d0ec 1998 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 1999 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 2000 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
9f527363
FC
2001 }
2002 if (PL_op->op_flags & OPf_REF) {
17ab7946 2003 SETs(sv);
a0d0e21e 2004 RETURN;
9f527363 2005 }
5d9574c1 2006 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
40c94d11
FC
2007 const I32 flags = is_lvalue_sub();
2008 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 2009 if (gimme != G_ARRAY)
042560a6 2010 goto croak_cant_return;
17ab7946 2011 SETs(sv);
78f9721b 2012 RETURN;
40c94d11 2013 }
a0d0e21e
LW
2014 }
2015
17ab7946 2016 if (is_pp_rv2av) {
502c6561 2017 AV *const av = MUTABLE_AV(sv);
0b5aba47 2018
96913b52 2019 if (gimme == G_ARRAY) {
d5524600
DM
2020 SP--;
2021 PUTBACK;
0b5aba47 2022 return S_pushav(aTHX_ av);
1c846c1f 2023 }
0b5aba47
DM
2024
2025 if (gimme == G_SCALAR) {
c70927a6 2026 const SSize_t maxarg = AvFILL(av) + 1;
7be75ccf
DM
2027 if (PL_op->op_private & OPpTRUEBOOL)
2028 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
2029 else {
2030 dTARGET;
2031 SETi(maxarg);
2032 }
93965878 2033 }
7be75ccf
DM
2034 }
2035 else {
aa36782f
DM
2036 SP--; PUTBACK;
2037 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
e84e4286
DM
2038 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2039 1 /* has_targ*/);
17ab7946 2040 }
be85d344 2041 RETURN;
042560a6
NC
2042
2043 croak_cant_return:
2044 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
2045 is_pp_rv2av ? "array" : "hash");
77e217c6 2046 RETURN;
a0d0e21e
LW
2047}
2048
10c8fecd 2049STATIC void
fb8f4cf8 2050S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
10c8fecd 2051{
7918f24d
NC
2052 PERL_ARGS_ASSERT_DO_ODDBALL;
2053
fb8f4cf8 2054 if (*oddkey) {
6d822dc4 2055 if (ckWARN(WARN_MISC)) {
a3b680e6 2056 const char *err;
fb8f4cf8
RZ
2057 if (oddkey == firstkey &&
2058 SvROK(*oddkey) &&
2059 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2060 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
10c8fecd 2061 {
a3b680e6 2062 err = "Reference found where even-sized list expected";
10c8fecd
GS
2063 }
2064 else
a3b680e6 2065 err = "Odd number of elements in hash assignment";
f1f66076 2066 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
10c8fecd 2067 }
6d822dc4 2068
10c8fecd
GS
2069 }
2070}
2071
a5f48505
DM
2072
2073/* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2074 * are common to both the LHS and RHS of an aassign, and replace them
2075 * with copies. All these copies are made before the actual list assign is
2076 * done.
2077 *
2078 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2079 * element ($b) to the first LH element ($a), modifies $a; when the
2080 * second assignment is done, the second RH element now has the wrong
2081 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
2082 * Note that we don't need to make a mortal copy of $b.
2083 *
2084 * The algorithm below works by, for every RHS element, mark the
2085 * corresponding LHS target element with SVf_BREAK. Then if the RHS
2086 * element is found with SVf_BREAK set, it means it would have been
2087 * modified, so make a copy.
2088 * Note that by scanning both LHS and RHS in lockstep, we avoid
2089 * unnecessary copies (like $b above) compared with a naive
2090 * "mark all LHS; copy all marked RHS; unmark all LHS".
2091 *
2092 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2093 * it can't be common and can be skipped.
ebc643ce
DM
2094 *
2095 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2096 * that we thought we didn't need to call S_aassign_copy_common(), but we
2097 * have anyway for sanity checking. If we find we need to copy, then panic.
a5f48505
DM
2098 */
2099
2100PERL_STATIC_INLINE void
2101S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
ebc643ce
DM
2102 SV **firstrelem, SV **lastrelem
2103#ifdef DEBUGGING
2104 , bool fake
2105#endif
2106)
a5f48505
DM
2107{
2108 dVAR;
2109 SV **relem;
2110 SV **lelem;
2111 SSize_t lcount = lastlelem - firstlelem + 1;
2112 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
2113 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
beb08a1e 2114 bool copy_all = FALSE;
a5f48505
DM
2115
2116 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
2117 assert(firstlelem < lastlelem); /* at least 2 LH elements */
2118 assert(firstrelem < lastrelem); /* at least 2 RH elements */
2119
ebc643ce
DM
2120
2121 lelem = firstlelem;
a5f48505
DM
2122 /* we never have to copy the first RH element; it can't be corrupted
2123 * by assigning something to the corresponding first LH element.
2124 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
2125 */
ebc643ce 2126 relem = firstrelem + 1;
a5f48505
DM
2127
2128 for (; relem <= lastrelem; relem++) {
2129 SV *svr;
2130
2131 /* mark next LH element */
2132
2133 if (--lcount >= 0) {
2134 SV *svl = *lelem++;
2135
2136 if (UNLIKELY(!svl)) {/* skip AV alias marker */
2137 assert (lelem <= lastlelem);
2138 svl = *lelem++;
2139 lcount--;
2140 }
2141
2142 assert(svl);
beb08a1e
TC
2143 if (SvSMAGICAL(svl)) {
2144 copy_all = TRUE;
2145 }
a5f48505
DM
2146 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
2147 if (!marked)
2148 return;
2149 /* this LH element will consume all further args;
2150 * no need to mark any further LH elements (if any).
2151 * But we still need to scan any remaining RHS elements;
2152 * set lcount negative to distinguish from lcount == 0,
2153 * so the loop condition continues being true
2154 */
2155 lcount = -1;
2156 lelem--; /* no need to unmark this element */
2157 }
94a5f659 2158 else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
a5f48505
DM
2159 SvFLAGS(svl) |= SVf_BREAK;
2160 marked = TRUE;
2161 }
2162 else if (!marked) {
2163 /* don't check RH element if no SVf_BREAK flags set yet */
2164 if (!lcount)
2165 break;
2166 continue;
2167 }
2168 }
2169
2170 /* see if corresponding RH element needs copying */
2171
2172 assert(marked);
2173 svr = *relem;
2174 assert(svr);
2175
5c1db569 2176 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
1050723f 2177 U32 brk = (SvFLAGS(svr) & SVf_BREAK);
a5f48505 2178
ebc643ce
DM
2179#ifdef DEBUGGING
2180 if (fake) {
9ae0115f 2181 /* op_dump(PL_op); */
ebc643ce
DM
2182 Perl_croak(aTHX_
2183 "panic: aassign skipped needed copy of common RH elem %"
2184 UVuf, (UV)(relem - firstrelem));
2185 }
2186#endif
2187
a5f48505
DM
2188 TAINT_NOT; /* Each item is independent */
2189
2190 /* Dear TODO test in t/op/sort.t, I love you.
2191 (It's relying on a panic, not a "semi-panic" from newSVsv()
2192 and then an assertion failure below.) */
2193 if (UNLIKELY(SvIS_FREED(svr))) {
2194 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
2195 (void*)svr);
2196 }
2197 /* avoid break flag while copying; otherwise COW etc
2198 * disabled... */
2199 SvFLAGS(svr) &= ~SVf_BREAK;
2200 /* Not newSVsv(), as it does not allow copy-on-write,
8c1e192f
DM
2201 resulting in wasteful copies.
2202 Also, we use SV_NOSTEAL in case the SV is used more than
2203 once, e.g. (...) = (f())[0,0]
2204 Where the same SV appears twice on the RHS without a ref
2205 count bump. (Although I suspect that the SV won't be
2206 stealable here anyway - DAPM).
2207 */
a5f48505
DM
2208 *relem = sv_mortalcopy_flags(svr,
2209 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2210 /* ... but restore afterwards in case it's needed again,
2211 * e.g. ($a,$b,$c) = (1,$a,$a)
2212 */
1050723f 2213 SvFLAGS(svr) |= brk;
a5f48505
DM
2214 }
2215
2216 if (!lcount)
2217 break;
2218 }
2219
2220 if (!marked)
2221 return;
2222
2223 /*unmark LHS */
2224
2225 while (lelem > firstlelem) {
2226 SV * const svl = *(--lelem);
2227 if (svl)
2228 SvFLAGS(svl) &= ~SVf_BREAK;
2229 }
2230}
2231
2232
2233
a0d0e21e
LW
2234PP(pp_aassign)
2235{
27da23d5 2236 dVAR; dSP;
3280af22
NIS
2237 SV **lastlelem = PL_stack_sp;
2238 SV **lastrelem = PL_stack_base + POPMARK;
2239 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
2240 SV **firstlelem = lastrelem + 1;
2241
eb578fdb
KW
2242 SV **relem;
2243 SV **lelem;
1c23e2bd 2244 U8 gimme;
a68090fe
DM
2245 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
2246 * only need to save locally, not on the save stack */
2247 U16 old_delaymagic = PL_delaymagic;
ebc643ce
DM
2248#ifdef DEBUGGING
2249 bool fake = 0;
2250#endif
5637b936 2251
3280af22 2252 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
a0d0e21e
LW
2253
2254 /* If there's a common identifier on both sides we have to take
2255 * special care that assigning the identifier on the left doesn't
2256 * clobber a value on the right that's used later in the list.
2257 */
acdea6f0 2258
beb08a1e
TC
2259 /* at least 2 LH and RH elements, or commonality isn't an issue */
2260 if (firstlelem < lastlelem && firstrelem < lastrelem) {
5c1db569
TC
2261 for (relem = firstrelem+1; relem <= lastrelem; relem++) {
2262 if (SvGMAGICAL(*relem))
2263 goto do_scan;
2264 }
beb08a1e
TC
2265 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2266 if (*lelem && SvSMAGICAL(*lelem))
2267 goto do_scan;
a5f48505 2268 }
beb08a1e
TC
2269 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
2270 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
2271 /* skip the scan if all scalars have a ref count of 1 */
2272 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
8b0c3377 2273 SV *sv = *lelem;
beb08a1e
TC
2274 if (!sv || SvREFCNT(sv) == 1)
2275 continue;
2276 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
2277 goto do_scan;
2278 break;
2279 }
2280 }
2281 else {
2282 do_scan:
2283 S_aassign_copy_common(aTHX_
2284 firstlelem, lastlelem, firstrelem, lastrelem
ebc643ce 2285#ifdef DEBUGGING
beb08a1e 2286 , fake
ebc643ce 2287#endif
beb08a1e
TC
2288 );
2289 }
a5f48505 2290 }
a0d0e21e 2291 }
ebc643ce
DM
2292#ifdef DEBUGGING
2293 else {
2294 /* on debugging builds, do the scan even if we've concluded we
2295 * don't need to, then panic if we find commonality. Note that the
2296 * scanner assumes at least 2 elements */
2297 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2298 fake = 1;
2299 goto do_scan;
2300 }
2301 }
2302#endif
a0d0e21e 2303
a5f48505 2304 gimme = GIMME_V;
a0d0e21e
LW
2305 relem = firstrelem;
2306 lelem = firstlelem;
10c8fecd 2307
8b0c3377
DM
2308 if (relem > lastrelem)
2309 goto no_relems;
2310
2311 /* first lelem loop while there are still relems */
5d9574c1 2312 while (LIKELY(lelem <= lastlelem)) {
bdaf10a5 2313 bool alias = FALSE;
8b0c3377
DM
2314 SV *lsv = *lelem++;
2315
c73f612f
DM
2316 TAINT_NOT; /* Each item stands on its own, taintwise. */
2317
8b0c3377
DM
2318 assert(relem <= lastrelem);
2319 if (UNLIKELY(!lsv)) {
bdaf10a5 2320 alias = TRUE;
8b0c3377
DM
2321 lsv = *lelem++;
2322 ASSUME(SvTYPE(lsv) == SVt_PVAV);
bdaf10a5 2323 }
a5f48505 2324
8b0c3377
DM
2325 switch (SvTYPE(lsv)) {
2326 case SVt_PVAV: {
2327 SV **svp;
2328 SSize_t i;
2329 SSize_t tmps_base;
2330 SSize_t nelems = lastrelem - relem + 1;
b09ed995 2331 AV *ary = MUTABLE_AV(lsv);
8b0c3377
DM
2332
2333 /* Assigning to an aggregate is tricky. First there is the
2334 * issue of commonality, e.g. @a = ($a[0]). Since the
2335 * stack isn't refcounted, clearing @a prior to storing
2336 * elements will free $a[0]. Similarly with
2337 * sub FETCH { $status[$_[1]] } @status = @tied[0,1];
2338 *
2339 * The way to avoid these issues is to make the copy of each
2340 * SV (and we normally store a *copy* in the array) *before*
2341 * clearing the array. But this has a problem in that
2342 * if the code croaks during copying, the not-yet-stored copies
2343 * could leak. One way to avoid this is to make all the copies
2344 * mortal, but that's quite expensive.
2345 *
2346 * The current solution to these issues is to use a chunk
2347 * of the tmps stack as a temporary refcounted-stack. SVs
2348 * will be put on there during processing to avoid leaks,
2349 * but will be removed again before the end of this block,
2350 * so free_tmps() is never normally called. Also, the
2351 * sv_refcnt of the SVs doesn't have to be manipulated, since
2352 * the ownership of 1 reference count is transferred directly
2353 * from the tmps stack to the AV when the SV is stored.
2354 *
2355 * We disarm slots in the temps stack by storing PL_sv_undef
2356 * there: it doesn't matter if that SV's refcount is
2357 * repeatedly decremented during a croak. But usually this is
2358 * only an interim measure. By the end of this code block
2359 * we try where possible to not leave any PL_sv_undef's on the
2360 * tmps stack e.g. by shuffling newer entries down.
2361 *
2362 * There is one case where we don't copy: non-magical
2363 * SvTEMP(sv)'s with a ref count of 1. The only owner of these
2364 * is on the tmps stack, so its safe to directly steal the SV
2365 * rather than copying. This is common in things like function
2366 * returns, map etc, which all return a list of such SVs.
2367 *
2368 * Note however something like @a = (f())[0,0], where there is
2369 * a danger of the same SV being shared: this avoided because
2370 * when the SV is stored as $a[0], its ref count gets bumped,
2371 * so the RC==1 test fails and the second element is copied
2372 * instead.
2373 *
2374 * We also use one slot in the tmps stack to hold an extra
2375 * ref to the array, to ensure it doesn't get prematurely
2376 * freed. Again, this is removed before the end of this block.
2377 *
2378 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
2379 * @a = ($a[0]) case, but the current implementation uses the
2380 * same algorithm regardless, so ignores that flag. (It *is*
2381 * used in the hash branch below, however).
2382 */
2383
2384 /* Reserve slots for ary, plus the elems we're about to copy,
2385 * then protect ary and temporarily void the remaining slots
2386 * with &PL_sv_undef */
2387 EXTEND_MORTAL(nelems + 1);
2388 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
2389 tmps_base = PL_tmps_ix + 1;
2390 for (i = 0; i < nelems; i++)
2391 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2392 PL_tmps_ix += nelems;
2393
2394 /* Make a copy of each RHS elem and save on the tmps_stack
2395 * (or pass through where we can optimise away the copy) */
2396
2397 if (UNLIKELY(alias)) {
2398 U32 lval = (gimme == G_ARRAY)
2399 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
a5f48505 2400 for (svp = relem; svp <= lastrelem; svp++) {
8b0c3377
DM
2401 SV *rsv = *svp;
2402
2403 SvGETMAGIC(rsv);
2404 if (!SvROK(rsv))
2405 DIE(aTHX_ "Assigned value is not a reference");
2406 if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
2407 /* diag_listed_as: Assigned value is not %s reference */
2408 DIE(aTHX_
2409 "Assigned value is not a SCALAR reference");
2410 if (lval)
2411 *svp = rsv = sv_mortalcopy(rsv);
2412 /* XXX else check for weak refs? */
2413 rsv = SvREFCNT_inc_NN(SvRV(rsv));
2414 assert(tmps_base <= PL_tmps_max);
2415 PL_tmps_stack[tmps_base++] = rsv;
a5f48505 2416 }
a5f48505 2417 }
8b0c3377
DM
2418 else {
2419 for (svp = relem; svp <= lastrelem; svp++) {
2420 SV *rsv = *svp;
a5f48505 2421
8b0c3377
DM
2422 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2423 /* can skip the copy */
2424 SvREFCNT_inc_simple_void_NN(rsv);
2425 SvTEMP_off(rsv);
2426 }
a5f48505 2427 else {
8b0c3377
DM
2428 SV *nsv;
2429 /* do get before newSV, in case it dies and leaks */
2430 SvGETMAGIC(rsv);
2431 nsv = newSV(0);
8c1e192f
DM
2432 /* see comment in S_aassign_copy_common about
2433 * SV_NOSTEAL */
8b0c3377
DM
2434 sv_setsv_flags(nsv, rsv,
2435 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2436 rsv = *svp = nsv;
a5f48505 2437 }
8b0c3377
DM
2438
2439 assert(tmps_base <= PL_tmps_max);
2440 PL_tmps_stack[tmps_base++] = rsv;
2441 }
2442 }
2443
2444 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
2445 av_clear(ary);
2446
2447 /* store in the array, the SVs that are in the tmps stack */
2448
2449 tmps_base -= nelems;
2450
80c1439f 2451 if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
8b0c3377
DM
2452 /* for arrays we can't cheat with, use the official API */
2453 av_extend(ary, nelems - 1);
2454 for (i = 0; i < nelems; i++) {
2455 SV **svp = &(PL_tmps_stack[tmps_base + i]);
2456 SV *rsv = *svp;
2457 /* A tied store won't take ownership of rsv, so keep
2458 * the 1 refcnt on the tmps stack; otherwise disarm
2459 * the tmps stack entry */
2460 if (av_store(ary, i, rsv))
2461 *svp = &PL_sv_undef;
2462 /* av_store() may have added set magic to rsv */;
2463 SvSETMAGIC(rsv);
2464 }
2465 /* disarm ary refcount: see comments below about leak */
2466 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2467 }
2468 else {
2469 /* directly access/set the guts of the AV */
2470 SSize_t fill = nelems - 1;
2471 if (fill > AvMAX(ary))
2472 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
2473 &AvARRAY(ary));
2474 AvFILLp(ary) = fill;
2475 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
2476 /* Quietly remove all the SVs from the tmps stack slots,
2477 * since ary has now taken ownership of the refcnt.
2478 * Also remove ary: which will now leak if we die before
2479 * the SvREFCNT_dec_NN(ary) below */
2480 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2481 Move(&PL_tmps_stack[tmps_base + nelems],
2482 &PL_tmps_stack[tmps_base - 1],
2483 PL_tmps_ix - (tmps_base + nelems) + 1,
2484 SV*);
2485 PL_tmps_ix -= (nelems + 1);
2486 }
2487
5d9574c1 2488 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
8b0c3377 2489 /* its assumed @ISA set magic can't die and leak ary */
ad64d0ec 2490 SvSETMAGIC(MUTABLE_SV(ary));
8b0c3377
DM
2491 SvREFCNT_dec_NN(ary);
2492
2493 relem = lastrelem + 1;
2494 goto no_relems;
a5f48505
DM
2495 }
2496
10c8fecd 2497 case SVt_PVHV: { /* normal hash */
8b0c3377
DM
2498
2499 SV **svp;
2500 bool dirty_tmps;
2501 SSize_t i;
2502 SSize_t tmps_base;
2503 SSize_t nelems = lastrelem - relem + 1;
b09ed995 2504 HV *hash = MUTABLE_HV(lsv);
8b0c3377
DM
2505
2506 if (UNLIKELY(nelems & 1)) {
2507 do_oddball(lastrelem, relem);
2508 /* we have firstlelem to reuse, it's not needed any more */
2509 *++lastrelem = &PL_sv_undef;
2510 nelems++;
2511 }
2512
2513 /* See the SVt_PVAV branch above for a long description of
2514 * how the following all works. The main difference for hashes
2515 * is that we treat keys and values separately (and have
2516 * separate loops for them): as for arrays, values are always
2517 * copied (except for the SvTEMP optimisation), since they
2518 * need to be stored in the hash; while keys are only
2519 * processed where they might get prematurely freed or
2520 * whatever. */
2521
2522 /* tmps stack slots:
2523 * * reserve a slot for the hash keepalive;
2524 * * reserve slots for the hash values we're about to copy;
2525 * * preallocate for the keys we'll possibly copy or refcount bump
2526 * later;
2527 * then protect hash and temporarily void the remaining
2528 * value slots with &PL_sv_undef */
2529 EXTEND_MORTAL(nelems + 1);
2530
2531 /* convert to number of key/value pairs */
2532 nelems >>= 1;
2533
2534 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
2535 tmps_base = PL_tmps_ix + 1;
2536 for (i = 0; i < nelems; i++)
2537 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2538 PL_tmps_ix += nelems;
2539
2540 /* Make a copy of each RHS hash value and save on the tmps_stack
2541 * (or pass through where we can optimise away the copy) */
2542
2543 for (svp = relem + 1; svp <= lastrelem; svp += 2) {
2544 SV *rsv = *svp;
2545
2546 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2547 /* can skip the copy */
2548 SvREFCNT_inc_simple_void_NN(rsv);
2549 SvTEMP_off(rsv);
2550 }
2551 else {
2552 SV *nsv;
2553 /* do get before newSV, in case it dies and leaks */
2554 SvGETMAGIC(rsv);
2555 nsv = newSV(0);
2556 /* see comment in S_aassign_copy_common about
2557 * SV_NOSTEAL */
2558 sv_setsv_flags(nsv, rsv,
2559 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2560 rsv = *svp = nsv;
1c4ea384
RZ
2561 }
2562
8b0c3377
DM
2563 assert(tmps_base <= PL_tmps_max);
2564 PL_tmps_stack[tmps_base++] = rsv;
2565 }
2566 tmps_base -= nelems;
a5f48505 2567
a5f48505 2568
8b0c3377
DM
2569 /* possibly protect keys */
2570
2571 if (UNLIKELY(gimme == G_ARRAY)) {
2572 /* handle e.g.
2573 * @a = ((%h = ($$r, 1)), $r = "x");
2574 * $_++ for %h = (1,2,3,4);
2575 */
2576 EXTEND_MORTAL(nelems);
2577 for (svp = relem; svp <= lastrelem; svp += 2)
2578 *svp = sv_mortalcopy_flags(*svp,
2579 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2580 }
2581 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
2582 /* for possible commonality, e.g.
2583 * %h = ($h{a},1)
2584 * avoid premature freeing RHS keys by mortalising
2585 * them.
2586 * For a magic element, make a copy so that its magic is
2587 * called *before* the hash is emptied (which may affect
2588 * a tied value for example).
2589 * In theory we should check for magic keys in all
2590 * cases, not just under OPpASSIGN_COMMON_AGG, but in
2591 * practice, !OPpASSIGN_COMMON_AGG implies only
2592 * constants or padtmps on the RHS.
2593 */
2594 EXTEND_MORTAL(nelems);
2595 for (svp = relem; svp <= lastrelem; svp += 2) {
2596 SV *rsv = *svp;
2597 if (UNLIKELY(SvGMAGICAL(rsv))) {
2598 SSize_t n;
a5f48505
DM
2599 *svp = sv_mortalcopy_flags(*svp,
2600 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
8b0c3377
DM
2601 /* allow other branch to continue pushing
2602 * onto tmps stack without checking each time */
2603 n = (lastrelem - relem) >> 1;
2604 EXTEND_MORTAL(n);
a5f48505 2605 }
8b0c3377
DM
2606 else
2607 PL_tmps_stack[++PL_tmps_ix] =
2608 SvREFCNT_inc_simple_NN(rsv);
a5f48505 2609 }
8b0c3377 2610 }
a5f48505 2611
8b0c3377
DM
2612 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
2613 hv_clear(hash);
a5f48505 2614
8b0c3377
DM
2615 /* now assign the keys and values to the hash */
2616
2617 dirty_tmps = FALSE;
2618
2619 if (UNLIKELY(gimme == G_ARRAY)) {
2620 /* @a = (%h = (...)) etc */
2621 SV **svp;
2622 SV **topelem = relem;
2623
2624 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2625 SV *key = *svp++;
2626 SV *val = *svp;
2627 /* remove duplicates from list we return */
2628 if (!hv_exists_ent(hash, key, 0)) {
2629 /* copy key back: possibly to an earlier
2630 * stack location if we encountered dups earlier,
2631 * The values will be updated later
2632 */
2633 *topelem = key;
2634 topelem += 2;
632b9d6f 2635 }
8b0c3377
DM
2636 /* A tied store won't take ownership of val, so keep
2637 * the 1 refcnt on the tmps stack; otherwise disarm
2638 * the tmps stack entry */
2639 if (hv_store_ent(hash, key, val, 0))
2640 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2641 else
2642 dirty_tmps = TRUE;
2643 /* hv_store_ent() may have added set magic to val */;
2644 SvSETMAGIC(val);
2645 }
2646 if (topelem < svp) {
1c4ea384
RZ
2647 /* at this point we have removed the duplicate key/value
2648 * pairs from the stack, but the remaining values may be
2649 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
2650 * the (a 2), but the stack now probably contains
2651 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
2652 * obliterates the earlier key. So refresh all values. */
8b0c3377
DM
2653 lastrelem = topelem - 1;
2654 while (relem < lastrelem) {
1c4ea384
RZ
2655 HE *he;
2656 he = hv_fetch_ent(hash, *relem++, 0, 0);
2657 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
2658 }
2659 }
8b0c3377
DM
2660 }
2661 else {
2662 SV **svp;
2663 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2664 SV *key = *svp++;
2665 SV *val = *svp;
2666 if (hv_store_ent(hash, key, val, 0))
2667 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2668 else
2669 dirty_tmps = TRUE;
2670 /* hv_store_ent() may have added set magic to val */;
2671 SvSETMAGIC(val);
2672 }
2673 }
2674
2675 if (dirty_tmps) {
2676 /* there are still some 'live' recounts on the tmps stack
2677 * - usually caused by storing into a tied hash. So let
2678 * free_tmps() do the proper but slow job later.
2679 * Just disarm hash refcount: see comments below about leak
2680 */
2681 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2682 }
2683 else {
2684 /* Quietly remove all the SVs from the tmps stack slots,
2685 * since hash has now taken ownership of the refcnt.
2686 * Also remove hash: which will now leak if we die before
2687 * the SvREFCNT_dec_NN(hash) below */
2688 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2689 Move(&PL_tmps_stack[tmps_base + nelems],
2690 &PL_tmps_stack[tmps_base - 1],
2691 PL_tmps_ix - (tmps_base + nelems) + 1,
2692 SV*);
2693 PL_tmps_ix -= (nelems + 1);
2694 }
2695
2696 SvREFCNT_dec_NN(hash);
2697
2698 relem = lastrelem + 1;
2699 goto no_relems;
2700 }
2701
a0d0e21e 2702 default:
8b0c3377 2703 if (!SvIMMORTAL(lsv)) {
d24e3eb1
DM
2704 SV *ref;
2705
8b0c3377
DM
2706 if (UNLIKELY(
2707 SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
2708 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
2709 ))
2710 Perl_warner(aTHX_
2711 packWARN(WARN_MISC),
2712 "Useless assignment to a temporary"
2713 );
d24e3eb1
DM
2714
2715 /* avoid freeing $$lsv if it might be needed for further
2716 * elements, e.g. ($ref, $foo) = (1, $$ref) */
2717 if ( SvROK(lsv)
2718 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
2719 && lelem <= lastlelem
2720 ) {
2721 SSize_t ix;
2722 SvREFCNT_inc_simple_void_NN(ref);
2723 /* an unrolled sv_2mortal */
2724 ix = ++PL_tmps_ix;
2725 if (UNLIKELY(ix >= PL_tmps_max))
2726 /* speculatively grow enough to cover other
2727 * possible refs */
67c3640a 2728 (void)tmps_grow_p(ix + (lastlelem - lelem));
d24e3eb1
DM
2729 PL_tmps_stack[ix] = ref;
2730 }
2731
8b0c3377
DM
2732 sv_setsv(lsv, *relem);
2733 *relem = lsv;
2734 SvSETMAGIC(lsv);
2735 }
2736 if (++relem > lastrelem)
2737 goto no_relems;
a0d0e21e 2738 break;
8b0c3377
DM
2739 } /* switch */
2740 } /* while */
2741
2742
2743 no_relems:
2744
2745 /* simplified lelem loop for when there are no relems left */
2746 while (LIKELY(lelem <= lastlelem)) {
2747 SV *lsv = *lelem++;
c73f612f
DM
2748
2749 TAINT_NOT; /* Each item stands on its own, taintwise. */
2750
8b0c3377
DM
2751 if (UNLIKELY(!lsv)) {
2752 lsv = *lelem++;
2753 ASSUME(SvTYPE(lsv) == SVt_PVAV);
a0d0e21e 2754 }
8b0c3377
DM
2755
2756 switch (SvTYPE(lsv)) {
2757 case SVt_PVAV:
b09ed995
DM
2758 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
2759 av_clear((AV*)lsv);
8b0c3377 2760 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
b09ed995 2761 SvSETMAGIC(lsv);
8b0c3377
DM
2762 }
2763 break;
2764
2765 case SVt_PVHV:
b09ed995
DM
2766 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
2767 hv_clear((HV*)lsv);
8b0c3377
DM
2768 break;
2769
2770 default:
2771 if (!SvIMMORTAL(lsv)) {
e03e82a0 2772 sv_set_undef(lsv);
8b0c3377 2773 SvSETMAGIC(lsv);
b09ed995 2774 *relem++ = lsv;
8b0c3377
DM
2775 }
2776 break;
2777 } /* switch */
2778 } /* while */
2779
c73f612f
DM
2780 TAINT_NOT; /* result of list assign isn't tainted */
2781
5d9574c1 2782 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
985213f2 2783 /* Will be used to set PL_tainting below */
dfff4baf
BF
2784 Uid_t tmp_uid = PerlProc_getuid();
2785 Uid_t tmp_euid = PerlProc_geteuid();
2786 Gid_t tmp_gid = PerlProc_getgid();
2787 Gid_t tmp_egid = PerlProc_getegid();
985213f2 2788
b469f1e0 2789 /* XXX $> et al currently silently ignore failures */
3280af22 2790 if (PL_delaymagic & DM_UID) {
a0d0e21e 2791#ifdef HAS_SETRESUID
b469f1e0
JH
2792 PERL_UNUSED_RESULT(
2793 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2794 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
2795 (Uid_t)-1));
d1a21e44 2796#elif defined(HAS_SETREUID)
b469f1e0
JH
2797 PERL_UNUSED_RESULT(
2798 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2799 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
d1a21e44 2800#else
56febc5e 2801# ifdef HAS_SETRUID
b28d0864 2802 if ((PL_delaymagic & DM_UID) == DM_RUID) {
b469f1e0 2803 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
b28d0864 2804 PL_delaymagic &= ~DM_RUID;
a0d0e21e 2805 }
56febc5e
AD
2806# endif /* HAS_SETRUID */
2807# ifdef HAS_SETEUID
b28d0864 2808 if ((PL_delaymagic & DM_UID) == DM_EUID) {
b469f1e0 2809 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
b28d0864 2810 PL_delaymagic &= ~DM_EUID;
a0d0e21e 2811 }
56febc5e 2812# endif /* HAS_SETEUID */
b28d0864 2813 if (PL_delaymagic & DM_UID) {
985213f2 2814 if (PL_delaymagic_uid != PL_delaymagic_euid)
cea2e8a9 2815 DIE(aTHX_ "No setreuid available");
b469f1e0 2816 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
a0d0e21e 2817 }
56febc5e 2818#endif /* HAS_SETRESUID */
04783dc7 2819
985213f2
AB
2820 tmp_uid = PerlProc_getuid();
2821 tmp_euid = PerlProc_geteuid();
a0d0e21e 2822 }
b469f1e0 2823 /* XXX $> et al currently silently ignore failures */
3280af22 2824 if (PL_delaymagic & DM_GID) {
a0d0e21e 2825#ifdef HAS_SETRESGID
b469f1e0
JH
2826 PERL_UNUSED_RESULT(
2827 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2828 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
2829 (Gid_t)-1));
d1a21e44 2830#elif defined(HAS_SETREGID)
b469f1e0
JH
2831 PERL_UNUSED_RESULT(
2832 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2833 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
d1a21e44 2834#else
56febc5e 2835# ifdef HAS_SETRGID
b28d0864 2836 if ((PL_delaymagic & DM_GID) == DM_RGID) {
b469f1e0 2837 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
b28d0864 2838 PL_delaymagic &= ~DM_RGID;
a0d0e21e 2839 }
56febc5e
AD
2840# endif /* HAS_SETRGID */
2841# ifdef HAS_SETEGID
b28d0864 2842 if ((PL_delaymagic & DM_GID) == DM_EGID) {
b469f1e0 2843 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
b28d0864 2844 PL_delaymagic &= ~DM_EGID;
a0d0e21e 2845 }
56febc5e 2846# endif /* HAS_SETEGID */
b28d0864 2847 if (PL_delaymagic & DM_GID) {
985213f2 2848 if (PL_delaymagic_gid != PL_delaymagic_egid)
cea2e8a9 2849 DIE(aTHX_ "No setregid available");
b469f1e0 2850 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
a0d0e21e 2851 }
56febc5e 2852#endif /* HAS_SETRESGID */
04783dc7 2853
985213f2
AB
2854 tmp_gid = PerlProc_getgid();
2855 tmp_egid = PerlProc_getegid();
a0d0e21e 2856 }
284167a5 2857 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
9a9b5ec9
DM
2858#ifdef NO_TAINT_SUPPORT
2859 PERL_UNUSED_VAR(tmp_uid);
2860 PERL_UNUSED_VAR(tmp_euid);
2861 PERL_UNUSED_VAR(tmp_gid);
2862 PERL_UNUSED_VAR(tmp_egid);
2863#endif
a0d0e21e 2864 }
a68090fe 2865 PL_delaymagic = old_delaymagic;
54310121 2866
54310121
PP
2867 if (gimme == G_VOID)
2868 SP = firstrelem - 1;
2869 else if (gimme == G_SCALAR) {
54310121 2870 SP = firstrelem;
b09ed995 2871 EXTEND(SP,1);
7b394f12
DM
2872 if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
2873 SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
2874 else {
2875 dTARGET;
2876 SETi(firstlelem - firstrelem);
2877 }
54310121 2878 }
b09ed995
DM
2879 else
2880 SP = relem - 1;
08aeb9f7 2881
54310121 2882 RETURN;
a0d0e21e
LW
2883}
2884
8782bef2
GB
2885PP(pp_qr)
2886{
20b7effb 2887 dSP;
eb578fdb 2888 PMOP * const pm = cPMOP;
fe578d7f 2889 REGEXP * rx = PM_GETRE(pm);
196a02af
DM
2890 regexp *prog = ReANY(rx);
2891 SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
c4420975 2892 SV * const rv = sv_newmortal();
d63c20f2
DM
2893 CV **cvp;
2894 CV *cv;
288b8c02
NC
2895
2896 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
2897 /* For a subroutine describing itself as "This is a hacky workaround" I'm
2898 loathe to use it here, but it seems to be the right fix. Or close.
2899 The key part appears to be that it's essential for pp_qr to return a new
2900 object (SV), which implies that there needs to be an effective way to
2901 generate a new SV from the existing SV that is pre-compiled in the
2902 optree. */
2903 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
2904 SvROK_on(rv);
2905
8d919b0a 2906 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
5d9574c1 2907 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
d63c20f2 2908 *cvp = cv_clone(cv);
fc2b2dca 2909 SvREFCNT_dec_NN(cv);
d63c20f2
DM
2910 }
2911
288b8c02 2912 if (pkg) {
f815daf2 2913 HV *const stash = gv_stashsv(pkg, GV_ADD);
fc2b2dca 2914 SvREFCNT_dec_NN(pkg);
288b8c02
NC
2915 (void)sv_bless(rv, stash);
2916 }
2917
196a02af 2918 if (UNLIKELY(RXp_ISTAINTED(prog))) {
e08e52cf 2919 SvTAINTED_on(rv);
9274aefd
DM
2920 SvTAINTED_on(SvRV(rv));
2921 }
c8c13c22 2922 XPUSHs(rv);
2923 RETURN;
8782bef2
GB
2924}
2925
a0d0e21e
LW
2926PP(pp_match)
2927{
20b7effb 2928 dSP; dTARG;
eb578fdb 2929 PMOP *pm = cPMOP;
d65afb4b 2930 PMOP *dynpm = pm;
eb578fdb 2931 const char *s;
5c144d81 2932 const char *strend;
99a90e59 2933 SSize_t curpos = 0; /* initial pos() or current $+[0] */
a0d0e21e 2934 I32 global;
7fadf4a7 2935 U8 r_flags = 0;
5c144d81 2936 const char *truebase; /* Start of string */
eb578fdb 2937 REGEXP *rx = PM_GETRE(pm);
196a02af 2938 regexp *prog = ReANY(rx);
b3eb6a9b 2939 bool rxtainted;
1c23e2bd 2940 const U8 gimme = GIMME_V;
a0d0e21e 2941 STRLEN len;
a3b680e6 2942 const I32 oldsave = PL_savestack_ix;
e60df1fa 2943 I32 had_zerolen = 0;
b1422d62 2944 MAGIC *mg = NULL;
a0d0e21e 2945
533c011a 2946 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
2947 TARG = POPs;
2948 else {
9399c607
DM
2949 if (ARGTARG)
2950 GETTARGET;
2951 else {
2952 TARG = DEFSV;
2953 }
a0d0e21e
LW
2954 EXTEND(SP,1);
2955 }
d9f424b2 2956
c277df42 2957 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
2958 /* Skip get-magic if this is a qr// clone, because regcomp has
2959 already done it. */
196a02af 2960 truebase = prog->mother_re
69dc4b30
FC
2961 ? SvPV_nomg_const(TARG, len)
2962 : SvPV_const(TARG, len);
f1d31338 2963 if (!truebase)
2269b42e 2964 DIE(aTHX_ "panic: pp_match");
f1d31338 2965 strend = truebase + len;
196a02af 2966 rxtainted = (RXp_ISTAINTED(prog) ||
284167a5 2967 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 2968 TAINT_NOT;
a0d0e21e 2969
6c864ec2 2970 /* We need to know this in case we fail out early - pos() must be reset */
de0df3c0
MH
2971 global = dynpm->op_pmflags & PMf_GLOBAL;
2972
d65afb4b 2973 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
2974 if (
2975#ifdef USE_ITHREADS
2976 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
2977#else
2978 pm->op_pmflags & PMf_USED
2979#endif
2980 ) {
e5dc5375 2981 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
de0df3c0 2982 goto nope;
a0d0e21e
LW
2983 }
2984
5585e758 2985 /* handle the empty pattern */
196a02af 2986 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
5585e758
YO
2987 if (PL_curpm == PL_reg_curpm) {
2988 if (PL_curpm_under) {
2989 if (PL_curpm_under == PL_reg_curpm) {
2990 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
2991 } else {
2992 pm = PL_curpm_under;
2993 }
2994 }
2995 } else {
2996 pm = PL_curpm;
2997 }
2998 rx = PM_GETRE(pm);
196a02af 2999 prog = ReANY(rx);
a0d0e21e 3000 }
d65afb4b 3001
196a02af 3002 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
75d43e96 3003 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
147e3846 3004 UVuf " < %" IVdf ")\n",
196a02af 3005 (UV)len, (IV)RXp_MINLEN(prog)));
de0df3c0 3006 goto nope;
e5dc5375 3007 }
c277df42 3008
8ef97b0e 3009 /* get pos() if //g */
de0df3c0 3010 if (global) {
b1422d62 3011 mg = mg_find_mglob(TARG);
8ef97b0e 3012 if (mg && mg->mg_len >= 0) {
25fdce4a 3013 curpos = MgBYTEPOS(mg, TARG, truebase, len);
8ef97b0e
DM
3014 /* last time pos() was set, it was zero-length match */
3015 if (mg->mg_flags & MGf_MINMATCH)
3016 had_zerolen = 1;
3017 }
a0d0e21e 3018 }
8ef97b0e 3019
6e240d0b 3020#ifdef PERL_SAWAMPERSAND
196a02af 3021 if ( RXp_NPARENS(prog)
6502e081 3022 || PL_sawampersand
196a02af 3023 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 3024 || (dynpm->op_pmflags & PMf_KEEPCOPY)
6e240d0b
FC
3025 )
3026#endif
3027 {
6502e081
DM
3028 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
3029 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
3030 * only on the first iteration. Therefore we need to copy $' as well
3031 * as $&, to make the rest of the string available for captures in
3032 * subsequent iterations */
3033 if (! (global && gimme == G_ARRAY))
3034 r_flags |= REXEC_COPY_SKIP_POST;
3035 };
5b0e71e9
DM
3036#ifdef PERL_SAWAMPERSAND
3037 if (dynpm->op_pmflags & PMf_KEEPCOPY)
3038 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3039 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3040#endif
22e551b9 3041
f1d31338
DM
3042 s = truebase;
3043
d7be1480 3044 play_it_again:
985afbc1 3045 if (global)
03c83e26 3046 s = truebase + curpos;
f722798b 3047
77da2310 3048 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
03c83e26 3049 had_zerolen, TARG, NULL, r_flags))
03b6c93d 3050 goto nope;
77da2310
NC
3051
3052 PL_curpm = pm;
985afbc1 3053 if (dynpm->op_pmflags & PMf_ONCE)
c737faaf 3054#ifdef USE_ITHREADS
77da2310 3055 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 3056#else
77da2310 3057 dynpm->op_pmflags |= PMf_USED;
c737faaf 3058#endif
a0d0e21e 3059
72311751 3060 if (rxtainted)
196a02af
DM
3061 RXp_MATCH_TAINTED_on(prog);
3062 TAINT_IF(RXp_MATCH_TAINTED(prog));
35c2ccc3
DM
3063
3064 /* update pos */
3065
3066 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
b1422d62 3067 if (!mg)
35c2ccc3 3068 mg = sv_magicext_mglob(TARG);
196a02af
DM
3069 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
3070 if (RXp_ZERO_LEN(prog))
adf51885
DM
3071 mg->mg_flags |= MGf_MINMATCH;
3072 else
3073 mg->mg_flags &= ~MGf_MINMATCH;
35c2ccc3
DM
3074 }
3075
196a02af 3076 if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
bf9dff51
DM
3077 LEAVE_SCOPE(oldsave);
3078 RETPUSHYES;
3079 }
3080
88ab22af
DM
3081 /* push captures on stack */
3082
bf9dff51 3083 {
196a02af 3084 const I32 nparens = RXp_NPARENS(prog);
a3b680e6 3085 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 3086
c277df42 3087 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
3088 EXTEND(SP, nparens + i);
3089 EXTEND_MORTAL(nparens + i);
3090 for (i = !i; i <= nparens; i++) {
a0d0e21e 3091 PUSHs(sv_newmortal());
196a02af
DM
3092 if (LIKELY((RXp_OFFS(prog)[i].start != -1)
3093 && RXp_OFFS(prog)[i].end != -1 ))
5d9574c1 3094 {
196a02af
DM
3095 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
3096 const char * const s = RXp_OFFS(prog)[i].start + truebase;
3097 if (UNLIKELY( RXp_OFFS(prog)[i].end < 0
3098 || RXp_OFFS(prog)[i].start < 0
3099 || len < 0
3100 || len > strend - s)
3101 )
5637ef5b 3102 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
147e3846 3103 "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
196a02af
DM
3104 (long) i, (long) RXp_OFFS(prog)[i].start,
3105 (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
a0d0e21e 3106 sv_setpvn(*SP, s, len);
cce850e4 3107 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 3108 SvUTF8_on(*SP);
a0d0e21e
LW
3109 }
3110 }
3111 if (global) {
196a02af
DM
3112 curpos = (UV)RXp_OFFS(prog)[0].end;
3113 had_zerolen = RXp_ZERO_LEN(prog);
c277df42 3114 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 3115 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
3116 goto play_it_again;
3117 }
4633a7c4 3118 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
3119 RETURN;
3120 }
e5964223 3121 NOT_REACHED; /* NOTREACHED */
a0d0e21e 3122
7b52d656 3123 nope:
d65afb4b 3124 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
b1422d62
DM
3125 if (!mg)
3126 mg = mg_find_mglob(TARG);
3127 if (mg)
3128 mg->mg_len = -1;
a0d0e21e 3129 }
4633a7c4 3130 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
3131 if (gimme == G_ARRAY)
3132 RETURN;
3133 RETPUSHNO;
3134}
3135
3136OP *
864dbfa3 3137Perl_do_readline(pTHX)
a0d0e21e 3138{
20b7effb 3139 dSP; dTARGETSTACKED;
eb578fdb 3140 SV *sv;
a0d0e21e
LW
3141 STRLEN tmplen = 0;
3142 STRLEN offset;
760ac839 3143 PerlIO *fp;
eb578fdb
KW
3144 IO * const io = GvIO(PL_last_in_gv);
3145 const I32 type = PL_op->op_type;
1c23e2bd 3146 const U8 gimme = GIMME_V;
a0d0e21e 3147
6136c704 3148 if (io) {
50db69d8 3149 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 3150 if (mg) {
3e0cb5de 3151 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 3152 if (gimme == G_SCALAR) {
50db69d8
NC
3153 SPAGAIN;
3154 SvSetSV_nosteal(TARG, TOPs);
3155 SETTARG;
6136c704 3156 }
50db69d8 3157 return NORMAL;
0b7c7b4f 3158 }
e79b0511 3159 }
4608196e 3160 fp = NULL;
a0d0e21e
LW
3161 if (io) {
3162 fp = IoIFP(io);
3163 if (!fp) {
3164 if (IoFLAGS(io) & IOf_ARGV) {
3165 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 3166 IoLINES(io) = 0;
b9f2b683 3167 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 3168 IoFLAGS(io) &= ~IOf_START;
d5eb9a46 3169 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
4bac9ae4 3170 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
76f68e9b 3171 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3280af22 3172 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
3173 fp = IoIFP(io);
3174 goto have_fp;
a0d0e21e
LW
3175 }
3176 }
157fb5a1 3177 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e 3178 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 3179 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
3180 }
3181 }
0d44d22b
NC
3182 else if (type == OP_GLOB)
3183 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
3184 }
3185 else if (type == OP_GLOB)
3186 SP--;
7716c5c5 3187 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 3188 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 3189 }
a0d0e21e
LW
3190 }
3191 if (!fp) {
041457d9 3192 if ((!io || !(IoFLAGS(io) & IOf_START))
de7dabb6
TC
3193 && ckWARN(WARN_CLOSED)
3194 && type != OP_GLOB)
041457d9 3195 {
de7dabb6 3196 report_evil_fh(PL_last_in_gv);
3f4520fe 3197 }
54310121 3198 if (gimme == G_SCALAR) {
79628082 3199 /* undef TARG, and push that undefined value */
ba92458f 3200 if (type != OP_RCATLINE) {
3773545d 3201 sv_set_undef(TARG);
ba92458f 3202 }
a0d0e21e
LW
3203 PUSHTARG;
3204 }
3205 RETURN;
3206 }
a2008d6d 3207 have_fp:
54310121 3208 if (gimme == G_SCALAR) {
a0d0e21e 3209 sv = TARG;
0f722b55
RGS
3210 if (type == OP_RCATLINE && SvGMAGICAL(sv))
3211 mg_get(sv);
48de12d9
RGS
3212 if (SvROK(sv)) {
3213 if (type == OP_RCATLINE)
5668452f 3214 SvPV_force_nomg_nolen(sv);
48de12d9
RGS
3215 else
3216 sv_unref(sv);
3217 }
f7877b28 3218 else if (isGV_with_GP(sv)) {
5668452f 3219 SvPV_force_nomg_nolen(sv);
f7877b28 3220 }
862a34c6 3221 SvUPGRADE(sv, SVt_PV);
a0d0e21e 3222 tmplen = SvLEN(sv); /* remember if already alloced */
e3918bb7 3223 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
f72e8700
JJ
3224 /* try short-buffering it. Please update t/op/readline.t
3225 * if you change the growth length.
3226 */
3227 Sv_Grow(sv, 80);
3228 }
2b5e58c4
AMS
3229 offset = 0;
3230 if (type == OP_RCATLINE && SvOK(sv)) {
3231 if (!SvPOK(sv)) {
5668452f 3232 SvPV_force_nomg_nolen(sv);
2b5e58c4 3233 }
a0d0e21e 3234 offset = SvCUR(sv);
2b5e58c4 3235 }
a0d0e21e 3236 }
54310121 3237 else {
561b68a9 3238 sv = sv_2mortal(newSV(80));
54310121
PP
3239 offset = 0;
3240 }
fbad3eb5 3241
3887d568
AP
3242 /* This should not be marked tainted if the fp is marked clean */
3243#define MAYBE_TAINT_LINE(io, sv) \
3244 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
3245 TAINT; \
3246 SvTAINTED_on(sv); \
3247 }
3248
684bef36 3249/* delay EOF state for a snarfed empty file */
fbad3eb5 3250#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 3251 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 3252 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 3253
a0d0e21e 3254 for (;;) {
09e8efcc 3255 PUTBACK;
fbad3eb5 3256 if (!sv_gets(sv, fp, offset)
2d726892
TF
3257 && (type == OP_GLOB
3258 || SNARF_EOF(gimme, PL_rs, io, sv)
3259 || PerlIO_error(fp)))
fbad3eb5 3260 {
760ac839 3261 PerlIO_clearerr(fp);
a0d0e21e 3262 if (IoFLAGS(io) & IOf_ARGV) {
157fb5a1 3263 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e
LW
3264 if (fp)
3265 continue;
3280af22 3266 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
3267 }
3268 else if (type == OP_GLOB) {
a2a5de95
NC
3269 if (!do_close(PL_last_in_gv, FALSE)) {
3270 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
3271 "glob failed (child exited with status %d%s)",
3272 (int)(STATUS_CURRENT >> 8),
3273 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 3274 }
a0d0e21e 3275 }
54310121 3276 if (gimme == G_SCALAR) {
ba92458f
AE
3277 if (type != OP_RCATLINE) {
3278 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 3279 SvOK_off(TARG);
ba92458f 3280 }
09e8efcc 3281 SPAGAIN;
a0d0e21e
LW
3282 PUSHTARG;
3283 }
3887d568 3284 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
3285 RETURN;
3286 }
3887d568 3287 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 3288 IoLINES(io)++;
b9fee9ba 3289 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 3290 SvSETMAGIC(sv);
09e8efcc 3291 SPAGAIN;
a0d0e21e 3292 XPUSHs(sv);
a0d0e21e 3293 if (type == OP_GLOB) {
349d4f2f 3294 const char *t1;
45a23732 3295 Stat_t statbuf;
a0d0e21e 3296
3280af22 3297 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 3298 char * const tmps = SvEND(sv) - 1;
aa07b2f6 3299 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 3300 *tmps = '\0';
b162af07 3301 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
3302 }
3303 }
349d4f2f 3304 for (t1 = SvPVX_const(sv); *t1; t1++)
b51c3e77
CB
3305#ifdef __VMS
3306 if (strchr("*%?", *t1))
3307#else
7ad1e72d 3308 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
b51c3e77 3309#endif
a0d0e21e 3310 break;
45a23732 3311 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
a0d0e21e
LW
3312 (void)POPs; /* Unmatched wildcard? Chuck it... */
3313 continue;
3314 }
2d79bf7f 3315 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
3316 if (ckWARN(WARN_UTF8)) {
3317 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
3318 const STRLEN len = SvCUR(sv) - offset;
3319 const U8 *f;
3320
3321 if (!is_utf8_string_loc(s, len, &f))
3322 /* Emulate :encoding(utf8) warning in the same case. */
3323 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3324 "utf8 \"\\x%02X\" does not map to Unicode",
3325 f < (U8*)SvEND(sv) ? *f : 0);
3326 }
a0d0e21e 3327 }
54310121 3328 if (gimme == G_ARRAY) {
a0d0e21e 3329 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 3330 SvPV_shrink_to_cur(sv);
a0d0e21e 3331 }
561b68a9 3332 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
3333 continue;
3334 }
54310121 3335 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 3336 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
3337 const STRLEN new_len
3338 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 3339 SvPV_renew(sv, new_len);
a0d0e21e
LW
3340 }
3341 RETURN;
3342 }
3343}
3344
a0d0e21e
LW
3345PP(pp_helem)
3346{
20b7effb 3347 dSP;
760ac839 3348 HE* he;
ae77835f 3349 SV **svp;
c445ea15 3350 SV * const keysv = POPs;
85fbaab2 3351 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
3352 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3353 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 3354 SV *sv;
92970b93 3355 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 3356 bool preeminent = TRUE;
a0d0e21e 3357
6dfc73ea
SM
3358 if (SvTYPE(hv) != SVt_PVHV)
3359 RETPUSHUNDEF;
d4c19fe8 3360
92970b93 3361 if (localizing) {
d4c19fe8
AL
3362 MAGIC *mg;
3363 HV *stash;
d30e492c
VP
3364
3365 /* If we can determine whether the element exist,
3366 * Try to preserve the existenceness of a tied hash
3367 * element by using EXISTS and DELETE if possible.
3368 * Fallback to FETCH and STORE otherwise. */
2c5f48c2 3369 if (SvCANEXISTDELETE(hv))
d30e492c 3370 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 3371 }
d30e492c 3372
5f9d7e2b 3373 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
d4c19fe8 3374 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 3375 if (lval) {
746f6409 3376 if (!svp || !*svp || *svp == &PL_sv_undef) {
68dc0745
PP
3377 SV* lv;
3378 SV* key2;
2d8e6c8d 3379 if (!defer) {
be2597df 3380 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 3381 }
68dc0745
PP
3382 lv = sv_newmortal();
3383 sv_upgrade(lv, SVt_PVLV);
3384 LvTYPE(lv) = 'y';
6136c704 3385 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
fc2b2dca 3386 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
0ad694a7 3387 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
68dc0745
PP
3388 LvTARGLEN(lv) = 1;
3389 PUSHs(lv);
3390 RETURN;
3391 }
92970b93 3392 if (localizing) {
6881372e 3393 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
159b6efe 3394 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
3395 else if (preeminent)
3396 save_helem_flags(hv, keysv, svp,
3397 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
3398 else
3399 SAVEHDELETE(hv, keysv);
5f05dabc 3400 }
9026059d
GG
3401 else if (PL_op->op_private & OPpDEREF) {
3402 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3403 RETURN;
3404 }
a0d0e21e 3405 }
746f6409 3406 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
3407 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
3408 * was to make C<local $tied{foo} = $tied{foo}> possible.
3409 * However, it seems no longer to be needed for that purpose, and
3410 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
3411 * would loop endlessly since the pos magic is getting set on the
3412 * mortal copy and lost. However, the copy has the effect of
3413 * triggering the get magic, and losing it altogether made things like
3414 * c<$tied{foo};> in void context no longer do get magic, which some
3415 * code relied on. Also, delayed triggering of magic on @+ and friends
3416 * meant the original regex may be out of scope by now. So as a
3417 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
3418 * being called too many times). */
39cf747a 3419 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 3420 mg_get(sv);
be6c24e0 3421 PUSHs(sv);
a0d0e21e
LW
3422 RETURN;
3423}
3424
fedf30e1
DM
3425
3426/* a stripped-down version of Perl_softref2xv() for use by
3427 * pp_multideref(), which doesn't use PL_op->op_flags */
3428
f9db5646 3429STATIC GV *
fedf30e1
DM
3430S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
3431 const svtype type)
3432{
3433 if (PL_op->op_private & HINT_STRICT_REFS) {
3434 if (SvOK(sv))
3435 Perl_die(aTHX_ PL_no_symref_sv, sv,
3436 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
3437 else
3438 Perl_die(aTHX_ PL_no_usym, what);
3439 }
3440 if (!SvOK(sv))
3441 Perl_die(aTHX_ PL_no_usym, what);
3442 return gv_fetchsv_nomg(sv, GV_ADD, type);
3443}
3444
3445
79815f56
DM
3446/* Handle one or more aggregate derefs and array/hash indexings, e.g.
3447 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
fedf30e1
DM
3448 *
3449 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
79815f56
DM
3450 * Each of these either contains a set of actions, or an argument, such as
3451 * an IV to use as an array index, or a lexical var to retrieve.
3452 * Several actions re stored per UV; we keep shifting new actions off the
3453 * one UV, and only reload when it becomes zero.
fedf30e1
DM
3454 */
3455
3456PP(pp_multideref)
3457{
3458 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
3459 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3460 UV actions = items->uv;
3461
3462 assert(actions);
3463 /* this tells find_uninit_var() where we're up to */
3464 PL_multideref_pc = items;
3465
3466 while (1) {
3467 /* there are three main classes of action; the first retrieve
3468 * the initial AV or HV from a variable or the stack; the second
3469 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
3470 * the third an unrolled (/DREFHV, rv2hv, helem).
3471 */
3472 switch (actions & MDEREF_ACTION_MASK) {
3473
3474 case MDEREF_reload:
3475 actions = (++items)->uv;
3476 continue;
3477
3478 case MDEREF_AV_padav_aelem: /* $lex[...] */
3479 sv = PAD_SVl((++items)->pad_offset);
3480 goto do_AV_aelem;
3481
3482 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
3483 sv = UNOP_AUX_item_sv(++items);
3484 assert(isGV_with_GP(sv));
3485 sv = (SV*)GvAVn((GV*)sv);
3486 goto do_AV_aelem;
3487
3488 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
3489 {
3490 dSP;
3491 sv = POPs;
3492 PUTBACK;
3493 goto do_AV_rv2av_aelem;
3494 }
3495
3496 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
3497 sv = UNOP_AUX_item_sv(++items);
3498 assert(isGV_with_GP(sv));
3499 sv = GvSVn((GV*)sv);
3500 goto do_AV_vivify_rv2av_aelem;
3501
3502 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
3503 sv = PAD_SVl((++items)->pad_offset);
3504 /* FALLTHROUGH */
3505
3506 do_AV_vivify_rv2av_aelem:
3507 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
3508 /* this is the OPpDEREF action normally found at the end of
3509 * ops like aelem, helem, rv2sv */
3510 sv = vivify_ref(sv, OPpDEREF_AV);
3511 /* FALLTHROUGH */
3512
3513 do_AV_rv2av_aelem:
3514 /* this is basically a copy of pp_rv2av when it just has the
3515 * sKR/1 flags */
3516 SvGETMAGIC(sv);
3517 if (LIKELY(SvROK(sv))) {
3518 if (UNLIKELY(SvAMAGIC(sv))) {
3519 sv = amagic_deref_call(sv, to_av_amg);
3520 }
3521 sv = SvRV(sv);
3522 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
3523 DIE(aTHX_ "Not an ARRAY reference");
3524 }
3525 else if (SvTYPE(sv) != SVt_PVAV) {
3526 if (!isGV_with_GP(sv))
3527 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
3528 sv = MUTABLE_SV(GvAVn((GV*)sv));
3529 }
3530 /* FALLTHROUGH */
3531
3532 do_AV_aelem:
3533 {
3534 /* retrieve the key; this may be either a lexical or package
3535 * var (whose index/ptr is stored as an item) or a signed
3536 * integer constant stored as an item.
3537 */
3538 SV *elemsv;
3539 IV elem = 0; /* to shut up stupid compiler warnings */
3540
3541
3542 assert(SvTYPE(sv) == SVt_PVAV);
3543
3544 switch (actions & MDEREF_INDEX_MASK) {
3545 case MDEREF_INDEX_none:
3546 goto finish;
3547 case MDEREF_INDEX_const:
3548 elem = (++items)->iv;
3549 break;
3550 case MDEREF_INDEX_padsv:
3551 elemsv = PAD_SVl((++items)->pad_offset);
3552 goto check_elem;
3553 case MDEREF_INDEX_gvsv:
3554 elemsv = UNOP_AUX_item_sv(++items);
3555 assert(isGV_with_GP(elemsv));
3556 elemsv = GvSVn((GV*)elemsv);
3557 check_elem:
3558 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
3559 && ckWARN(WARN_MISC)))
3560 Perl_warner(aTHX_ packWARN(WARN_MISC),
147e3846 3561 "Use of reference \"%" SVf "\" as array index",
fedf30e1
DM
3562 SVfARG(elemsv));
3563 /* the only time that S_find_uninit_var() needs this
3564 * is to determine which index value triggered the
3565 * undef warning. So just update it here. Note that
3566 * since we don't save and restore this var (e.g. for
3567 * tie or overload execution), its value will be
3568 * meaningless apart from just here */
3569 PL_multideref_pc = items;
3570 elem = SvIV(elemsv);
3571 break;
3572 }
3573
3574
3575 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
3576
3577 if (!(actions & MDEREF_FLAG_last)) {
3578 SV** svp = av_fetch((AV*)sv, elem, 1);
3579 if (!svp || ! (sv=*svp))
3580 DIE(aTHX_ PL_no_aelem, elem);
3581 break;
3582 }
3583
3584 if (PL_op->op_private &
3585 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3586 {
3587 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3588 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
3589 }
3590 else {
3591 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3592 sv = av_delete((AV*)sv, elem, discard);
3593 if (discard)
3594 return NORMAL;
3595 if (!sv)
3596 sv = &PL_sv_undef;
3597 }
3598 }
3599 else {
3600 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3601 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3602 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3603 bool preeminent = TRUE;
3604 AV *const av = (AV*)sv;
3605 SV** svp;
3606
3607 if (UNLIKELY(localizing)) {
3608 MAGIC *mg;
3609 HV *stash;
3610
3611 /* If we can determine whether the element exist,
3612 * Try to preserve the existenceness of a tied array
3613 * element by using EXISTS and DELETE if possible.
3614 * Fallback to FETCH and STORE otherwise. */
3615 if (SvCANEXISTDELETE(av))
3616 preeminent = av_exists(av, elem);
3617 }
3618
3619 svp = av_fetch(av, elem, lval && !defer);
3620
3621 if (lval) {
3622 if (!svp || !(sv = *svp)) {
3623 IV len;
3624 if (!defer)
3625 DIE(aTHX_ PL_no_aelem, elem);
3626 len = av_tindex(av);
3627 sv = sv_2mortal(newSVavdefelem(av,
3628 /* Resolve a negative index now, unless it points
3629 * before the beginning of the array, in which
3630 * case record it for error reporting in
3631 * magic_setdefelem. */
3632 elem < 0 && len + elem >= 0
3633 ? len + elem : elem, 1));
3634 }
3635 else {
3636 if (UNLIKELY(localizing)) {
3637 if (preeminent) {
3638 save_aelem(av, elem, svp);
3639 sv = *svp; /* may have changed */
3640 }
3641 else
3642 SAVEADELETE(av, elem);
3643 }
3644 }
3645 }
3646 else {
3647 sv = (svp ? *svp : &PL_sv_undef);
3648 /* see note in pp_helem() */
3649 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
3650 mg_get(sv);
3651 }
3652 }
3653
3654 }
3655 finish:
3656 {
3657 dSP;
3658 XPUSHs(sv);
3659 RETURN;
3660 }
3661 /* NOTREACHED */
3662
3663
3664
3665
3666 case MDEREF_HV_padhv_helem: /* $lex{...} */
3667 sv = PAD_SVl((++items)->pad_offset);
3668 goto do_HV_helem;
3669
3670 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
3671 sv = UNOP_AUX_item_sv(++items);
3672 assert(isGV_with_GP(sv));
3673 sv = (SV*)GvHVn((GV*)sv);
3674 goto do_HV_helem;
3675
3676 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
3677 {
3678 dSP;
3679 sv = POPs;
3680 PUTBACK;
3681 goto do_HV_rv2hv_helem;
3682 }
3683
3684 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
3685 sv = UNOP_AUX_item_sv(++items);
3686 assert(isGV_with_GP(sv));
3687 sv = GvSVn((GV*)sv);
3688 goto do_HV_vivify_rv2hv_helem;
3689
3690 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
3691 sv = PAD_SVl((++items)->pad_offset);
3692 /* FALLTHROUGH */
3693
3694 do_HV_vivify_rv2hv_helem:
3695 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
3696 /* this is the OPpDEREF action normally found at the end of
3697 * ops like aelem, helem, rv2sv */
3698 sv = vivify_ref(sv, OPpDEREF_HV);
3699 /* FALLTHROUGH */
3700
3701 do_HV_rv2hv_helem:
3702 /* this is basically a copy of pp_rv2hv when it just has the
3703 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
3704
3705 SvGETMAGIC(sv);
3706 if (LIKELY(SvROK(sv))) {
3707 if (UNLIKELY(SvAMAGIC(sv))) {
3708 sv = amagic_deref_call(sv, to_hv_amg);
3709 }
3710 sv = SvRV(sv);
3711 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
3712 DIE(aTHX_ "Not a HASH reference");
3713 }
3714 else if (SvTYPE(sv) != SVt_PVHV) {
3715 if (!isGV_with_GP(sv))
3716 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
3717 sv = MUTABLE_SV(GvHVn((GV*)sv));
3718 }
3719 /* FALLTHROUGH */
3720
3721 do_HV_helem:
3722 {
3723 /* retrieve the key; this may be either a lexical / package
3724 * var or a string constant, whose index/ptr is stored as an
3725 * item
3726 */
3727 SV *keysv = NULL; /* to shut up stupid compiler warnings */
3728
3729 assert(SvTYPE(sv) == SVt_PVHV);
3730
3731 switch (actions & MDEREF_INDEX_MASK) {
3732 case MDEREF_INDEX_none:
3733 goto finish;
3734
3735 case MDEREF_INDEX_const:
3736 keysv = UNOP_AUX_item_sv(++items);
3737 break;
3738
3739 case MDEREF_INDEX_padsv:
3740 keysv = PAD_SVl((++items)->pad_offset);
3741 break;
3742
3743 case MDEREF_INDEX_gvsv:
3744 keysv = UNOP_AUX_item_sv(++items);
3745 keysv = GvSVn((GV*)keysv);
3746 break;
3747 }
3748
3749 /* see comment above about setting this var */
3750 PL_multideref_pc = items;
3751
3752
3753 /* ensure that candidate CONSTs have been HEKified */
3754 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
3755 || SvTYPE(keysv) >= SVt_PVMG
3756 || !SvOK(keysv)
3757 || SvROK(keysv)
3758 || SvIsCOW_shared_hash(keysv));
3759
3760 /* this is basically a copy of pp_helem with OPpDEREF skipped */
3761
3762 if (!(actions & MDEREF_FLAG_last)) {
3763 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
3764 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
3765 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3766 break;
3767 }
3768
3769 if (PL_op->op_private &
3770 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3771 {
3772 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3773 sv = hv_exists_ent((HV*)sv, keysv, 0)
3774 ? &PL_sv_yes : &PL_sv_no;
3775 }
3776 else {
3777 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3778 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
3779 if (discard)
3780 return NORMAL;
3781 if (!sv)
3782 sv = &PL_sv_undef;
3783 }
3784 }
3785 else {
3786 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3787 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3788 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3789 bool preeminent = TRUE;
3790 SV **svp;
3791 HV * const hv = (HV*)sv;
3792 HE* he;
3793
3794 if (UNLIKELY(localizing)) {
3795 MAGIC *mg;
3796 HV *stash;
3797
3798 /* If we can determine whether the element exist,
3799 * Try to preserve the existenceness of a tied hash
3800 * element by using EXISTS and DELETE if possible.
3801 * Fallback to FETCH and STORE otherwise. */
3802 if (SvCANEXISTDELETE(hv))
3803 preeminent = hv_exists_ent(hv, keysv, 0);
3804 }
3805
3806 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3807 svp = he ? &HeVAL(he) : NULL;
3808
3809
3810 if (lval) {
3811 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
3812 SV* lv;
3813 SV* key2;
3814 if (!defer)
3815 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3816 lv = sv_newmortal();
3817 sv_upgrade(lv, SVt_PVLV);
3818 LvTYPE(lv) = 'y';
3819 sv_magic(lv, key2 = newSVsv(keysv),
3820 PERL_MAGIC_defelem, NULL, 0);
3821 /* sv_magic() increments refcount */
3822 SvREFCNT_dec_NN(key2);
0ad694a7 3823 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
fedf30e1
DM
3824 LvTARGLEN(lv) = 1;
3825 sv = lv;
3826 }
3827 else {
3828 if (localizing) {
a35c9018 3829 if (HvNAME_get(hv) && isGV_or_RVCV(sv))
fedf30e1
DM
3830 save_gp(MUTABLE_GV(sv),
3831 !(PL_op->op_flags & OPf_SPECIAL));
3832 else if (preeminent) {
3833 save_helem_flags(hv, keysv, svp,
3834 (PL_op->op_flags & OPf_SPECIAL)
3835 ? 0 : SAVEf_SETMAGIC);
3836 sv = *svp; /* may have changed */
3837 }
3838 else
3839 SAVEHDELETE(hv, keysv);
3840 }
3841 }
3842 }
3843 else {
3844 sv = (svp && *svp ? *svp : &PL_sv_undef);
3845 /* see note in pp_helem() */
3846 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
3847 mg_get(sv);
3848 }
3849 }
3850 goto finish;
3851 }
3852
3853 } /* switch */
3854
3855