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