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