This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Create fcn for lossless conversion of NV to IV
[perl5.git] / pp_hot.c
CommitLineData
a0d0e21e
LW
1/* pp_hot.c
2 *
1129b882
NC
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
a0d0e21e
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
13 * shaking the air.
14 *
4ac71550
TC
15 * Awake! Awake! Fear, Fire, Foes! Awake!
16 * Fire, Foes! Awake!
17 *
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
a0d0e21e
LW
19 */
20
166f8a29
DM
21/* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
26 *
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
31 * performance.
32 */
33
a0d0e21e 34#include "EXTERN.h"
864dbfa3 35#define PERL_IN_PP_HOT_C
a0d0e21e
LW
36#include "perl.h"
37
38/* Hot code. */
39
40PP(pp_const)
41{
39644a26 42 dSP;
996c9baa 43 XPUSHs(cSVOP_sv);
a0d0e21e
LW
44 RETURN;
45}
46
47PP(pp_nextstate)
48{
533c011a 49 PL_curcop = (COP*)PL_op;
a0d0e21e 50 TAINT_NOT; /* Each statement is presumed innocent */
4ebe6e95 51 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
a0d0e21e 52 FREETMPS;
f410a211 53 PERL_ASYNC_CHECK();
a0d0e21e
LW
54 return NORMAL;
55}
56
57PP(pp_gvsv)
58{
39644a26 59 dSP;
924508f0 60 EXTEND(SP,1);
5d9574c1 61 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
1d7c1841 62 PUSHs(save_scalar(cGVOP_gv));
a0d0e21e 63 else
c69033f2 64 PUSHs(GvSVn(cGVOP_gv));
a0d0e21e
LW
65 RETURN;
66}
67
b1c05ba5
DM
68
69/* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
70
a0d0e21e
LW
71PP(pp_null)
72{
73 return NORMAL;
74}
75
3dd9d4e4
FC
76/* This is sometimes called directly by pp_coreargs, pp_grepstart and
77 amagic_call. */
a0d0e21e
LW
78PP(pp_pushmark)
79{
3280af22 80 PUSHMARK(PL_stack_sp);
a0d0e21e
LW
81 return NORMAL;
82}
83
84PP(pp_stringify)
85{
20b7effb 86 dSP; dTARGET;
4cc783ef
DD
87 SV * const sv = TOPs;
88 SETs(TARG);
89 sv_copypv(TARG, sv);
90 SvSETMAGIC(TARG);
91 /* no PUTBACK, SETs doesn't inc/dec SP */
92 return NORMAL;
a0d0e21e
LW
93}
94
95PP(pp_gv)
96{
20b7effb 97 dSP;
ad64d0ec 98 XPUSHs(MUTABLE_SV(cGVOP_gv));
a0d0e21e
LW
99 RETURN;
100}
101
b1c05ba5
DM
102
103/* also used for: pp_andassign() */
104
a0d0e21e
LW
105PP(pp_and)
106{
f410a211 107 PERL_ASYNC_CHECK();
4cc783ef
DD
108 {
109 /* SP is not used to remove a variable that is saved across the
110 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
111 register or load/store vs direct mem ops macro is introduced, this
112 should be a define block between direct PL_stack_sp and dSP operations,
113 presently, using PL_stack_sp is bias towards CISC cpus */
114 SV * const sv = *PL_stack_sp;
115 if (!SvTRUE_NN(sv))
116 return NORMAL;
117 else {
118 if (PL_op->op_type == OP_AND)
119 --PL_stack_sp;
120 return cLOGOP->op_other;
121 }
a0d0e21e
LW
122 }
123}
124
125PP(pp_sassign)
126{
20b7effb 127 dSP;
3e75a3c4
RU
128 /* sassign keeps its args in the optree traditionally backwards.
129 So we pop them differently.
130 */
131 SV *left = POPs; SV *right = TOPs;
748a9306 132
354eabfa 133 if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
0bd48802
AL
134 SV * const temp = left;
135 left = right; right = temp;
a0d0e21e 136 }
d48c660d
DM
137 assert(TAINTING_get || !TAINT_get);
138 if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
a0d0e21e 139 TAINT_NOT;
5d9574c1
DM
140 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
141 /* *foo =\&bar */
3e75a3c4 142 SV * const cv = SvRV(right);
e26df76a 143 const U32 cv_type = SvTYPE(cv);
3e75a3c4 144 const bool is_gv = isGV_with_GP(left);
6136c704 145 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
e26df76a
NC
146
147 if (!got_coderef) {
148 assert(SvROK(cv));
149 }
150
3e75a3c4
RU
151 /* Can do the optimisation if left (LVALUE) is not a typeglob,
152 right (RVALUE) is a reference to something, and we're in void
e26df76a 153 context. */
13be902c 154 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
e26df76a 155 /* Is the target symbol table currently empty? */
3e75a3c4 156 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
bb112e5a 157 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
e26df76a
NC
158 /* Good. Create a new proxy constant subroutine in the target.
159 The gv becomes a(nother) reference to the constant. */
160 SV *const value = SvRV(cv);
161
ad64d0ec 162 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
1ccdb730 163 SvPCS_IMPORTED_on(gv);
e26df76a 164 SvRV_set(gv, value);
b37c2d43 165 SvREFCNT_inc_simple_void(value);
3e75a3c4 166 SETs(left);
e26df76a
NC
167 RETURN;
168 }
169 }
170
171 /* Need to fix things up. */
13be902c 172 if (!is_gv) {
e26df76a 173 /* Need to fix GV. */
3e75a3c4 174 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
e26df76a
NC
175 }
176
177 if (!got_coderef) {
178 /* We've been returned a constant rather than a full subroutine,
179 but they expect a subroutine reference to apply. */
53a42478 180 if (SvROK(cv)) {
d343c3ef 181 ENTER_with_name("sassign_coderef");
53a42478
NC
182 SvREFCNT_inc_void(SvRV(cv));
183 /* newCONSTSUB takes a reference count on the passed in SV
184 from us. We set the name to NULL, otherwise we get into
185 all sorts of fun as the reference to our new sub is
186 donated to the GV that we're about to assign to.
187 */
3e75a3c4 188 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
ad64d0ec 189 SvRV(cv))));
fc2b2dca 190 SvREFCNT_dec_NN(cv);
d343c3ef 191 LEAVE_with_name("sassign_coderef");
53a42478
NC
192 } else {
193 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
194 is that
195 First: ops for \&{"BONK"}; return us the constant in the
196 symbol table
197 Second: ops for *{"BONK"} cause that symbol table entry
198 (and our reference to it) to be upgraded from RV
199 to typeblob)
200 Thirdly: We get here. cv is actually PVGV now, and its
201 GvCV() is actually the subroutine we're looking for
202
203 So change the reference so that it points to the subroutine
204 of that typeglob, as that's what they were after all along.
205 */
159b6efe 206 GV *const upgraded = MUTABLE_GV(cv);
53a42478
NC
207 CV *const source = GvCV(upgraded);
208
209 assert(source);
210 assert(CvFLAGS(source) & CVf_CONST);
211
0ad694a7 212 SvREFCNT_inc_simple_void_NN(source);
fc2b2dca 213 SvREFCNT_dec_NN(upgraded);
3e75a3c4 214 SvRV_set(right, MUTABLE_SV(source));
53a42478 215 }
e26df76a 216 }
53a42478 217
e26df76a 218 }
8fe85e3f 219 if (
5d9574c1 220 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
3e75a3c4 221 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
8fe85e3f
FC
222 )
223 Perl_warner(aTHX_
224 packWARN(WARN_MISC), "Useless assignment to a temporary"
225 );
3e75a3c4
RU
226 SvSetMagicSV(left, right);
227 SETs(left);
a0d0e21e
LW
228 RETURN;
229}
230
231PP(pp_cond_expr)
232{
20b7effb 233 dSP;
f4c975aa
DM
234 SV *sv;
235
f410a211 236 PERL_ASYNC_CHECK();
f4c975aa
DM
237 sv = POPs;
238 RETURNOP(SvTRUE_NN(sv) ? cLOGOP->op_other : cLOGOP->op_next);
a0d0e21e
LW
239}
240
241PP(pp_unstack)
242{
f5319de9 243 PERL_CONTEXT *cx;
8f3964af 244 PERL_ASYNC_CHECK();
a0d0e21e 245 TAINT_NOT; /* Each statement is presumed innocent */
4ebe6e95 246 cx = CX_CUR();
f5319de9 247 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
a0d0e21e 248 FREETMPS;
eae48c89 249 if (!(PL_op->op_flags & OPf_SPECIAL)) {
93661e56 250 assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
dfe0f39b 251 CX_LEAVE_SCOPE(cx);
eae48c89 252 }
a0d0e21e
LW
253 return NORMAL;
254}
255
16fe3f8a
DM
256
257/* The main body of pp_concat, not including the magic/overload and
258 * stack handling.
259 * It does targ = left . right.
260 * Moved into a separate function so that pp_multiconcat() can use it
261 * too.
262 */
263
264PERL_STATIC_INLINE void
265S_do_concat(pTHX_ SV *left, SV *right, SV *targ, U8 targmy)
a0d0e21e 266{
8d6d96c1
HS
267 bool lbyte;
268 STRLEN rlen;
d4c19fe8 269 const char *rpv = NULL;
a6b599c7 270 bool rbyte = FALSE;
a9c4fd4e 271 bool rcopied = FALSE;
8d6d96c1 272
6f1401dc
DM
273 if (TARG == right && right != left) { /* $r = $l.$r */
274 rpv = SvPV_nomg_const(right, rlen);
c75ab21a 275 rbyte = !DO_UTF8(right);
59cd0e26 276 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
349d4f2f 277 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
db79b45b 278 rcopied = TRUE;
8d6d96c1 279 }
7889fe52 280
89734059 281 if (TARG != left) { /* not $l .= $r */
a9c4fd4e 282 STRLEN llen;
6f1401dc 283 const char* const lpv = SvPV_nomg_const(left, llen);
90f5826e 284 lbyte = !DO_UTF8(left);
8d6d96c1
HS
285 sv_setpvn(TARG, lpv, llen);
286 if (!lbyte)
287 SvUTF8_on(TARG);
288 else
289 SvUTF8_off(TARG);
290 }
18ea7bf2
SM
291 else { /* $l .= $r and left == TARG */
292 if (!SvOK(left)) {
51f69a24 293 if ((left == right /* $l .= $l */
16fe3f8a 294 || targmy) /* $l = $l . $r */
51f69a24
AC
295 && ckWARN(WARN_UNINITIALIZED)
296 )
297 report_uninit(left);
adf14ec6 298 SvPVCLEAR(left);
c75ab21a 299 }
18ea7bf2
SM
300 else {
301 SvPV_force_nomg_nolen(left);
302 }
583a5589 303 lbyte = !DO_UTF8(left);
90f5826e 304 if (IN_BYTES)
18ea7bf2 305 SvUTF8_off(left);
8d6d96c1 306 }
a12c0f56 307
c75ab21a 308 if (!rcopied) {
6f1401dc 309 rpv = SvPV_nomg_const(right, rlen);
c75ab21a
RH
310 rbyte = !DO_UTF8(right);
311 }
8d6d96c1
HS
312 if (lbyte != rbyte) {
313 if (lbyte)
314 sv_utf8_upgrade_nomg(TARG);
315 else {
db79b45b 316 if (!rcopied)
59cd0e26 317 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
8d6d96c1 318 sv_utf8_upgrade_nomg(right);
6f1401dc 319 rpv = SvPV_nomg_const(right, rlen);
69b47968 320 }
a0d0e21e 321 }
8d6d96c1 322 sv_catpvn_nomg(TARG, rpv, rlen);
16fe3f8a
DM
323 SvSETMAGIC(TARG);
324}
325
43ebc500 326
16fe3f8a
DM
327PP(pp_concat)
328{
329 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
330 {
331 dPOPTOPssrl;
332 S_do_concat(aTHX_ left, right, targ, PL_op->op_private & OPpTARGET_MY);
333 SETs(TARG);
a0d0e21e 334 RETURN;
748a9306 335 }
a0d0e21e
LW
336}
337
e839e6ed
DM
338
339/* pp_multiconcat()
340
341Concatenate one or more args, possibly interleaved with constant string
342segments. The result may be assigned to, or appended to, a variable or
343expression.
344
345Several op_flags and/or op_private bits indicate what the target is, and
346whether it's appended to. Valid permutations are:
347
348 - (PADTMP) = (A.B.C....)
349 OPpTARGET_MY $lex = (A.B.C....)
350 OPpTARGET_MY,OPpLVAL_INTRO my $lex = (A.B.C....)
351 OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex .= (A.B.C....)
352 OPf_STACKED expr = (A.B.C....)
353 OPf_STACKED,OPpMULTICONCAT_APPEND expr .= (A.B.C....)
354
355Other combinations like (A.B).(C.D) are not optimised into a multiconcat
356op, as it's too hard to get the correct ordering of ties, overload etc.
357
358In addition:
359
360 OPpMULTICONCAT_FAKE: not a real concat, instead an optimised
361 sprintf "...%s...". Don't call '.'
362 overloading: only use '""' overloading.
363
55b62dee
DM
364 OPpMULTICONCAT_STRINGIFY: the RHS was of the form
365 "...$a...$b..." rather than
e839e6ed
DM
366 "..." . $a . "..." . $b . "..."
367
368An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are
369defined with PERL_MULTICONCAT_IX_FOO constants, where:
370
371
372 FOO index description
373 -------- ----- ----------------------------------
374 NARGS 0 number of arguments
375 PLAIN_PV 1 non-utf8 constant string
376 PLAIN_LEN 2 non-utf8 constant string length
377 UTF8_PV 3 utf8 constant string
378 UTF8_LEN 4 utf8 constant string length
379 LENGTHS 5 first of nargs+1 const segment lengths
380
381The idea is that a general string concatenation will have a fixed (known
382at compile time) number of variable args, interspersed with constant
383strings, e.g. "a=$a b=$b\n"
384
385All the constant string segments "a=", " b=" and "\n" are stored as a
386single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along
387with a series of segment lengths: e.g. 2,3,1. In the case where the
388constant string is plain but has a different utf8 representation, both
389variants are stored, and two sets of (nargs+1) segments lengths are stored
390in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS.
391
392A segment length of -1 indicates that there is no constant string at that
393point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which
394have differing overloading behaviour.
395
396*/
397
398PP(pp_multiconcat)
399{
400 dSP;
401 SV *targ; /* The SV to be assigned or appended to */
057ba76a 402 char *targ_pv; /* where within SvPVX(targ) we're writing to */
e839e6ed
DM
403 STRLEN targ_len; /* SvCUR(targ) */
404 SV **toparg; /* the highest arg position on the stack */
405 UNOP_AUX_item *aux; /* PL_op->op_aux buffer */
406 UNOP_AUX_item *const_lens; /* the segment length array part of aux */
407 const char *const_pv; /* the current segment of the const string buf */
ca84e88e
DM
408 SSize_t nargs; /* how many args were expected */
409 SSize_t stack_adj; /* how much to adjust SP on return */
057ba76a 410 STRLEN grow; /* final size of destination string (targ) */
e839e6ed
DM
411 UV targ_count; /* how many times targ has appeared on the RHS */
412 bool is_append; /* OPpMULTICONCAT_APPEND flag is set */
413 bool slow_concat; /* args too complex for quick concat */
414 U32 dst_utf8; /* the result will be utf8 (indicate this with
415 SVf_UTF8 in a U32, rather than using bool,
416 for ease of testing and setting) */
417 /* for each arg, holds the result of an SvPV() call */
418 struct multiconcat_svpv {
419 char *pv;
420 SSize_t len;
421 }
422 *targ_chain, /* chain of slots where targ has appeared on RHS */
423 *svpv_p, /* ptr for looping through svpv_buf */
424 *svpv_base, /* first slot (may be greater than svpv_buf), */
425 *svpv_end, /* and slot after highest result so far, of: */
426 svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */
427
428 aux = cUNOP_AUXx(PL_op)->op_aux;
ca84e88e 429 stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
e839e6ed
DM
430 is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND);
431
432 /* get targ from the stack or pad */
433
434 if (PL_op->op_flags & OPf_STACKED) {
435 if (is_append) {
436 /* for 'expr .= ...', expr is the bottom item on the stack */
437 targ = SP[-nargs];
438 stack_adj++;
439 }
440 else
441 /* for 'expr = ...', expr is the top item on the stack */
442 targ = POPs;
443 }
444 else {
445 SV **svp = &(PAD_SVl(PL_op->op_targ));
446 targ = *svp;
447 if (PL_op->op_private & OPpLVAL_INTRO) {
448 assert(PL_op->op_private & OPpTARGET_MY);
449 save_clearsv(svp);
450 }
451 if (!nargs)
452 /* $lex .= "const" doesn't cause anything to be pushed */
453 EXTEND(SP,1);
454 }
455
456 toparg = SP;
457 SP -= (nargs - 1);
e839e6ed
DM
458 grow = 1; /* allow for '\0' at minimum */
459 targ_count = 0;
460 targ_chain = NULL;
461 targ_len = 0;
462 svpv_end = svpv_buf;
463 /* only utf8 variants of the const strings? */
464 dst_utf8 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8;
465
466
467 /* --------------------------------------------------------------
468 * Phase 1:
469 *
470 * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8
471 * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths.
472 *
473 * utf8 is indicated by storing a negative length.
474 *
475 * Where an arg is actually targ, the stringification is deferred:
476 * the length is set to 0, and the slot is added to targ_chain.
477 *
af390142
DM
478 * If a magic, overloaded, or otherwise weird arg is found, which
479 * might have side effects when stringified, the loop is abandoned and
480 * we goto a code block where a more basic 'emulate calling
481 * pp_cpncat() on each arg in turn' is done.
e839e6ed
DM
482 */
483
484 for (; SP <= toparg; SP++, svpv_end++) {
e839e6ed
DM
485 U32 utf8;
486 STRLEN len;
487 SV *sv;
488
489 assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
490
491 sv = *SP;
e839e6ed
DM
492
493 /* this if/else chain is arranged so that common/simple cases
494 * take few conditionals */
495
af390142
DM
496 if (LIKELY((SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK)) {
497 /* common case: sv is a simple non-magical PV */
498 if (targ == sv) {
499 /* targ appears on RHS.
500 * Delay storing PV pointer; instead, add slot to targ_chain
501 * so it can be populated later, after targ has been grown and
502 * we know its final SvPVX() address.
503 */
504 targ_on_rhs:
505 svpv_end->len = 0; /* zerojng here means we can skip
506 updating later if targ_len == 0 */
507 svpv_end->pv = (char*)targ_chain;
508 targ_chain = svpv_end;
509 targ_count++;
510 continue;
511 }
512
e839e6ed 513 len = SvCUR(sv);
af390142 514 svpv_end->pv = SvPVX(sv);
e839e6ed 515 }
af390142
DM
516 else if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK)))
517 /* may have side effects: tie, overload etc.
518 * Abandon 'stringify everything first' and handle
519 * args in strict order. Note that already-stringified args
520 * will be reprocessed, which is safe because the each first
521 * stringification would have been idempotent.
e839e6ed 522 */
af390142
DM
523 goto do_magical;
524 else if (SvNIOK(sv)) {
525 if (targ == sv)
526 goto targ_on_rhs;
527 /* stringify general valid scalar */
e839e6ed
DM
528 svpv_end->pv = sv_2pv_flags(sv, &len, 0);
529 }
af390142
DM
530 else if (!SvOK(sv)) {
531 if (ckWARN(WARN_UNINITIALIZED))
532 /* an undef value in the presence of warnings may trigger
533 * side affects */
534 goto do_magical;
535 svpv_end->pv = (char*)"";
536 len = 0;
537 }
538 else
539 goto do_magical; /* something weird */
e839e6ed
DM
540
541 utf8 = (SvFLAGS(sv) & SVf_UTF8);
542 dst_utf8 |= utf8;
543 ASSUME(len < SSize_t_MAX);
544 svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len;
545 grow += len;
546 }
547
548 /* --------------------------------------------------------------
549 * Phase 2:
550 *
551 * Stringify targ:
552 *
553 * if targ appears on the RHS or is appended to, force stringify it;
554 * otherwise set it to "". Then set targ_len.
555 */
556
557 if (is_append) {
af390142
DM
558 /* abandon quick route if using targ might have side effects */
559 if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK)))
560 goto do_magical;
e839e6ed
DM
561
562 if (SvOK(targ)) {
563 U32 targ_utf8;
564 stringify_targ:
565 SvPV_force_nomg_nolen(targ);
566 targ_utf8 = SvFLAGS(targ) & SVf_UTF8;
567 if (UNLIKELY(dst_utf8 & ~targ_utf8)) {
568 if (LIKELY(!IN_BYTES))
569 sv_utf8_upgrade_nomg(targ);
570 }
571 else
572 dst_utf8 |= targ_utf8;
573
574 targ_len = SvCUR(targ);
575 grow += targ_len * (targ_count + is_append);
576 goto phase3;
577 }
af390142
DM
578 else if (ckWARN(WARN_UNINITIALIZED))
579 /* warning might have side effects */
580 goto do_magical;
581 /* the undef targ will be silently SvPVCLEAR()ed below */
e839e6ed
DM
582 }
583 else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) {
584 /* Assigning to some weird LHS type. Don't force the LHS to be an
585 * empty string; instead, do things 'long hand' by using the
586 * overload code path, which concats to a TEMP sv and does
587 * sv_catsv() calls rather than COPY()s. This ensures that even
588 * bizarre code like this doesn't break or crash:
589 * *F = *F . *F.
590 * (which makes the 'F' typeglob an alias to the
591 * '*main::F*main::F' typeglob).
592 */
af390142 593 goto do_magical;
e839e6ed 594 }
af390142 595 else if (targ_chain)
e839e6ed 596 /* targ was found on RHS.
af390142
DM
597 * Force stringify it, using the same code as the append branch
598 * above, except that we don't need the magic/overload/undef
599 * checks as these will already have been done in the phase 1
600 * loop.
e839e6ed 601 */
e839e6ed 602 goto stringify_targ;
e839e6ed
DM
603
604 /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
605 * those will be done later. */
e839e6ed
DM
606 SV_CHECK_THINKFIRST_COW_DROP(targ);
607 SvUPGRADE(targ, SVt_PV);
608 SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
609 SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8);
610
611 phase3:
612
613 /* --------------------------------------------------------------
614 * Phase 3:
615 *
057ba76a 616 * UTF-8 tweaks and grow targ:
e839e6ed
DM
617 *
618 * Now that we know the length and utf8-ness of both the targ and
057ba76a 619 * args, grow targ to the size needed to accumulate all the args, based
e839e6ed
DM
620 * on whether targ appears on the RHS, whether we're appending, and
621 * whether any non-utf8 args expand in size if converted to utf8.
622 *
623 * For the latter, if dst_utf8 we scan non-utf8 args looking for
624 * variant chars, and adjust the svpv->len value of those args to the
625 * utf8 size and negate it to flag them. At the same time we un-negate
626 * the lens of any utf8 args since after this phase we no longer care
627 * whether an arg is utf8 or not.
628 *
629 * Finally, initialise const_lens and const_pv based on utf8ness.
630 * Note that there are 3 permutations:
631 *
632 * * If the constant string is invariant whether utf8 or not (e.g. "abc"),
633 * then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as
634 * aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of
635 * segment lengths.
636 *
637 * * If the string is fully utf8, e.g. "\x{100}", then
638 * aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is
639 * one set of segment lengths.
640 *
641 * * If the string has different plain and utf8 representations
642 * (e.g. "\x80"), then then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
643 * holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
644 * holds the utf8 rep, and there are 2 sets of segment lengths,
645 * with the utf8 set following after the plain set.
646 *
647 * On entry to this section the (pv,len) pairs in svpv_buf have the
648 * following meanings:
649 * (pv, len) a plain string
650 * (pv, -len) a utf8 string
651 * (NULL, 0) left-most targ \ linked together R-to-L
652 * (next, 0) other targ / in targ_chain
653 */
654
655 /* turn off utf8 handling if 'use bytes' is in scope */
656 if (UNLIKELY(dst_utf8 && IN_BYTES)) {
657 dst_utf8 = 0;
057ba76a 658 SvUTF8_off(targ);
e839e6ed
DM
659 /* undo all the negative lengths which flag utf8-ness */
660 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
661 SSize_t len = svpv_p->len;
662 if (len < 0)
663 svpv_p->len = -len;
664 }
665 }
666
667 /* grow += total of lengths of constant string segments */
668 {
669 SSize_t len;
670 len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN
b5bf9f73 671 : PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
e839e6ed
DM
672 slow_concat = cBOOL(len);
673 grow += len;
674 }
675
676 const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
677
678 if (dst_utf8) {
679 const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
680 if ( aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv
681 && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv)
682 /* separate sets of lengths for plain and utf8 */
683 const_lens += nargs + 1;
684
685 /* If the result is utf8 but some of the args aren't,
686 * calculate how much extra growth is needed for all the chars
687 * which will expand to two utf8 bytes.
688 * Also, if the growth is non-zero, negate the length to indicate
689 * that this this is a variant string. Conversely, un-negate the
690 * length on utf8 args (which was only needed to flag non-utf8
691 * args in this loop */
692 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
7d5ed5d0 693 SSize_t len, extra;
e839e6ed
DM
694
695 len = svpv_p->len;
696 if (len <= 0) {
697 svpv_p->len = -len;
698 continue;
699 }
700
7d5ed5d0
KW
701 extra = variant_under_utf8_count((U8 *) svpv_p->pv,
702 (U8 *) svpv_p->pv + len);
e839e6ed
DM
703 if (UNLIKELY(extra)) {
704 grow += extra;
705 /* -ve len indicates special handling */
706 svpv_p->len = -(len + extra);
707 slow_concat = TRUE;
708 }
709 }
710 }
711 else
712 const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
713
714 /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
715 * already have been dropped */
057ba76a
DM
716 assert(!SvIsCOW(targ));
717 targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ));
e839e6ed
DM
718
719
720 /* --------------------------------------------------------------
721 * Phase 4:
722 *
057ba76a
DM
723 * Now that targ has been grown, we know the final address of the targ
724 * PVX, if needed. Preserve / move targ contents if appending or if
725 * targ appears on RHS.
e839e6ed
DM
726 *
727 * Also update svpv_buf slots in targ_chain.
728 *
729 * Don't bother with any of this if the target length is zero:
730 * targ_len is set to zero unless we're appending or targ appears on
731 * RHS. And even if it is, we can optimise by skipping this chunk of
732 * code for zero targ_len. In the latter case, we don't need to update
733 * the slots in targ_chain with the (zero length) target string, since
734 * we set the len in such slots to 0 earlier, and since the Copy() is
735 * skipped on zero length, it doesn't matter what svpv_p->pv contains.
736 *
737 * On entry to this section the (pv,len) pairs in svpv_buf have the
738 * following meanings:
739 * (pv, len) a pure-plain or utf8 string
740 * (pv, -(len+extra)) a plain string which will expand by 'extra'
741 * bytes when converted to utf8
742 * (NULL, 0) left-most targ \ linked together R-to-L
743 * (next, 0) other targ / in targ_chain
744 *
745 * On exit, the targ contents will have been moved to the
746 * earliest place they are needed (e.g. $x = "abc$x" will shift them
747 * 3 bytes, while $x .= ... will leave them at the beginning);
057ba76a 748 * and dst_pv will point to the location within SvPVX(targ) where the
e839e6ed
DM
749 * next arg should be copied.
750 */
751
752 svpv_base = svpv_buf;
753
754 if (targ_len) {
755 struct multiconcat_svpv *tc_stop;
057ba76a 756 char *targ_buf = targ_pv; /* ptr to original targ string */
e839e6ed 757
e839e6ed
DM
758 assert(is_append || targ_count);
759
760 if (is_append) {
057ba76a 761 targ_pv += targ_len;
e839e6ed
DM
762 tc_stop = NULL;
763 }
764 else {
765 /* The targ appears on RHS, e.g. '$t = $a . $t . $t'.
766 * Move the current contents of targ to the first
767 * position where it's needed, and use that as the src buffer
768 * for any further uses (such as the second RHS $t above).
769 * In calculating the first position, we need to sum the
770 * lengths of all consts and args before that.
771 */
772
773 UNOP_AUX_item *lens = const_lens;
774 /* length of first const string segment */
b5bf9f73 775 STRLEN offset = lens->ssize > 0 ? lens->ssize : 0;
e839e6ed
DM
776
777 assert(targ_chain);
778 svpv_p = svpv_base;
779
780 for (;;) {
781 SSize_t len;
782 if (!svpv_p->pv)
783 break; /* the first targ argument */
784 /* add lengths of the next arg and const string segment */
785 len = svpv_p->len;
786 if (len < 0) /* variant args have this */
787 len = -len;
788 offset += (STRLEN)len;
b5bf9f73 789 len = (++lens)->ssize;
e839e6ed
DM
790 offset += (len >= 0) ? (STRLEN)len : 0;
791 if (!offset) {
792 /* all args and consts so far are empty; update
793 * the start position for the concat later */
794 svpv_base++;
795 const_lens++;
796 }
797 svpv_p++;
798 assert(svpv_p < svpv_end);
799 }
800
801 if (offset) {
057ba76a
DM
802 targ_buf += offset;
803 Move(targ_pv, targ_buf, targ_len, char);
e839e6ed 804 /* a negative length implies don't Copy(), but do increment */
90b21a3e 805 svpv_p->len = -((SSize_t)targ_len);
e839e6ed
DM
806 slow_concat = TRUE;
807 }
808 else {
809 /* skip the first targ copy */
810 svpv_base++;
811 const_lens++;
057ba76a 812 targ_pv += targ_len;
e839e6ed
DM
813 }
814
815 /* Don't populate the first targ slot in the loop below; it's
816 * either not used because we advanced svpv_base beyond it, or
817 * we already stored the special -targ_len value in it
818 */
819 tc_stop = svpv_p;
820 }
821
822 /* populate slots in svpv_buf representing targ on RHS */
823 while (targ_chain != tc_stop) {
824 struct multiconcat_svpv *p = targ_chain;
825 targ_chain = (struct multiconcat_svpv *)(p->pv);
057ba76a 826 p->pv = targ_buf;
e839e6ed
DM
827 p->len = (SSize_t)targ_len;
828 }
829 }
830
831
832 /* --------------------------------------------------------------
833 * Phase 5:
834 *
057ba76a 835 * Append all the args in svpv_buf, plus the const strings, to targ.
e839e6ed
DM
836 *
837 * On entry to this section the (pv,len) pairs in svpv_buf have the
838 * following meanings:
839 * (pv, len) a pure-plain or utf8 string (which may be targ)
840 * (pv, -(len+extra)) a plain string which will expand by 'extra'
841 * bytes when converted to utf8
842 * (0, -len) left-most targ, whose content has already
057ba76a 843 * been copied. Just advance targ_pv by len.
e839e6ed
DM
844 */
845
846 /* If there are no constant strings and no special case args
847 * (svpv_p->len < 0), use a simpler, more efficient concat loop
848 */
849 if (!slow_concat) {
850 for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) {
851 SSize_t len = svpv_p->len;
852 if (!len)
853 continue;
057ba76a
DM
854 Copy(svpv_p->pv, targ_pv, len, char);
855 targ_pv += len;
e839e6ed
DM
856 }
857 const_lens += (svpv_end - svpv_base + 1);
858 }
859 else {
860 /* Note that we iterate the loop nargs+1 times: to append nargs
861 * arguments and nargs+1 constant strings. For example, "-$a-$b-"
862 */
863 svpv_p = svpv_base - 1;
864
865 for (;;) {
b5bf9f73 866 SSize_t len = (const_lens++)->ssize;
e839e6ed
DM
867
868 /* append next const string segment */
869 if (len > 0) {
057ba76a
DM
870 Copy(const_pv, targ_pv, len, char);
871 targ_pv += len;
e839e6ed
DM
872 const_pv += len;
873 }
874
875 if (++svpv_p == svpv_end)
876 break;
877
878 /* append next arg */
879 len = svpv_p->len;
880
881 if (LIKELY(len > 0)) {
057ba76a
DM
882 Copy(svpv_p->pv, targ_pv, len, char);
883 targ_pv += len;
e839e6ed
DM
884 }
885 else if (UNLIKELY(len < 0)) {
886 /* negative length indicates two special cases */
887 const char *p = svpv_p->pv;
888 len = -len;
889 if (UNLIKELY(p)) {
890 /* copy plain-but-variant pv to a utf8 targ */
057ba76a 891 char * end_pv = targ_pv + len;
e839e6ed 892 assert(dst_utf8);
057ba76a 893 while (targ_pv < end_pv) {
e839e6ed 894 U8 c = (U8) *p++;
057ba76a 895 append_utf8_from_native_byte(c, (U8**)&targ_pv);
e839e6ed
DM
896 }
897 }
898 else
899 /* arg is already-copied targ */
057ba76a 900 targ_pv += len;
e839e6ed
DM
901 }
902
903 }
904 }
905
057ba76a
DM
906 *targ_pv = '\0';
907 SvCUR_set(targ, targ_pv - SvPVX(targ));
908 assert(grow >= SvCUR(targ) + 1);
909 assert(SvLEN(targ) >= SvCUR(targ) + 1);
e839e6ed
DM
910
911 /* --------------------------------------------------------------
912 * Phase 6:
913 *
af390142 914 * return result
e839e6ed
DM
915 */
916
af390142
DM
917 SP -= stack_adj;
918 SvTAINT(targ);
919 SETTARG;
920 RETURN;
e839e6ed 921
af390142
DM
922 /* --------------------------------------------------------------
923 * Phase 7:
924 *
925 * We only get here if any of the args (or targ too in the case of
926 * append) have something which might cause side effects, such
927 * as magic, overload, or an undef value in the presence of warnings.
928 * In that case, any earlier attempt to stringify the args will have
929 * been abandoned, and we come here instead.
930 *
931 * Here, we concat each arg in turn the old-fashioned way: essentially
932 * emulating pp_concat() in a loop. This means that all the weird edge
933 * cases will be handled correctly, if not necessarily speedily.
934 *
935 * Note that some args may already have been stringified - those are
936 * processed again, which is safe, since only args without side-effects
937 * were stringified earlier.
938 */
939
940 do_magical:
941 {
942 SSize_t i, n;
943 SV *left = NULL;
944 SV *right;
945 SV* nexttarg;
946 bool nextappend;
947 U32 utf8 = 0;
948 SV **svp;
949 const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
950 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
55b62dee 951 Size_t arg_count = 0; /* how many args have been processed */
af390142
DM
952
953 if (!cpv) {
954 cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
955 utf8 = SVf_UTF8;
956 }
957
958 svp = toparg - nargs + 1;
959
960 /* iterate for:
961 * nargs arguments,
962 * plus possible nargs+1 consts,
963 * plus, if appending, a final targ in an extra last iteration
964 */
965
966 n = nargs *2 + 1;
55b62dee
DM
967 for (i = 0; i <= n; i++) {
968 SSize_t len;
969
970 /* if necessary, stringify the final RHS result in
971 * something like $targ .= "$a$b$c" - simulating
972 * pp_stringify
973 */
974 if ( i == n
975 && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY)
976 && !(SvPOK(left))
977 /* extra conditions for backwards compatibility:
978 * probably incorrect, but keep the existing behaviour
979 * for now. The rules are:
980 * $x = "$ov" single arg: stringify;
981 * $x = "$ov$y" multiple args: don't stringify,
982 * $lex = "$ov$y$z" except TARGMY with at least 2 concats
983 */
984 && ( arg_count == 1
985 || ( arg_count >= 3
986 && !is_append
987 && (PL_op->op_private & OPpTARGET_MY)
988 && !(PL_op->op_private & OPpLVAL_INTRO)
989 )
990 )
991 )
992 {
993 SV *tmp = sv_newmortal();
994 sv_copypv(tmp, left);
995 SvSETMAGIC(tmp);
996 left = tmp;
997 }
998
999 /* do one extra iteration to handle $targ in $targ .= ... */
1000 if (i == n && !is_append)
1001 break;
1002
af390142 1003 /* get the next arg SV or regen the next const SV */
55b62dee 1004 len = lens[i >> 1].ssize;
af390142
DM
1005 if (i == n) {
1006 /* handle the final targ .= (....) */
1007 right = left;
1008 left = targ;
1009 }
1010 else if (i & 1)
1011 right = svp[(i >> 1)];
1012 else if (len < 0)
1013 continue; /* no const in this position */
1014 else {
1015 right = newSVpvn_flags(cpv, len, (utf8 | SVs_TEMP));
1016 cpv += len;
1017 }
e839e6ed 1018
55b62dee
DM
1019 arg_count++;
1020
1021 if (arg_count <= 1) {
af390142
DM
1022 left = right;
1023 continue; /* need at least two SVs to concat together */
1024 }
1025
55b62dee 1026 if (arg_count == 2 && i < n) {
af390142
DM
1027 /* for the first concat, create a mortal acting like the
1028 * padtmp from OP_CONST. In later iterations this will
1029 * be appended to */
1030 nexttarg = sv_newmortal();
1031 nextappend = FALSE;
af390142
DM
1032 }
1033 else {
1034 nexttarg = left;
1035 nextappend = TRUE;
1036 }
1037
1038 /* Handle possible overloading.
1039 * This is basically an unrolled
1040 * tryAMAGICbin_MG(concat_amg, AMGf_assign);
1041 * and
1042 * Perl_try_amagic_bin()
1043 * call, but using left and right rather than SP[-1], SP[0],
1044 * and not relying on OPf_STACKED implying .=
e839e6ed 1045 */
e839e6ed 1046
af390142
DM
1047 if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) {
1048 SvGETMAGIC(left);
1049 if (left != right)
1050 SvGETMAGIC(right);
1051
1052 if ((SvAMAGIC(left) || SvAMAGIC(right))
1053 /* sprintf doesn't do concat overloading,
1054 * but allow for $x .= sprintf(...)
1055 */
1056 && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE)
1057 || i == n)
e839e6ed 1058 )
af390142
DM
1059 {
1060 SV * const tmpsv = amagic_call(left, right, concat_amg,
1061 (nextappend ? AMGf_assign: 0));
1062 if (tmpsv) {
7554d344
DM
1063 /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test
1064 * here, which isn't needed as any implicit
1065 * assign done under OPpTARGET_MY is done after
af390142
DM
1066 * this loop */
1067 if (nextappend) {
1068 sv_setsv(left, tmpsv);
1069 SvSETMAGIC(left);
e839e6ed 1070 }
af390142
DM
1071 else
1072 left = tmpsv;
1073 continue;
1074 }
1075 }
1076
1077 /* if both args are the same magical value, make one a copy */
1078 if (left == right && SvGMAGICAL(left)) {
1079 left = sv_newmortal();
1080 /* Print the uninitialized warning now, so it includes the
1081 * variable name. */
1082 if (!SvOK(right)) {
1083 if (ckWARN(WARN_UNINITIALIZED))
1084 report_uninit(right);
1085 sv_setsv_flags(left, &PL_sv_no, 0);
e839e6ed 1086 }
af390142
DM
1087 else
1088 sv_setsv_flags(left, right, 0);
1089 SvGETMAGIC(right);
e839e6ed
DM
1090 }
1091 }
e839e6ed 1092
af390142
DM
1093 /* nexttarg = left . right */
1094 S_do_concat(aTHX_ left, right, nexttarg, 0);
1095 left = nexttarg;
e839e6ed 1096 }
e839e6ed 1097
af390142 1098 SP = toparg - stack_adj + 1;
e839e6ed 1099
4e521aaf
DM
1100 /* Return the result of all RHS concats, unless this op includes
1101 * an assign ($lex = x.y.z or expr = x.y.z), in which case copy
1102 * to target (which will be $lex or expr).
af390142
DM
1103 * If we are appending, targ will already have been appended to in
1104 * the loop */
4e521aaf
DM
1105 if ( !is_append
1106 && ( (PL_op->op_flags & OPf_STACKED)
1107 || (PL_op->op_private & OPpTARGET_MY))
1108 ) {
af390142
DM
1109 sv_setsv(targ, left);
1110 SvSETMAGIC(targ);
1111 }
4e521aaf
DM
1112 else
1113 targ = left;
af390142
DM
1114 SETs(targ);
1115 RETURN;
1116 }
e839e6ed
DM
1117}
1118
1119
0b5aba47
DM
1120/* push the elements of av onto the stack.
1121 * Returns PL_op->op_next to allow tail-call optimisation of its callers */
d5524600 1122
0b5aba47 1123STATIC OP*
d5524600
DM
1124S_pushav(pTHX_ AV* const av)
1125{
1126 dSP;
c70927a6 1127 const SSize_t maxarg = AvFILL(av) + 1;
d5524600 1128 EXTEND(SP, maxarg);
5d9574c1 1129 if (UNLIKELY(SvRMAGICAL(av))) {
c70927a6
FC
1130 PADOFFSET i;
1131 for (i=0; i < (PADOFFSET)maxarg; i++) {
fd77b29b
FC
1132 SV ** const svp = av_fetch(av, i, FALSE);
1133 SP[i+1] = LIKELY(svp)
1134 ? *svp
1135 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1f1dcfb5 1136 ? av_nonelem(av,i)
fd77b29b 1137 : &PL_sv_undef;
d5524600
DM
1138 }
1139 }
1140 else {
c70927a6
FC
1141 PADOFFSET i;
1142 for (i=0; i < (PADOFFSET)maxarg; i++) {
6661956a 1143 SV *sv = AvARRAY(av)[i];
fd77b29b
FC
1144 SP[i+1] = LIKELY(sv)
1145 ? sv
1146 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1f1dcfb5 1147 ? av_nonelem(av,i)
fd77b29b 1148 : &PL_sv_undef;
ce0d59fd 1149 }
d5524600
DM
1150 }
1151 SP += maxarg;
1152 PUTBACK;
0b5aba47 1153 return NORMAL;
d5524600
DM
1154}
1155
1156
a7fd8ef6
DM
1157/* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
1158
1159PP(pp_padrange)
1160{
20b7effb 1161 dSP;
a7fd8ef6
DM
1162 PADOFFSET base = PL_op->op_targ;
1163 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
d5524600
DM
1164 if (PL_op->op_flags & OPf_SPECIAL) {
1165 /* fake the RHS of my ($x,$y,..) = @_ */
1166 PUSHMARK(SP);
0b5aba47 1167 (void)S_pushav(aTHX_ GvAVn(PL_defgv));
d5524600
DM
1168 SPAGAIN;
1169 }
1170
a7fd8ef6
DM
1171 /* note, this is only skipped for compile-time-known void cxt */
1172 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
19742f39
AL
1173 int i;
1174
a7fd8ef6
DM
1175 EXTEND(SP, count);
1176 PUSHMARK(SP);
1177 for (i = 0; i <count; i++)
1178 *++SP = PAD_SV(base+i);
1179 }
1180 if (PL_op->op_private & OPpLVAL_INTRO) {
4e09461c
DM
1181 SV **svp = &(PAD_SVl(base));
1182 const UV payload = (UV)(
1183 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1184 | (count << SAVE_TIGHT_SHIFT)
1185 | SAVEt_CLEARPADRANGE);
19742f39
AL
1186 int i;
1187
6d59e610 1188 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
d081a355
DM
1189 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1190 == (Size_t)base);
a3444cc5
DM
1191 {
1192 dSS_ADD;
1193 SS_ADD_UV(payload);
1194 SS_ADD_END(1);
1195 }
4e09461c 1196
a7fd8ef6 1197 for (i = 0; i <count; i++)
4e09461c 1198 SvPADSTALE_off(*svp++); /* mark lexical as active */
a7fd8ef6
DM
1199 }
1200 RETURN;
1201}
1202
1203
a0d0e21e
LW
1204PP(pp_padsv)
1205{
20b7effb 1206 dSP;
6c28b496
DD
1207 EXTEND(SP, 1);
1208 {
1209 OP * const op = PL_op;
1210 /* access PL_curpad once */
1211 SV ** const padentry = &(PAD_SVl(op->op_targ));
1212 {
1213 dTARG;
1214 TARG = *padentry;
1215 PUSHs(TARG);
1216 PUTBACK; /* no pop/push after this, TOPs ok */
8ec5e241 1217 }
6c28b496
DD
1218 if (op->op_flags & OPf_MOD) {
1219 if (op->op_private & OPpLVAL_INTRO)
1220 if (!(op->op_private & OPpPAD_STATE))
1221 save_clearsv(padentry);
1222 if (op->op_private & OPpDEREF) {
8f90a16d
FC
1223 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
1224 than TARG reduces the scope of TARG, so it does not
1225 span the call to save_clearsv, resulting in smaller
1226 machine code. */
6c28b496
DD
1227 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
1228 }
1229 }
1230 return op->op_next;
4633a7c4 1231 }
a0d0e21e
LW
1232}
1233
1234PP(pp_readline)
1235{
30901a8a 1236 dSP;
12dc5f94
DM
1237 /* pp_coreargs pushes a NULL to indicate no args passed to
1238 * CORE::readline() */
30901a8a
FC
1239 if (TOPs) {
1240 SvGETMAGIC(TOPs);
fc99edcf 1241 tryAMAGICunTARGETlist(iter_amg, 0);
30901a8a
FC
1242 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1243 }
1244 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
6e592b3a
BM
1245 if (!isGV_with_GP(PL_last_in_gv)) {
1246 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
159b6efe 1247 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
8efb3254 1248 else {
f5284f61 1249 dSP;
ad64d0ec 1250 XPUSHs(MUTABLE_SV(PL_last_in_gv));
f5284f61 1251 PUTBACK;
897d3989 1252 Perl_pp_rv2gv(aTHX);
159b6efe 1253 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
745e740c 1254 assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
f5284f61
IZ
1255 }
1256 }
a0d0e21e
LW
1257 return do_readline();
1258}
1259
1260PP(pp_eq)
1261{
20b7effb 1262 dSP;
33efebe6
DM
1263 SV *left, *right;
1264
0872de45 1265 tryAMAGICbin_MG(eq_amg, AMGf_numeric);
33efebe6
DM
1266 right = POPs;
1267 left = TOPs;
1268 SETs(boolSV(
1269 (SvIOK_notUV(left) && SvIOK_notUV(right))
1270 ? (SvIVX(left) == SvIVX(right))
1271 : ( do_ncmp(left, right) == 0)
1272 ));
1273 RETURN;
a0d0e21e
LW
1274}
1275
b1c05ba5 1276
4c2c3128 1277/* also used for: pp_i_preinc() */
b1c05ba5 1278
a0d0e21e
LW
1279PP(pp_preinc)
1280{
4c2c3128
DM
1281 SV *sv = *PL_stack_sp;
1282
1283 if (LIKELY(((sv->sv_flags &
1284 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1285 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1286 == SVf_IOK))
1287 && SvIVX(sv) != IV_MAX)
1288 {
1289 SvIV_set(sv, SvIVX(sv) + 1);
1290 }
1291 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1292 sv_inc(sv);
1293 SvSETMAGIC(sv);
1294 return NORMAL;
1295}
1296
1297
1298/* also used for: pp_i_predec() */
1299
1300PP(pp_predec)
1301{
1302 SV *sv = *PL_stack_sp;
1303
1304 if (LIKELY(((sv->sv_flags &
1305 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1306 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1307 == SVf_IOK))
1308 && SvIVX(sv) != IV_MIN)
55497cff 1309 {
4c2c3128 1310 SvIV_set(sv, SvIVX(sv) - 1);
748a9306 1311 }
4c2c3128
DM
1312 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */
1313 sv_dec(sv);
1314 SvSETMAGIC(sv);
a0d0e21e
LW
1315 return NORMAL;
1316}
1317
b1c05ba5
DM
1318
1319/* also used for: pp_orassign() */
1320
a0d0e21e
LW
1321PP(pp_or)
1322{
20b7effb 1323 dSP;
f4c975aa 1324 SV *sv;
f410a211 1325 PERL_ASYNC_CHECK();
f4c975aa
DM
1326 sv = TOPs;
1327 if (SvTRUE_NN(sv))
a0d0e21e
LW
1328 RETURN;
1329 else {
c960fc3b
SP
1330 if (PL_op->op_type == OP_OR)
1331 --SP;
a0d0e21e
LW
1332 RETURNOP(cLOGOP->op_other);
1333 }
1334}
1335
b1c05ba5
DM
1336
1337/* also used for: pp_dor() pp_dorassign() */
1338
25a55bd7 1339PP(pp_defined)
c963b151 1340{
20b7effb 1341 dSP;
eb578fdb 1342 SV* sv;
6136c704 1343 bool defined;
25a55bd7 1344 const int op_type = PL_op->op_type;
ea5195b7 1345 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
c963b151 1346
6136c704 1347 if (is_dor) {
f410a211 1348 PERL_ASYNC_CHECK();
25a55bd7 1349 sv = TOPs;
5d9574c1 1350 if (UNLIKELY(!sv || !SvANY(sv))) {
2bd49cfc
NC
1351 if (op_type == OP_DOR)
1352 --SP;
25a55bd7
SP
1353 RETURNOP(cLOGOP->op_other);
1354 }
b7c44293
RGS
1355 }
1356 else {
1357 /* OP_DEFINED */
25a55bd7 1358 sv = POPs;
5d9574c1 1359 if (UNLIKELY(!sv || !SvANY(sv)))
25a55bd7 1360 RETPUSHNO;
b7c44293 1361 }
25a55bd7 1362
6136c704 1363 defined = FALSE;
c963b151
BD
1364 switch (SvTYPE(sv)) {
1365 case SVt_PVAV:
1366 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 1367 defined = TRUE;
c963b151
BD
1368 break;
1369 case SVt_PVHV:
1370 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 1371 defined = TRUE;
c963b151
BD
1372 break;
1373 case SVt_PVCV:
1374 if (CvROOT(sv) || CvXSUB(sv))
25a55bd7 1375 defined = TRUE;
c963b151
BD
1376 break;
1377 default:
5b295bef 1378 SvGETMAGIC(sv);
c963b151 1379 if (SvOK(sv))
25a55bd7 1380 defined = TRUE;
6136c704 1381 break;
c963b151 1382 }
6136c704
AL
1383
1384 if (is_dor) {
c960fc3b
SP
1385 if(defined)
1386 RETURN;
1387 if(op_type == OP_DOR)
1388 --SP;
25a55bd7 1389 RETURNOP(cLOGOP->op_other);
25a55bd7 1390 }
d9aa96a4
SP
1391 /* assuming OP_DEFINED */
1392 if(defined)
1393 RETPUSHYES;
1394 RETPUSHNO;
c963b151
BD
1395}
1396
230ee21f
DM
1397
1398
a0d0e21e
LW
1399PP(pp_add)
1400{
20b7effb 1401 dSP; dATARGET; bool useleft; SV *svl, *svr;
230ee21f 1402
6f1401dc
DM
1403 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
1404 svr = TOPs;
1405 svl = TOPm1s;
1406
28e5dec8 1407#ifdef PERL_PRESERVE_IVUV
230ee21f
DM
1408
1409 /* special-case some simple common cases */
1410 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1411 IV il, ir;
1412 U32 flags = (svl->sv_flags & svr->sv_flags);
1413 if (flags & SVf_IOK) {
1414 /* both args are simple IVs */
1415 UV topl, topr;
1416 il = SvIVX(svl);
1417 ir = SvIVX(svr);
1418 do_iv:
1419 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1420 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1421
1422 /* if both are in a range that can't under/overflow, do a
1423 * simple integer add: if the top of both numbers
1424 * are 00 or 11, then it's safe */
1425 if (!( ((topl+1) | (topr+1)) & 2)) {
1426 SP--;
1427 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1428 SETs(TARG);
1429 RETURN;
1430 }
1431 goto generic;
1432 }
1433 else if (flags & SVf_NOK) {
1434 /* both args are NVs */
1435 NV nl = SvNVX(svl);
1436 NV nr = SvNVX(svr);
1437
3a019afd 1438 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
230ee21f
DM
1439 /* nothing was lost by converting to IVs */
1440 goto do_iv;
3a019afd 1441 }
230ee21f
DM
1442 SP--;
1443 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1444 SETs(TARG);
1445 RETURN;
1446 }
1447 }
1448
1449 generic:
1450
1451 useleft = USE_LEFT(svl);
28e5dec8
JH
1452 /* We must see if we can perform the addition with integers if possible,
1453 as the integer code detects overflow while the NV code doesn't.
1454 If either argument hasn't had a numeric conversion yet attempt to get
1455 the IV. It's important to do this now, rather than just assuming that
1456 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1457 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1458 integer in case the second argument is IV=9223372036854775806
1459 We can (now) rely on sv_2iv to do the right thing, only setting the
1460 public IOK flag if the value in the NV (or PV) slot is truly integer.
1461
1462 A side effect is that this also aggressively prefers integer maths over
7dca457a
NC
1463 fp maths for integer values.
1464
a00b5bd3 1465 How to detect overflow?
7dca457a
NC
1466
1467 C 99 section 6.2.6.1 says
1468
1469 The range of nonnegative values of a signed integer type is a subrange
1470 of the corresponding unsigned integer type, and the representation of
1471 the same value in each type is the same. A computation involving
1472 unsigned operands can never overflow, because a result that cannot be
1473 represented by the resulting unsigned integer type is reduced modulo
1474 the number that is one greater than the largest value that can be
1475 represented by the resulting type.
1476
1477 (the 9th paragraph)
1478
1479 which I read as "unsigned ints wrap."
1480
1481 signed integer overflow seems to be classed as "exception condition"
1482
1483 If an exceptional condition occurs during the evaluation of an
1484 expression (that is, if the result is not mathematically defined or not
1485 in the range of representable values for its type), the behavior is
1486 undefined.
1487
1488 (6.5, the 5th paragraph)
1489
1490 I had assumed that on 2s complement machines signed arithmetic would
1491 wrap, hence coded pp_add and pp_subtract on the assumption that
1492 everything perl builds on would be happy. After much wailing and
1493 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1494 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
1495 unsigned code below is actually shorter than the old code. :-)
1496 */
1497
01f91bf2 1498 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1499 /* Unless the left argument is integer in range we are going to have to
1500 use NV maths. Hence only attempt to coerce the right argument if
1501 we know the left is integer. */
eb578fdb 1502 UV auv = 0;
9c5ffd7c 1503 bool auvok = FALSE;
7dca457a
NC
1504 bool a_valid = 0;
1505
28e5dec8 1506 if (!useleft) {
7dca457a
NC
1507 auv = 0;
1508 a_valid = auvok = 1;
1509 /* left operand is undef, treat as zero. + 0 is identity,
1510 Could SETi or SETu right now, but space optimise by not adding
1511 lots of code to speed up what is probably a rarish case. */
1512 } else {
1513 /* Left operand is defined, so is it IV? */
01f91bf2 1514 if (SvIV_please_nomg(svl)) {
800401ee
JH
1515 if ((auvok = SvUOK(svl)))
1516 auv = SvUVX(svl);
7dca457a 1517 else {
eb578fdb 1518 const IV aiv = SvIVX(svl);
7dca457a
NC
1519 if (aiv >= 0) {
1520 auv = aiv;
1521 auvok = 1; /* Now acting as a sign flag. */
53e2bfb7 1522 } else {
9354a41f
KW
1523 /* Using 0- here and later to silence bogus warning
1524 * from MS VC */
1525 auv = (UV) (0 - (UV) aiv);
7dca457a
NC
1526 }
1527 }
1528 a_valid = 1;
28e5dec8
JH
1529 }
1530 }
7dca457a
NC
1531 if (a_valid) {
1532 bool result_good = 0;
1533 UV result;
eb578fdb 1534 UV buv;
800401ee 1535 bool buvok = SvUOK(svr);
a00b5bd3 1536
7dca457a 1537 if (buvok)
800401ee 1538 buv = SvUVX(svr);
7dca457a 1539 else {
eb578fdb 1540 const IV biv = SvIVX(svr);
7dca457a
NC
1541 if (biv >= 0) {
1542 buv = biv;
1543 buvok = 1;
1544 } else
9354a41f 1545 buv = (UV) (0 - (UV) biv);
7dca457a
NC
1546 }
1547 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1548 else "IV" now, independent of how it came in.
7dca457a
NC
1549 if a, b represents positive, A, B negative, a maps to -A etc
1550 a + b => (a + b)
1551 A + b => -(a - b)
1552 a + B => (a - b)
1553 A + B => -(a + b)
1554 all UV maths. negate result if A negative.
1555 add if signs same, subtract if signs differ. */
1556
1557 if (auvok ^ buvok) {
1558 /* Signs differ. */
1559 if (auv >= buv) {
1560 result = auv - buv;
1561 /* Must get smaller */
1562 if (result <= auv)
1563 result_good = 1;
1564 } else {
1565 result = buv - auv;
1566 if (result <= buv) {
1567 /* result really should be -(auv-buv). as its negation
1568 of true value, need to swap our result flag */
1569 auvok = !auvok;
1570 result_good = 1;
28e5dec8
JH
1571 }
1572 }
7dca457a
NC
1573 } else {
1574 /* Signs same */
1575 result = auv + buv;
1576 if (result >= auv)
1577 result_good = 1;
1578 }
1579 if (result_good) {
1580 SP--;
1581 if (auvok)
28e5dec8 1582 SETu( result );
7dca457a
NC
1583 else {
1584 /* Negate result */
1585 if (result <= (UV)IV_MIN)
53e2bfb7
DM
1586 SETi(result == (UV)IV_MIN
1587 ? IV_MIN : -(IV)result);
7dca457a
NC
1588 else {
1589 /* result valid, but out of range for IV. */
1590 SETn( -(NV)result );
28e5dec8
JH
1591 }
1592 }
7dca457a
NC
1593 RETURN;
1594 } /* Overflow, drop through to NVs. */
28e5dec8
JH
1595 }
1596 }
230ee21f
DM
1597
1598#else
1599 useleft = USE_LEFT(svl);
28e5dec8 1600#endif
230ee21f 1601
a0d0e21e 1602 {
6f1401dc 1603 NV value = SvNV_nomg(svr);
4efa5a16 1604 (void)POPs;
28e5dec8
JH
1605 if (!useleft) {
1606 /* left operand is undef, treat as zero. + 0.0 is identity. */
1607 SETn(value);
1608 RETURN;
1609 }
6f1401dc 1610 SETn( value + SvNV_nomg(svl) );
28e5dec8 1611 RETURN;
a0d0e21e
LW
1612 }
1613}
1614
b1c05ba5
DM
1615
1616/* also used for: pp_aelemfast_lex() */
1617
a0d0e21e
LW
1618PP(pp_aelemfast)
1619{
20b7effb 1620 dSP;
93bad3fd 1621 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
8f878375 1622 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
a3b680e6 1623 const U32 lval = PL_op->op_flags & OPf_MOD;
7e169e84
DM
1624 const I8 key = (I8)PL_op->op_private;
1625 SV** svp;
1626 SV *sv;
1627
1628 assert(SvTYPE(av) == SVt_PVAV);
1629
f4484b87
DM
1630 EXTEND(SP, 1);
1631
7e169e84
DM
1632 /* inlined av_fetch() for simple cases ... */
1633 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1634 sv = AvARRAY(av)[key];
9fb994be 1635 if (sv) {
7e169e84
DM
1636 PUSHs(sv);
1637 RETURN;
1638 }
1639 }
1640
1641 /* ... else do it the hard way */
1642 svp = av_fetch(av, key, lval);
1643 sv = (svp ? *svp : &PL_sv_undef);
b024352e
DM
1644
1645 if (UNLIKELY(!svp && lval))
7e169e84 1646 DIE(aTHX_ PL_no_aelem, (int)key);
b024352e 1647
39cf747a 1648 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 1649 mg_get(sv);
be6c24e0 1650 PUSHs(sv);
a0d0e21e
LW
1651 RETURN;
1652}
1653
1654PP(pp_join)
1655{
20b7effb 1656 dSP; dMARK; dTARGET;
a0d0e21e
LW
1657 MARK++;
1658 do_join(TARG, *MARK, MARK, SP);
1659 SP = MARK;
1660 SETs(TARG);
1661 RETURN;
1662}
1663
a0d0e21e
LW
1664/* Oversized hot code. */
1665
b1c05ba5
DM
1666/* also used for: pp_say() */
1667
a0d0e21e
LW
1668PP(pp_print)
1669{
20b7effb 1670 dSP; dMARK; dORIGMARK;
eb578fdb 1671 PerlIO *fp;
236988e4 1672 MAGIC *mg;
159b6efe
NC
1673 GV * const gv
1674 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 1675 IO *io = GvIO(gv);
5b468f54 1676
9c9f25b8 1677 if (io
ad64d0ec 1678 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 1679 {
01bb7c6d 1680 had_magic:
68dc0745 1681 if (MARK == ORIGMARK) {
1c846c1f 1682 /* If using default handle then we need to make space to
a60c0954
NIS
1683 * pass object as 1st arg, so move other args up ...
1684 */
4352c267 1685 MEXTEND(SP, 1);
68dc0745
PP
1686 ++MARK;
1687 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1688 ++SP;
1689 }
3e0cb5de 1690 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
94bc412f
NC
1691 mg,
1692 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1693 | (PL_op->op_type == OP_SAY
1694 ? TIED_METHOD_SAY : 0)), sp - mark);
236988e4 1695 }
9c9f25b8 1696 if (!io) {
68b590d9 1697 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
ad64d0ec 1698 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 1699 goto had_magic;
51087808 1700 report_evil_fh(gv);
93189314 1701 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
1702 goto just_say_no;
1703 }
1704 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
1705 if (IoIFP(io))
1706 report_wrongway_fh(gv, '<');
51087808 1707 else
7716c5c5 1708 report_evil_fh(gv);
93189314 1709 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
1710 goto just_say_no;
1711 }
1712 else {
e23d9e2f 1713 SV * const ofs = GvSV(PL_ofsgv); /* $, */
a0d0e21e 1714 MARK++;
e23d9e2f 1715 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
a0d0e21e
LW
1716 while (MARK <= SP) {
1717 if (!do_print(*MARK, fp))
1718 break;
1719 MARK++;
1720 if (MARK <= SP) {
e23d9e2f
CS
1721 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
1722 if (!do_print(GvSV(PL_ofsgv), fp)) {
a0d0e21e
LW
1723 MARK--;
1724 break;
1725 }
1726 }
1727 }
1728 }
1729 else {
1730 while (MARK <= SP) {
1731 if (!do_print(*MARK, fp))
1732 break;
1733 MARK++;
1734 }
1735 }
1736 if (MARK <= SP)
1737 goto just_say_no;
1738 else {
cfc4a7da
GA
1739 if (PL_op->op_type == OP_SAY) {
1740 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
1741 goto just_say_no;
1742 }
1743 else if (PL_ors_sv && SvOK(PL_ors_sv))
7889fe52 1744 if (!do_print(PL_ors_sv, fp)) /* $\ */
a0d0e21e
LW
1745 goto just_say_no;
1746
1747 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1748 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
1749 goto just_say_no;
1750 }
1751 }
1752 SP = ORIGMARK;
e52fd6f4 1753 XPUSHs(&PL_sv_yes);
a0d0e21e
LW
1754 RETURN;
1755
1756 just_say_no:
1757 SP = ORIGMARK;
e52fd6f4 1758 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
1759 RETURN;
1760}
1761
b1c05ba5 1762
aa36782f
DM
1763/* do the common parts of pp_padhv() and pp_rv2hv()
1764 * It assumes the caller has done EXTEND(SP, 1) or equivalent.
af3b1cba 1765 * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
e84e4286
DM
1766 * 'has_targ' indicates that the op has a target - this should
1767 * be a compile-time constant so that the code can constant-folded as
1768 * appropriate
aa36782f
DM
1769 * */
1770
1771PERL_STATIC_INLINE OP*
e84e4286 1772S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
aa36782f 1773{
e80717e7
DM
1774 bool is_tied;
1775 bool is_bool;
e1ad5d4c 1776 MAGIC *mg;
aa36782f 1777 dSP;
e80717e7
DM
1778 IV i;
1779 SV *sv;
aa36782f
DM
1780
1781 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
1782
1783 if (gimme == G_ARRAY) {
8dc9003f 1784 hv_pushkv(hv, 3);
af3b1cba 1785 return NORMAL;
aa36782f
DM
1786 }
1787
1788 if (is_keys)
1789 /* 'keys %h' masquerading as '%h': reset iterator */
1790 (void)hv_iterinit(hv);
1791
6f2dc9a6
DM
1792 if (gimme == G_VOID)
1793 return NORMAL;
1794
e80717e7
DM
1795 is_bool = ( PL_op->op_private & OPpTRUEBOOL
1796 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
1797 && block_gimme() == G_VOID));
1798 is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
1799
1800 if (UNLIKELY(is_tied)) {
1801 if (is_keys && !is_bool) {
1802 i = 0;
1803 while (hv_iternext(hv))
1804 i++;
1805 goto push_i;
1806 }
1807 else {
1808 sv = magic_scalarpack(hv, mg);
1809 goto push_sv;
1810 }
3cd2c7d4 1811 }
e80717e7
DM
1812 else {
1813 i = HvUSEDKEYS(hv);
1814 if (is_bool) {
1815 sv = i ? &PL_sv_yes : &PL_sv_zero;
1816 push_sv:
1817 PUSHs(sv);
1818 }
1819 else {
1820 push_i:
e84e4286
DM
1821 if (has_targ) {
1822 dTARGET;
1823 PUSHi(i);
1824 }
1825 else
6f2dc9a6
DM
1826 if (is_keys) {
1827 /* parent op should be an unused OP_KEYS whose targ we can
1828 * use */
1829 dTARG;
1830 OP *k;
1831
1832 assert(!OpHAS_SIBLING(PL_op));
1833 k = PL_op->op_sibparent;
1834 assert(k->op_type == OP_KEYS);
1835 TARG = PAD_SV(k->op_targ);
1836 PUSHi(i);
1837 }
1838 else
e84e4286 1839 mPUSHi(i);
aa36782f 1840 }
aa36782f
DM
1841 }
1842
1843 PUTBACK;
1844 return NORMAL;
1845}
1846
1847
e855b461
DM
1848/* This is also called directly by pp_lvavref. */
1849PP(pp_padav)
1850{
1851 dSP; dTARGET;
1852 U8 gimme;
1853 assert(SvTYPE(TARG) == SVt_PVAV);
1854 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1855 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1856 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1857 EXTEND(SP, 1);
1858
1859 if (PL_op->op_flags & OPf_REF) {
1860 PUSHs(TARG);
1861 RETURN;
1862 }
1863 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1864 const I32 flags = is_lvalue_sub();
1865 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1866 if (GIMME_V == G_SCALAR)
1867 /* diag_listed_as: Can't return %s to lvalue scalar context */
1868 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1869 PUSHs(TARG);
1870 RETURN;
1871 }
1872 }
1873
1874 gimme = GIMME_V;
0b5aba47
DM
1875 if (gimme == G_ARRAY)
1876 return S_pushav(aTHX_ (AV*)TARG);
327c9b9e
DM
1877
1878 if (gimme == G_SCALAR) {
e855b461
DM
1879 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
1880 if (!maxarg)
1881 PUSHs(&PL_sv_zero);
1882 else if (PL_op->op_private & OPpTRUEBOOL)
1883 PUSHs(&PL_sv_yes);
1884 else
1885 mPUSHi(maxarg);
1886 }
1887 RETURN;
1888}
1889
1890
1891PP(pp_padhv)
1892{
1893 dSP; dTARGET;
1894 U8 gimme;
e855b461
DM
1895
1896 assert(SvTYPE(TARG) == SVt_PVHV);
e855b461
DM
1897 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1898 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1899 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1900
aa36782f
DM
1901 EXTEND(SP, 1);
1902
1903 if (PL_op->op_flags & OPf_REF) {
1904 PUSHs(TARG);
e855b461 1905 RETURN;
aa36782f 1906 }
e855b461
DM
1907 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1908 const I32 flags = is_lvalue_sub();
1909 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1910 if (GIMME_V == G_SCALAR)
1911 /* diag_listed_as: Can't return %s to lvalue scalar context */
1912 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
aa36782f 1913 PUSHs(TARG);
e855b461
DM
1914 RETURN;
1915 }
1916 }
1917
1918 gimme = GIMME_V;
e855b461 1919
aa36782f 1920 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
e84e4286
DM
1921 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
1922 0 /* has_targ*/);
e855b461
DM
1923}
1924
1925
b1c05ba5 1926/* also used for: pp_rv2hv() */
bdaf10a5 1927/* also called directly by pp_lvavref */
b1c05ba5 1928
a0d0e21e
LW
1929PP(pp_rv2av)
1930{
20b7effb 1931 dSP; dTOPss;
1c23e2bd 1932 const U8 gimme = GIMME_V;
13c59d41
MH
1933 static const char an_array[] = "an ARRAY";
1934 static const char a_hash[] = "a HASH";
bdaf10a5
FC
1935 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
1936 || PL_op->op_type == OP_LVAVREF;
d83b45b8 1937 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 1938
9026059d 1939 SvGETMAGIC(sv);
a0d0e21e 1940 if (SvROK(sv)) {
5d9574c1 1941 if (UNLIKELY(SvAMAGIC(sv))) {
93d7320b 1942 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
93d7320b 1943 }
17ab7946 1944 sv = SvRV(sv);
5d9574c1 1945 if (UNLIKELY(SvTYPE(sv) != type))
dcbac5bb 1946 /* diag_listed_as: Not an ARRAY reference */
13c59d41 1947 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
5d9574c1
DM
1948 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
1949 && PL_op->op_private & OPpLVAL_INTRO))
3da99855 1950 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e 1951 }
5d9574c1 1952 else if (UNLIKELY(SvTYPE(sv) != type)) {
67955e0c 1953 GV *gv;
1c846c1f 1954
6e592b3a 1955 if (!isGV_with_GP(sv)) {
13c59d41 1956 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
dc3c76f8
NC
1957 type, &sp);
1958 if (!gv)
1959 RETURN;
35cd451c
GS
1960 }
1961 else {
159b6efe 1962 gv = MUTABLE_GV(sv);
a0d0e21e 1963 }
ad64d0ec 1964 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 1965 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 1966 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
9f527363
FC
1967 }
1968 if (PL_op->op_flags & OPf_REF) {
17ab7946 1969 SETs(sv);
a0d0e21e 1970 RETURN;
9f527363 1971 }
5d9574c1 1972 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
40c94d11
FC
1973 const I32 flags = is_lvalue_sub();
1974 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 1975 if (gimme != G_ARRAY)
042560a6 1976 goto croak_cant_return;
17ab7946 1977 SETs(sv);
78f9721b 1978 RETURN;
40c94d11 1979 }
a0d0e21e
LW
1980 }
1981
17ab7946 1982 if (is_pp_rv2av) {
502c6561 1983 AV *const av = MUTABLE_AV(sv);
0b5aba47 1984
96913b52 1985 if (gimme == G_ARRAY) {
d5524600
DM
1986 SP--;
1987 PUTBACK;
0b5aba47 1988 return S_pushav(aTHX_ av);
1c846c1f 1989 }
0b5aba47
DM
1990
1991 if (gimme == G_SCALAR) {
c70927a6 1992 const SSize_t maxarg = AvFILL(av) + 1;
7be75ccf
DM
1993 if (PL_op->op_private & OPpTRUEBOOL)
1994 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
1995 else {
1996 dTARGET;
1997 SETi(maxarg);
1998 }
93965878 1999 }
7be75ccf
DM
2000 }
2001 else {
aa36782f
DM
2002 SP--; PUTBACK;
2003 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
e84e4286
DM
2004 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2005 1 /* has_targ*/);
17ab7946 2006 }
be85d344 2007 RETURN;
042560a6
NC
2008
2009 croak_cant_return:
2010 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
2011 is_pp_rv2av ? "array" : "hash");
77e217c6 2012 RETURN;
a0d0e21e
LW
2013}
2014
10c8fecd 2015STATIC void
fb8f4cf8 2016S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
10c8fecd 2017{
7918f24d
NC
2018 PERL_ARGS_ASSERT_DO_ODDBALL;
2019
fb8f4cf8 2020 if (*oddkey) {
6d822dc4 2021 if (ckWARN(WARN_MISC)) {
a3b680e6 2022 const char *err;
fb8f4cf8
RZ
2023 if (oddkey == firstkey &&
2024 SvROK(*oddkey) &&
2025 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2026 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
10c8fecd 2027 {
a3b680e6 2028 err = "Reference found where even-sized list expected";
10c8fecd
GS
2029 }
2030 else
a3b680e6 2031 err = "Odd number of elements in hash assignment";
f1f66076 2032 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
10c8fecd 2033 }
6d822dc4 2034
10c8fecd
GS
2035 }
2036}
2037
a5f48505
DM
2038
2039/* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2040 * are common to both the LHS and RHS of an aassign, and replace them
2041 * with copies. All these copies are made before the actual list assign is
2042 * done.
2043 *
2044 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2045 * element ($b) to the first LH element ($a), modifies $a; when the
2046 * second assignment is done, the second RH element now has the wrong
2047 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
2048 * Note that we don't need to make a mortal copy of $b.
2049 *
2050 * The algorithm below works by, for every RHS element, mark the
2051 * corresponding LHS target element with SVf_BREAK. Then if the RHS
2052 * element is found with SVf_BREAK set, it means it would have been
2053 * modified, so make a copy.
2054 * Note that by scanning both LHS and RHS in lockstep, we avoid
2055 * unnecessary copies (like $b above) compared with a naive
2056 * "mark all LHS; copy all marked RHS; unmark all LHS".
2057 *
2058 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2059 * it can't be common and can be skipped.
ebc643ce
DM
2060 *
2061 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2062 * that we thought we didn't need to call S_aassign_copy_common(), but we
2063 * have anyway for sanity checking. If we find we need to copy, then panic.
a5f48505
DM
2064 */
2065
2066PERL_STATIC_INLINE void
2067S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
ebc643ce
DM
2068 SV **firstrelem, SV **lastrelem
2069#ifdef DEBUGGING
2070 , bool fake
2071#endif
2072)
a5f48505
DM
2073{
2074 dVAR;
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{
27da23d5 2202 dVAR; 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
a0d0e21e
LW
2892PP(pp_match)
2893{
20b7effb 2894 dSP; dTARG;
eb578fdb 2895 PMOP *pm = cPMOP;
d65afb4b 2896 PMOP *dynpm = pm;
eb578fdb 2897 const char *s;
5c144d81 2898 const char *strend;
99a90e59 2899 SSize_t curpos = 0; /* initial pos() or current $+[0] */
a0d0e21e 2900 I32 global;
7fadf4a7 2901 U8 r_flags = 0;
5c144d81 2902 const char *truebase; /* Start of string */
eb578fdb 2903 REGEXP *rx = PM_GETRE(pm);
196a02af 2904 regexp *prog = ReANY(rx);
b3eb6a9b 2905 bool rxtainted;
1c23e2bd 2906 const U8 gimme = GIMME_V;
a0d0e21e 2907 STRLEN len;
a3b680e6 2908 const I32 oldsave = PL_savestack_ix;
e60df1fa 2909 I32 had_zerolen = 0;
b1422d62 2910 MAGIC *mg = NULL;
a0d0e21e 2911
533c011a 2912 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
2913 TARG = POPs;
2914 else {
9399c607
DM
2915 if (ARGTARG)
2916 GETTARGET;
2917 else {
2918 TARG = DEFSV;
2919 }
a0d0e21e
LW
2920 EXTEND(SP,1);
2921 }
d9f424b2 2922
c277df42 2923 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
2924 /* Skip get-magic if this is a qr// clone, because regcomp has
2925 already done it. */
196a02af 2926 truebase = prog->mother_re
69dc4b30
FC
2927 ? SvPV_nomg_const(TARG, len)
2928 : SvPV_const(TARG, len);
f1d31338 2929 if (!truebase)
2269b42e 2930 DIE(aTHX_ "panic: pp_match");
f1d31338 2931 strend = truebase + len;
196a02af 2932 rxtainted = (RXp_ISTAINTED(prog) ||
284167a5 2933 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 2934 TAINT_NOT;
a0d0e21e 2935
6c864ec2 2936 /* We need to know this in case we fail out early - pos() must be reset */
de0df3c0
MH
2937 global = dynpm->op_pmflags & PMf_GLOBAL;
2938
d65afb4b 2939 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
2940 if (
2941#ifdef USE_ITHREADS
2942 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
2943#else
2944 pm->op_pmflags & PMf_USED
2945#endif
2946 ) {
e5dc5375 2947 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
de0df3c0 2948 goto nope;
a0d0e21e
LW
2949 }
2950
5585e758 2951 /* handle the empty pattern */
196a02af 2952 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
5585e758
YO
2953 if (PL_curpm == PL_reg_curpm) {
2954 if (PL_curpm_under) {
2955 if (PL_curpm_under == PL_reg_curpm) {
2956 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
2957 } else {
2958 pm = PL_curpm_under;
2959 }
2960 }
2961 } else {
2962 pm = PL_curpm;
2963 }
2964 rx = PM_GETRE(pm);
196a02af 2965 prog = ReANY(rx);
a0d0e21e 2966 }
d65afb4b 2967
196a02af 2968 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
75d43e96 2969 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
147e3846 2970 UVuf " < %" IVdf ")\n",
196a02af 2971 (UV)len, (IV)RXp_MINLEN(prog)));
de0df3c0 2972 goto nope;
e5dc5375 2973 }
c277df42 2974
8ef97b0e 2975 /* get pos() if //g */
de0df3c0 2976 if (global) {
b1422d62 2977 mg = mg_find_mglob(TARG);
8ef97b0e 2978 if (mg && mg->mg_len >= 0) {
25fdce4a 2979 curpos = MgBYTEPOS(mg, TARG, truebase, len);
8ef97b0e
DM
2980 /* last time pos() was set, it was zero-length match */
2981 if (mg->mg_flags & MGf_MINMATCH)
2982 had_zerolen = 1;
2983 }
a0d0e21e 2984 }
8ef97b0e 2985
6e240d0b 2986#ifdef PERL_SAWAMPERSAND
196a02af 2987 if ( RXp_NPARENS(prog)
6502e081 2988 || PL_sawampersand
196a02af 2989 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 2990 || (dynpm->op_pmflags & PMf_KEEPCOPY)
6e240d0b
FC
2991 )
2992#endif
2993 {
6502e081
DM
2994 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
2995 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
2996 * only on the first iteration. Therefore we need to copy $' as well
2997 * as $&, to make the rest of the string available for captures in
2998 * subsequent iterations */
2999 if (! (global && gimme == G_ARRAY))
3000 r_flags |= REXEC_COPY_SKIP_POST;
3001 };
5b0e71e9
DM
3002#ifdef PERL_SAWAMPERSAND
3003 if (dynpm->op_pmflags & PMf_KEEPCOPY)
3004 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3005 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3006#endif
22e551b9 3007
f1d31338
DM
3008 s = truebase;
3009
d7be1480 3010 play_it_again:
985afbc1 3011 if (global)
03c83e26 3012 s = truebase + curpos;
f722798b 3013
77da2310 3014 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
03c83e26 3015 had_zerolen, TARG, NULL, r_flags))
03b6c93d 3016 goto nope;
77da2310
NC
3017
3018 PL_curpm = pm;
985afbc1 3019 if (dynpm->op_pmflags & PMf_ONCE)
c737faaf 3020#ifdef USE_ITHREADS
77da2310 3021 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 3022#else
77da2310 3023 dynpm->op_pmflags |= PMf_USED;
c737faaf 3024#endif
a0d0e21e 3025
72311751 3026 if (rxtainted)
196a02af
DM
3027 RXp_MATCH_TAINTED_on(prog);
3028 TAINT_IF(RXp_MATCH_TAINTED(prog));
35c2ccc3
DM
3029
3030 /* update pos */
3031
3032 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
b1422d62 3033 if (!mg)
35c2ccc3 3034 mg = sv_magicext_mglob(TARG);
196a02af
DM
3035 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
3036 if (RXp_ZERO_LEN(prog))
adf51885
DM
3037 mg->mg_flags |= MGf_MINMATCH;
3038 else
3039 mg->mg_flags &= ~MGf_MINMATCH;
35c2ccc3
DM
3040 }
3041
196a02af 3042 if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
bf9dff51
DM
3043 LEAVE_SCOPE(oldsave);
3044 RETPUSHYES;
3045 }
3046
88ab22af
DM
3047 /* push captures on stack */
3048
bf9dff51 3049 {
196a02af 3050 const I32 nparens = RXp_NPARENS(prog);
a3b680e6 3051 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 3052
c277df42 3053 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
3054 EXTEND(SP, nparens + i);
3055 EXTEND_MORTAL(nparens + i);
3056 for (i = !i; i <= nparens; i++) {
a0d0e21e 3057 PUSHs(sv_newmortal());
196a02af
DM
3058 if (LIKELY((RXp_OFFS(prog)[i].start != -1)
3059 && RXp_OFFS(prog)[i].end != -1 ))
5d9574c1 3060 {
196a02af
DM
3061 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
3062 const char * const s = RXp_OFFS(prog)[i].start + truebase;
3063 if (UNLIKELY( RXp_OFFS(prog)[i].end < 0
3064 || RXp_OFFS(prog)[i].start < 0
3065 || len < 0
3066 || len > strend - s)
3067 )
5637ef5b 3068 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
147e3846 3069 "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
196a02af
DM
3070 (long) i, (long) RXp_OFFS(prog)[i].start,
3071 (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
a0d0e21e 3072 sv_setpvn(*SP, s, len);
cce850e4 3073 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 3074 SvUTF8_on(*SP);
a0d0e21e
LW
3075 }
3076 }
3077 if (global) {
196a02af
DM
3078 curpos = (UV)RXp_OFFS(prog)[0].end;
3079 had_zerolen = RXp_ZERO_LEN(prog);
c277df42 3080 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 3081 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
3082 goto play_it_again;
3083 }
4633a7c4 3084 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
3085 RETURN;
3086 }
e5964223 3087 NOT_REACHED; /* NOTREACHED */
a0d0e21e 3088
7b52d656 3089 nope:
d65afb4b 3090 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
b1422d62
DM
3091 if (!mg)
3092 mg = mg_find_mglob(TARG);
3093 if (mg)
3094 mg->mg_len = -1;
a0d0e21e 3095 }
4633a7c4 3096 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
3097 if (gimme == G_ARRAY)
3098 RETURN;
3099 RETPUSHNO;
3100}
3101
3102OP *
864dbfa3 3103Perl_do_readline(pTHX)
a0d0e21e 3104{
20b7effb 3105 dSP; dTARGETSTACKED;
eb578fdb 3106 SV *sv;
a0d0e21e
LW
3107 STRLEN tmplen = 0;
3108 STRLEN offset;
760ac839 3109 PerlIO *fp;
eb578fdb
KW
3110 IO * const io = GvIO(PL_last_in_gv);
3111 const I32 type = PL_op->op_type;
1c23e2bd 3112 const U8 gimme = GIMME_V;
a0d0e21e 3113
6136c704 3114 if (io) {
50db69d8 3115 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 3116 if (mg) {
3e0cb5de 3117 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 3118 if (gimme == G_SCALAR) {
50db69d8
NC
3119 SPAGAIN;
3120 SvSetSV_nosteal(TARG, TOPs);
3121 SETTARG;
6136c704 3122 }
50db69d8 3123 return NORMAL;
0b7c7b4f 3124 }
e79b0511 3125 }
4608196e 3126 fp = NULL;
a0d0e21e
LW
3127 if (io) {
3128 fp = IoIFP(io);
3129 if (!fp) {
3130 if (IoFLAGS(io) & IOf_ARGV) {
3131 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 3132 IoLINES(io) = 0;
b9f2b683 3133 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 3134 IoFLAGS(io) &= ~IOf_START;
d5eb9a46 3135 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
4bac9ae4 3136 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
76f68e9b 3137 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3280af22 3138 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
3139 fp = IoIFP(io);
3140 goto have_fp;
a0d0e21e
LW
3141 }
3142 }
157fb5a1 3143 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e 3144 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 3145 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
3146 }
3147 }
0d44d22b
NC
3148 else if (type == OP_GLOB)
3149 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
3150 }
3151 else if (type == OP_GLOB)
3152 SP--;
7716c5c5 3153 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 3154 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 3155 }
a0d0e21e
LW
3156 }
3157 if (!fp) {
041457d9 3158 if ((!io || !(IoFLAGS(io) & IOf_START))
de7dabb6
TC
3159 && ckWARN(WARN_CLOSED)
3160 && type != OP_GLOB)
041457d9 3161 {
de7dabb6 3162 report_evil_fh(PL_last_in_gv);
3f4520fe 3163 }
54310121 3164 if (gimme == G_SCALAR) {
79628082 3165 /* undef TARG, and push that undefined value */
ba92458f 3166 if (type != OP_RCATLINE) {
3773545d 3167 sv_set_undef(TARG);
ba92458f 3168 }
a0d0e21e
LW
3169 PUSHTARG;
3170 }
3171 RETURN;
3172 }
a2008d6d 3173 have_fp:
54310121 3174 if (gimme == G_SCALAR) {
a0d0e21e 3175 sv = TARG;
0f722b55
RGS
3176 if (type == OP_RCATLINE && SvGMAGICAL(sv))
3177 mg_get(sv);
48de12d9
RGS
3178 if (SvROK(sv)) {
3179 if (type == OP_RCATLINE)
5668452f 3180 SvPV_force_nomg_nolen(sv);
48de12d9
RGS
3181 else
3182 sv_unref(sv);
3183 }
f7877b28 3184 else if (isGV_with_GP(sv)) {
5668452f 3185 SvPV_force_nomg_nolen(sv);
f7877b28 3186 }
862a34c6 3187 SvUPGRADE(sv, SVt_PV);
a0d0e21e 3188 tmplen = SvLEN(sv); /* remember if already alloced */
e3918bb7 3189 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
f72e8700
JJ
3190 /* try short-buffering it. Please update t/op/readline.t
3191 * if you change the growth length.
3192 */
3193 Sv_Grow(sv, 80);
3194 }
2b5e58c4
AMS
3195 offset = 0;
3196 if (type == OP_RCATLINE && SvOK(sv)) {
3197 if (!SvPOK(sv)) {
5668452f 3198 SvPV_force_nomg_nolen(sv);
2b5e58c4 3199 }
a0d0e21e 3200 offset = SvCUR(sv);
2b5e58c4 3201 }
a0d0e21e 3202 }
54310121 3203 else {
561b68a9 3204 sv = sv_2mortal(newSV(80));
54310121
PP
3205 offset = 0;
3206 }
fbad3eb5 3207
3887d568
AP
3208 /* This should not be marked tainted if the fp is marked clean */
3209#define MAYBE_TAINT_LINE(io, sv) \
3210 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
3211 TAINT; \
3212 SvTAINTED_on(sv); \
3213 }
3214
684bef36 3215/* delay EOF state for a snarfed empty file */
fbad3eb5 3216#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 3217 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 3218 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 3219
a0d0e21e 3220 for (;;) {
09e8efcc 3221 PUTBACK;
fbad3eb5 3222 if (!sv_gets(sv, fp, offset)
2d726892
TF
3223 && (type == OP_GLOB
3224 || SNARF_EOF(gimme, PL_rs, io, sv)
3225 || PerlIO_error(fp)))
fbad3eb5 3226 {
760ac839 3227 PerlIO_clearerr(fp);
a0d0e21e 3228 if (IoFLAGS(io) & IOf_ARGV) {
157fb5a1 3229 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e
LW
3230 if (fp)
3231 continue;
3280af22 3232 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
3233 }
3234 else if (type == OP_GLOB) {
a2a5de95
NC
3235 if (!do_close(PL_last_in_gv, FALSE)) {
3236 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
3237 "glob failed (child exited with status %d%s)",
3238 (int)(STATUS_CURRENT >> 8),
3239 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 3240 }
a0d0e21e 3241 }
54310121 3242 if (gimme == G_SCALAR) {
ba92458f
AE
3243 if (type != OP_RCATLINE) {
3244 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 3245 SvOK_off(TARG);
ba92458f 3246 }
09e8efcc 3247 SPAGAIN;
a0d0e21e
LW
3248 PUSHTARG;
3249 }
3887d568 3250 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
3251 RETURN;
3252 }
3887d568 3253 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 3254 IoLINES(io)++;
b9fee9ba 3255 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 3256 SvSETMAGIC(sv);
09e8efcc 3257 SPAGAIN;
a0d0e21e 3258 XPUSHs(sv);
a0d0e21e 3259 if (type == OP_GLOB) {
349d4f2f 3260 const char *t1;
45a23732 3261 Stat_t statbuf;
a0d0e21e 3262
3280af22 3263 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 3264 char * const tmps = SvEND(sv) - 1;
aa07b2f6 3265 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 3266 *tmps = '\0';
b162af07 3267 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
3268 }
3269 }
349d4f2f 3270 for (t1 = SvPVX_const(sv); *t1; t1++)
b51c3e77
CB
3271#ifdef __VMS
3272 if (strchr("*%?", *t1))
3273#else
7ad1e72d 3274 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
b51c3e77 3275#endif
a0d0e21e 3276 break;
45a23732 3277 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
a0d0e21e
LW
3278 (void)POPs; /* Unmatched wildcard? Chuck it... */
3279 continue;
3280 }
2d79bf7f 3281 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
3282 if (ckWARN(WARN_UTF8)) {
3283 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
3284 const STRLEN len = SvCUR(sv) - offset;
3285 const U8 *f;
3286
3287 if (!is_utf8_string_loc(s, len, &f))
3288 /* Emulate :encoding(utf8) warning in the same case. */
3289 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3290 "utf8 \"\\x%02X\" does not map to Unicode",
3291 f < (U8*)SvEND(sv) ? *f : 0);
3292 }
a0d0e21e 3293 }
54310121 3294 if (gimme == G_ARRAY) {
a0d0e21e 3295 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 3296 SvPV_shrink_to_cur(sv);
a0d0e21e 3297 }
561b68a9 3298 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
3299 continue;
3300 }
54310121 3301 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 3302 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
3303 const STRLEN new_len
3304 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 3305 SvPV_renew(sv, new_len);
a0d0e21e
LW
3306 }
3307 RETURN;
3308 }
3309}
3310
a0d0e21e
LW
3311PP(pp_helem)
3312{
20b7effb 3313 dSP;
760ac839 3314 HE* he;
ae77835f 3315 SV **svp;
c445ea15 3316 SV * const keysv = POPs;
85fbaab2 3317 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
3318 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3319 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 3320 SV *sv;
92970b93 3321 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 3322 bool preeminent = TRUE;
a0d0e21e 3323
6dfc73ea
SM
3324 if (SvTYPE(hv) != SVt_PVHV)
3325 RETPUSHUNDEF;
d4c19fe8 3326
92970b93 3327 if (localizing) {
d4c19fe8
AL
3328 MAGIC *mg;
3329 HV *stash;
d30e492c
VP
3330
3331 /* If we can determine whether the element exist,
3332 * Try to preserve the existenceness of a tied hash
3333 * element by using EXISTS and DELETE if possible.
3334 * Fallback to FETCH and STORE otherwise. */
2c5f48c2 3335 if (SvCANEXISTDELETE(hv))
d30e492c 3336 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 3337 }
d30e492c 3338
5f9d7e2b 3339 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
d4c19fe8 3340 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 3341 if (lval) {
746f6409 3342 if (!svp || !*svp || *svp == &PL_sv_undef) {
68dc0745
PP
3343 SV* lv;
3344 SV* key2;
2d8e6c8d 3345 if (!defer) {
be2597df 3346 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 3347 }
68dc0745
PP
3348 lv = sv_newmortal();
3349 sv_upgrade(lv, SVt_PVLV);
3350 LvTYPE(lv) = 'y';
6136c704 3351 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
fc2b2dca 3352 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
0ad694a7 3353 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
68dc0745
PP
3354 LvTARGLEN(lv) = 1;
3355 PUSHs(lv);
3356 RETURN;
3357 }
92970b93 3358 if (localizing) {
6881372e 3359 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
159b6efe 3360 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
3361 else if (preeminent)
3362 save_helem_flags(hv, keysv, svp,
3363 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
3364 else
3365 SAVEHDELETE(hv, keysv);
5f05dabc 3366 }
9026059d
GG
3367 else if (PL_op->op_private & OPpDEREF) {
3368 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3369 RETURN;
3370 }
a0d0e21e 3371 }
746f6409 3372 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
3373 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
3374 * was to make C<local $tied{foo} = $tied{foo}> possible.
3375 * However, it seems no longer to be needed for that purpose, and
3376 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
3377 * would loop endlessly since the pos magic is getting set on the
3378 * mortal copy and lost. However, the copy has the effect of
3379 * triggering the get magic, and losing it altogether made things like
3380 * c<$tied{foo};> in void context no longer do get magic, which some
3381 * code relied on. Also, delayed triggering of magic on @+ and friends
3382 * meant the original regex may be out of scope by now. So as a
3383 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
3384 * being called too many times). */
39cf747a 3385 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 3386 mg_get(sv);
be6c24e0 3387 PUSHs(sv);
a0d0e21e
LW
3388 RETURN;
3389}
3390
fedf30e1
DM
3391
3392/* a stripped-down version of Perl_softref2xv() for use by
3393 * pp_multideref(), which doesn't use PL_op->op_flags */
3394
f9db5646 3395STATIC GV *
fedf30e1
DM
3396S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
3397 const svtype type)
3398{
3399 if (PL_op->op_private & HINT_STRICT_REFS) {
3400 if (SvOK(sv))
3401 Perl_die(aTHX_ PL_no_symref_sv, sv,
3402 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
3403 else
3404 Perl_die(aTHX_ PL_no_usym, what);
3405 }
3406 if (!SvOK(sv))
3407 Perl_die(aTHX_ PL_no_usym, what);
3408 return gv_fetchsv_nomg(sv, GV_ADD, type);
3409}
3410
3411
79815f56
DM
3412/* Handle one or more aggregate derefs and array/hash indexings, e.g.
3413 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
fedf30e1
DM
3414 *
3415 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
79815f56
DM
3416 * Each of these either contains a set of actions, or an argument, such as
3417 * an IV to use as an array index, or a lexical var to retrieve.
3418 * Several actions re stored per UV; we keep shifting new actions off the
3419 * one UV, and only reload when it becomes zero.
fedf30e1
DM
3420 */
3421
3422PP(pp_multideref)
3423{
3424 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
3425 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3426 UV actions = items->uv;
3427
3428 assert(actions);
3429 /* this tells find_uninit_var() where we're up to */
3430 PL_multideref_pc = items;
3431
3432 while (1) {
3433 /* there are three main classes of action; the first retrieve
3434 * the initial AV or HV from a variable or the stack; the second
3435 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
3436 * the third an unrolled (/DREFHV, rv2hv, helem).
3437 */
3438 switch (actions & MDEREF_ACTION_MASK) {
3439
3440 case MDEREF_reload:
3441 actions = (++items)->uv;
3442 continue;
3443
3444 case MDEREF_AV_padav_aelem: /* $lex[...] */
3445 sv = PAD_SVl((++items)->pad_offset);
3446 goto do_AV_aelem;
3447
3448 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
3449 sv = UNOP_AUX_item_sv(++items);
3450 assert(isGV_with_GP(sv));
3451 sv = (SV*)GvAVn((GV*)sv);
3452 goto do_AV_aelem;
3453
3454 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
3455 {
3456 dSP;
3457 sv = POPs;
3458 PUTBACK;
3459 goto do_AV_rv2av_aelem;
3460 }
3461
3462 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
3463 sv = UNOP_AUX_item_sv(++items);
3464 assert(isGV_with_GP(sv));
3465 sv = GvSVn((GV*)sv);
3466 goto do_AV_vivify_rv2av_aelem;
3467
3468 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
3469 sv = PAD_SVl((++items)->pad_offset);
3470 /* FALLTHROUGH */
3471
3472 do_AV_vivify_rv2av_aelem:
3473 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
3474 /* this is the OPpDEREF action normally found at the end of
3475 * ops like aelem, helem, rv2sv */
3476 sv = vivify_ref(sv, OPpDEREF_AV);
3477 /* FALLTHROUGH */
3478
3479 do_AV_rv2av_aelem:
3480 /* this is basically a copy of pp_rv2av when it just has the
3481 * sKR/1 flags */
3482 SvGETMAGIC(sv);
3483 if (LIKELY(SvROK(sv))) {
3484 if (UNLIKELY(SvAMAGIC(sv))) {
3485 sv = amagic_deref_call(sv, to_av_amg);
3486 }
3487 sv = SvRV(sv);
3488 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
3489 DIE(aTHX_ "Not an ARRAY reference");
3490 }
3491 else if (SvTYPE(sv) != SVt_PVAV) {
3492 if (!isGV_with_GP(sv))
3493 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
3494 sv = MUTABLE_SV(GvAVn((GV*)sv));
3495 }
3496 /* FALLTHROUGH */
3497
3498 do_AV_aelem:
3499 {
3500 /* retrieve the key; this may be either a lexical or package
3501 * var (whose index/ptr is stored as an item) or a signed
3502 * integer constant stored as an item.
3503 */
3504 SV *elemsv;
3505 IV elem = 0; /* to shut up stupid compiler warnings */
3506
3507
3508 assert(SvTYPE(sv) == SVt_PVAV);
3509
3510 switch (actions & MDEREF_INDEX_MASK) {
3511 case MDEREF_INDEX_none:
3512 goto finish;
3513 case MDEREF_INDEX_const:
3514 elem = (++items)->iv;
3515 break;
3516 case MDEREF_INDEX_padsv:
3517 elemsv = PAD_SVl((++items)->pad_offset);
3518 goto check_elem;
3519 case MDEREF_INDEX_gvsv:
3520 elemsv = UNOP_AUX_item_sv(++items);
3521 assert(isGV_with_GP(elemsv));
3522 elemsv = GvSVn((GV*)elemsv);
3523 check_elem:
3524 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
3525 && ckWARN(WARN_MISC)))
3526 Perl_warner(aTHX_ packWARN(WARN_MISC),
147e3846 3527 "Use of reference \"%" SVf "\" as array index",
fedf30e1
DM
3528 SVfARG(elemsv));
3529 /* the only time that S_find_uninit_var() needs this
3530 * is to determine which index value triggered the
3531 * undef warning. So just update it here. Note that
3532 * since we don't save and restore this var (e.g. for
3533 * tie or overload execution), its value will be
3534 * meaningless apart from just here */
3535 PL_multideref_pc = items;
3536 elem = SvIV(elemsv);
3537 break;
3538 }
3539
3540
3541 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
3542
3543 if (!(actions & MDEREF_FLAG_last)) {
3544 SV** svp = av_fetch((AV*)sv, elem, 1);
3545 if (!svp || ! (sv=*svp))
3546 DIE(aTHX_ PL_no_aelem, elem);
3547 break;
3548 }
3549
3550 if (PL_op->op_private &
3551 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3552 {
3553 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3554 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
3555 }
3556 else {
3557 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3558 sv = av_delete((AV*)sv, elem, discard);
3559 if (discard)
3560 return NORMAL;
3561 if (!sv)
3562 sv = &PL_sv_undef;
3563 }
3564 }
3565 else {
3566 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3567 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3568 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3569 bool preeminent = TRUE;
3570 AV *const av = (AV*)sv;
3571 SV** svp;
3572
3573 if (UNLIKELY(localizing)) {
3574 MAGIC *mg;
3575 HV *stash;
3576
3577 /* If we can determine whether the element exist,
3578 * Try to preserve the existenceness of a tied array
3579 * element by using EXISTS and DELETE if possible.
3580 * Fallback to FETCH and STORE otherwise. */
3581 if (SvCANEXISTDELETE(av))
3582 preeminent = av_exists(av, elem);
3583 }
3584
3585 svp = av_fetch(av, elem, lval && !defer);
3586
3587 if (lval) {
3588 if (!svp || !(sv = *svp)) {
3589 IV len;
3590 if (!defer)
3591 DIE(aTHX_ PL_no_aelem, elem);
3592 len = av_tindex(av);
9ef753fe
FC
3593 /* Resolve a negative index that falls within
3594 * the array. Leave it negative it if falls
3595 * outside the array. */
3596 if (elem < 0 && len + elem >= 0)
3597 elem = len + elem;
3598 if (elem >= 0 && elem <= len)
3599 /* Falls within the array. */
3600 sv = av_nonelem(av,elem);
3601 else
3602 /* Falls outside the array. If it is neg-
3603 ative, magic_setdefelem will use the
3604 index for error reporting. */
3605 sv = sv_2mortal(newSVavdefelem(av,elem,1));
fedf30e1
DM
3606 }
3607 else {
3608 if (UNLIKELY(localizing)) {
3609 if (preeminent) {
3610 save_aelem(av, elem, svp);
3611 sv = *svp; /* may have changed */
3612 }
3613 else
3614 SAVEADELETE(av, elem);
3615 }
3616 }
3617 }
3618 else {
3619 sv = (svp ? *svp : &PL_sv_undef);
3620 /* see note in pp_helem() */
3621 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
3622 mg_get(sv);
3623 }
3624 }
3625
3626 }
3627 finish:
3628 {
3629 dSP;
3630 XPUSHs(sv);
3631 RETURN;
3632 }
3633 /* NOTREACHED */
3634
3635
3636
3637
3638 case MDEREF_HV_padhv_helem: /* $lex{...} */
3639 sv = PAD_SVl((++items)->pad_offset);
3640 goto do_HV_helem;
3641
3642 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
3643 sv = UNOP_AUX_item_sv(++items);
3644 assert(isGV_with_GP(sv));
3645 sv = (SV*)GvHVn((GV*)sv);
3646 goto do_HV_helem;
3647
3648 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
3649 {
3650 dSP;
3651 sv = POPs;
3652 PUTBACK;
3653 goto do_HV_rv2hv_helem;
3654 }
3655
3656 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
3657 sv = UNOP_AUX_item_sv(++items);
3658 assert(isGV_with_GP(sv));
3659 sv = GvSVn((GV*)sv);
3660 goto do_HV_vivify_rv2hv_helem;
3661
3662 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
3663 sv = PAD_SVl((++items)->pad_offset);
3664 /* FALLTHROUGH */
3665
3666 do_HV_vivify_rv2hv_helem:
3667 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
3668 /* this is the OPpDEREF action normally found at the end of
3669 * ops like aelem, helem, rv2sv */
3670 sv = vivify_ref(sv, OPpDEREF_HV);
3671 /* FALLTHROUGH */
3672
3673 do_HV_rv2hv_helem:
3674 /* this is basically a copy of pp_rv2hv when it just has the
3675 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
3676
3677 SvGETMAGIC(sv);
3678 if (LIKELY(SvROK(sv))) {
3679 if (UNLIKELY(SvAMAGIC(sv))) {
3680 sv = amagic_deref_call(sv, to_hv_amg);
3681 }
3682 sv = SvRV(sv);
3683 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
3684 DIE(aTHX_ "Not a HASH reference");
3685 }
3686 else if (SvTYPE(sv) != SVt_PVHV) {
3687 if (!isGV_with_GP(sv))
3688 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
3689 sv = MUTABLE_SV(GvHVn((GV*)sv));
3690 }
3691 /* FALLTHROUGH */
3692
3693 do_HV_helem:
3694 {
3695 /* retrieve the key; this may be either a lexical / package
3696 * var or a string constant, whose index/ptr is stored as an
3697 * item
3698 */
3699 SV *keysv = NULL; /* to shut up stupid compiler warnings */
3700
3701 assert(SvTYPE(sv) == SVt_PVHV);
3702
3703 switch (actions & MDEREF_INDEX_MASK) {
3704 case MDEREF_INDEX_none:
3705 goto finish;
3706
3707 case MDEREF_INDEX_const:
3708 keysv = UNOP_AUX_item_sv(++items);
3709 break;
3710
3711 case MDEREF_INDEX_padsv:
3712 keysv = PAD_SVl((++items)->pad_offset);
3713 break;
3714
3715 case MDEREF_INDEX_gvsv:
3716 keysv = UNOP_AUX_item_sv(++items);
3717 keysv = GvSVn((GV*)keysv);
3718 break;
3719 }
3720
3721 /* see comment above about setting this var */
3722 PL_multideref_pc = items;
3723
3724
3725 /* ensure that candidate CONSTs have been HEKified */
3726 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
3727 || SvTYPE(keysv) >= SVt_PVMG
3728 || !SvOK(keysv)
3729 || SvROK(keysv)
3730 || SvIsCOW_shared_hash(keysv));
3731
3732 /* this is basically a copy of pp_helem with OPpDEREF skipped */
3733
3734 if (!(actions & MDEREF_FLAG_last)) {
3735 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
3736 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
3737 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3738 break;
3739 }
3740
3741 if (PL_op->op_private &
3742 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3743 {
3744 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3745 sv = hv_exists_ent((HV*)sv, keysv, 0)
3746 ? &PL_sv_yes : &PL_sv_no;
3747 }
3748 else {
3749 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3750 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
3751 if (discard)
3752 return NORMAL;
3753 if (!sv)
3754 sv = &PL_sv_undef;
3755 }
3756 }
3757 else {
3758 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3759 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3760 const boo