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