This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix SET_NUMERIC_STANDARD, _UNDERLYING spelling
[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;
ff2a62e0 50 PL_sawalias = 0;
a0d0e21e 51 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 52 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 53 FREETMPS;
f410a211 54 PERL_ASYNC_CHECK();
a0d0e21e
LW
55 return NORMAL;
56}
57
58PP(pp_gvsv)
59{
39644a26 60 dSP;
924508f0 61 EXTEND(SP,1);
5d9574c1 62 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
1d7c1841 63 PUSHs(save_scalar(cGVOP_gv));
a0d0e21e 64 else
c69033f2 65 PUSHs(GvSVn(cGVOP_gv));
ff2a62e0
FC
66 if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))
67 PL_sawalias = TRUE;
a0d0e21e
LW
68 RETURN;
69}
70
b1c05ba5
DM
71
72/* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
73
a0d0e21e
LW
74PP(pp_null)
75{
76 return NORMAL;
77}
78
3dd9d4e4
FC
79/* This is sometimes called directly by pp_coreargs, pp_grepstart and
80 amagic_call. */
a0d0e21e
LW
81PP(pp_pushmark)
82{
3280af22 83 PUSHMARK(PL_stack_sp);
a0d0e21e
LW
84 return NORMAL;
85}
86
87PP(pp_stringify)
88{
20b7effb 89 dSP; dTARGET;
4cc783ef
DD
90 SV * const sv = TOPs;
91 SETs(TARG);
92 sv_copypv(TARG, sv);
93 SvSETMAGIC(TARG);
94 /* no PUTBACK, SETs doesn't inc/dec SP */
95 return NORMAL;
a0d0e21e
LW
96}
97
98PP(pp_gv)
99{
20b7effb 100 dSP;
ad64d0ec 101 XPUSHs(MUTABLE_SV(cGVOP_gv));
ff2a62e0
FC
102 if (isGV(cGVOP_gv)
103 && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
104 PL_sawalias = TRUE;
a0d0e21e
LW
105 RETURN;
106}
107
b1c05ba5
DM
108
109/* also used for: pp_andassign() */
110
a0d0e21e
LW
111PP(pp_and)
112{
f410a211 113 PERL_ASYNC_CHECK();
4cc783ef
DD
114 {
115 /* SP is not used to remove a variable that is saved across the
116 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
117 register or load/store vs direct mem ops macro is introduced, this
118 should be a define block between direct PL_stack_sp and dSP operations,
119 presently, using PL_stack_sp is bias towards CISC cpus */
120 SV * const sv = *PL_stack_sp;
121 if (!SvTRUE_NN(sv))
122 return NORMAL;
123 else {
124 if (PL_op->op_type == OP_AND)
125 --PL_stack_sp;
126 return cLOGOP->op_other;
127 }
a0d0e21e
LW
128 }
129}
130
131PP(pp_sassign)
132{
20b7effb 133 dSP;
3e75a3c4
RU
134 /* sassign keeps its args in the optree traditionally backwards.
135 So we pop them differently.
136 */
137 SV *left = POPs; SV *right = TOPs;
748a9306 138
533c011a 139 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
0bd48802
AL
140 SV * const temp = left;
141 left = right; right = temp;
a0d0e21e 142 }
5d9574c1 143 if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
a0d0e21e 144 TAINT_NOT;
5d9574c1
DM
145 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
146 /* *foo =\&bar */
3e75a3c4 147 SV * const cv = SvRV(right);
e26df76a 148 const U32 cv_type = SvTYPE(cv);
3e75a3c4 149 const bool is_gv = isGV_with_GP(left);
6136c704 150 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
e26df76a
NC
151
152 if (!got_coderef) {
153 assert(SvROK(cv));
154 }
155
3e75a3c4
RU
156 /* Can do the optimisation if left (LVALUE) is not a typeglob,
157 right (RVALUE) is a reference to something, and we're in void
e26df76a 158 context. */
13be902c 159 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
e26df76a 160 /* Is the target symbol table currently empty? */
3e75a3c4 161 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
bb112e5a 162 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
e26df76a
NC
163 /* Good. Create a new proxy constant subroutine in the target.
164 The gv becomes a(nother) reference to the constant. */
165 SV *const value = SvRV(cv);
166
ad64d0ec 167 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
1ccdb730 168 SvPCS_IMPORTED_on(gv);
e26df76a 169 SvRV_set(gv, value);
b37c2d43 170 SvREFCNT_inc_simple_void(value);
3e75a3c4 171 SETs(left);
e26df76a
NC
172 RETURN;
173 }
174 }
175
176 /* Need to fix things up. */
13be902c 177 if (!is_gv) {
e26df76a 178 /* Need to fix GV. */
3e75a3c4 179 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
e26df76a
NC
180 }
181
182 if (!got_coderef) {
183 /* We've been returned a constant rather than a full subroutine,
184 but they expect a subroutine reference to apply. */
53a42478 185 if (SvROK(cv)) {
d343c3ef 186 ENTER_with_name("sassign_coderef");
53a42478
NC
187 SvREFCNT_inc_void(SvRV(cv));
188 /* newCONSTSUB takes a reference count on the passed in SV
189 from us. We set the name to NULL, otherwise we get into
190 all sorts of fun as the reference to our new sub is
191 donated to the GV that we're about to assign to.
192 */
3e75a3c4 193 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
ad64d0ec 194 SvRV(cv))));
fc2b2dca 195 SvREFCNT_dec_NN(cv);
d343c3ef 196 LEAVE_with_name("sassign_coderef");
53a42478
NC
197 } else {
198 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
199 is that
200 First: ops for \&{"BONK"}; return us the constant in the
201 symbol table
202 Second: ops for *{"BONK"} cause that symbol table entry
203 (and our reference to it) to be upgraded from RV
204 to typeblob)
205 Thirdly: We get here. cv is actually PVGV now, and its
206 GvCV() is actually the subroutine we're looking for
207
208 So change the reference so that it points to the subroutine
209 of that typeglob, as that's what they were after all along.
210 */
159b6efe 211 GV *const upgraded = MUTABLE_GV(cv);
53a42478
NC
212 CV *const source = GvCV(upgraded);
213
214 assert(source);
215 assert(CvFLAGS(source) & CVf_CONST);
216
217 SvREFCNT_inc_void(source);
fc2b2dca 218 SvREFCNT_dec_NN(upgraded);
3e75a3c4 219 SvRV_set(right, MUTABLE_SV(source));
53a42478 220 }
e26df76a 221 }
53a42478 222
e26df76a 223 }
8fe85e3f 224 if (
5d9574c1 225 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
3e75a3c4 226 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
8fe85e3f
FC
227 )
228 Perl_warner(aTHX_
229 packWARN(WARN_MISC), "Useless assignment to a temporary"
230 );
3e75a3c4
RU
231 SvSetMagicSV(left, right);
232 SETs(left);
a0d0e21e
LW
233 RETURN;
234}
235
236PP(pp_cond_expr)
237{
20b7effb 238 dSP;
f410a211 239 PERL_ASYNC_CHECK();
a0d0e21e 240 if (SvTRUEx(POPs))
1a67a97c 241 RETURNOP(cLOGOP->op_other);
a0d0e21e 242 else
1a67a97c 243 RETURNOP(cLOGOP->op_next);
a0d0e21e
LW
244}
245
246PP(pp_unstack)
247{
8f3964af 248 PERL_ASYNC_CHECK();
a0d0e21e 249 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 250 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 251 FREETMPS;
eae48c89
Z
252 if (!(PL_op->op_flags & OPf_SPECIAL)) {
253 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
254 LEAVE_SCOPE(oldsave);
255 }
a0d0e21e
LW
256 return NORMAL;
257}
258
a0d0e21e
LW
259PP(pp_concat)
260{
20b7effb 261 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
748a9306
LW
262 {
263 dPOPTOPssrl;
8d6d96c1
HS
264 bool lbyte;
265 STRLEN rlen;
d4c19fe8 266 const char *rpv = NULL;
a6b599c7 267 bool rbyte = FALSE;
a9c4fd4e 268 bool rcopied = FALSE;
8d6d96c1 269
6f1401dc
DM
270 if (TARG == right && right != left) { /* $r = $l.$r */
271 rpv = SvPV_nomg_const(right, rlen);
c75ab21a 272 rbyte = !DO_UTF8(right);
59cd0e26 273 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
349d4f2f 274 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
db79b45b 275 rcopied = TRUE;
8d6d96c1 276 }
7889fe52 277
89734059 278 if (TARG != left) { /* not $l .= $r */
a9c4fd4e 279 STRLEN llen;
6f1401dc 280 const char* const lpv = SvPV_nomg_const(left, llen);
90f5826e 281 lbyte = !DO_UTF8(left);
8d6d96c1
HS
282 sv_setpvn(TARG, lpv, llen);
283 if (!lbyte)
284 SvUTF8_on(TARG);
285 else
286 SvUTF8_off(TARG);
287 }
18ea7bf2
SM
288 else { /* $l .= $r and left == TARG */
289 if (!SvOK(left)) {
89734059 290 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
c75ab21a 291 report_uninit(right);
76f68e9b 292 sv_setpvs(left, "");
c75ab21a 293 }
18ea7bf2
SM
294 else {
295 SvPV_force_nomg_nolen(left);
296 }
583a5589 297 lbyte = !DO_UTF8(left);
90f5826e 298 if (IN_BYTES)
18ea7bf2 299 SvUTF8_off(left);
8d6d96c1 300 }
a12c0f56 301
c75ab21a 302 if (!rcopied) {
6f1401dc 303 rpv = SvPV_nomg_const(right, rlen);
c75ab21a
RH
304 rbyte = !DO_UTF8(right);
305 }
8d6d96c1
HS
306 if (lbyte != rbyte) {
307 if (lbyte)
308 sv_utf8_upgrade_nomg(TARG);
309 else {
db79b45b 310 if (!rcopied)
59cd0e26 311 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
8d6d96c1 312 sv_utf8_upgrade_nomg(right);
6f1401dc 313 rpv = SvPV_nomg_const(right, rlen);
69b47968 314 }
a0d0e21e 315 }
8d6d96c1 316 sv_catpvn_nomg(TARG, rpv, rlen);
43ebc500 317
a0d0e21e
LW
318 SETTARG;
319 RETURN;
748a9306 320 }
a0d0e21e
LW
321}
322
d5524600
DM
323/* push the elements of av onto the stack.
324 * XXX Note that padav has similar code but without the mg_get().
325 * I suspect that the mg_get is no longer needed, but while padav
326 * differs, it can't share this function */
327
f9ae8fb6 328STATIC void
d5524600
DM
329S_pushav(pTHX_ AV* const av)
330{
331 dSP;
c70927a6 332 const SSize_t maxarg = AvFILL(av) + 1;
d5524600 333 EXTEND(SP, maxarg);
5d9574c1 334 if (UNLIKELY(SvRMAGICAL(av))) {
c70927a6
FC
335 PADOFFSET i;
336 for (i=0; i < (PADOFFSET)maxarg; i++) {
d5524600
DM
337 SV ** const svp = av_fetch(av, i, FALSE);
338 /* See note in pp_helem, and bug id #27839 */
339 SP[i+1] = svp
340 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
341 : &PL_sv_undef;
342 }
343 }
344 else {
c70927a6
FC
345 PADOFFSET i;
346 for (i=0; i < (PADOFFSET)maxarg; i++) {
ce0d59fd 347 SV * const sv = AvARRAY(av)[i];
5d9574c1 348 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
ce0d59fd 349 }
d5524600
DM
350 }
351 SP += maxarg;
352 PUTBACK;
353}
354
355
a7fd8ef6
DM
356/* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
357
358PP(pp_padrange)
359{
20b7effb 360 dSP;
a7fd8ef6
DM
361 PADOFFSET base = PL_op->op_targ;
362 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
363 int i;
d5524600
DM
364 if (PL_op->op_flags & OPf_SPECIAL) {
365 /* fake the RHS of my ($x,$y,..) = @_ */
366 PUSHMARK(SP);
367 S_pushav(aTHX_ GvAVn(PL_defgv));
368 SPAGAIN;
369 }
370
a7fd8ef6
DM
371 /* note, this is only skipped for compile-time-known void cxt */
372 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
373 EXTEND(SP, count);
374 PUSHMARK(SP);
375 for (i = 0; i <count; i++)
376 *++SP = PAD_SV(base+i);
377 }
378 if (PL_op->op_private & OPpLVAL_INTRO) {
4e09461c
DM
379 SV **svp = &(PAD_SVl(base));
380 const UV payload = (UV)(
381 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
382 | (count << SAVE_TIGHT_SHIFT)
383 | SAVEt_CLEARPADRANGE);
6d59e610 384 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
4e09461c 385 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
a3444cc5
DM
386 {
387 dSS_ADD;
388 SS_ADD_UV(payload);
389 SS_ADD_END(1);
390 }
4e09461c 391
a7fd8ef6 392 for (i = 0; i <count; i++)
4e09461c 393 SvPADSTALE_off(*svp++); /* mark lexical as active */
a7fd8ef6
DM
394 }
395 RETURN;
396}
397
398
a0d0e21e
LW
399PP(pp_padsv)
400{
20b7effb 401 dSP;
6c28b496
DD
402 EXTEND(SP, 1);
403 {
404 OP * const op = PL_op;
405 /* access PL_curpad once */
406 SV ** const padentry = &(PAD_SVl(op->op_targ));
407 {
408 dTARG;
409 TARG = *padentry;
410 PUSHs(TARG);
411 PUTBACK; /* no pop/push after this, TOPs ok */
8ec5e241 412 }
6c28b496
DD
413 if (op->op_flags & OPf_MOD) {
414 if (op->op_private & OPpLVAL_INTRO)
415 if (!(op->op_private & OPpPAD_STATE))
416 save_clearsv(padentry);
417 if (op->op_private & OPpDEREF) {
8f90a16d
FC
418 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
419 than TARG reduces the scope of TARG, so it does not
420 span the call to save_clearsv, resulting in smaller
421 machine code. */
6c28b496
DD
422 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
423 }
424 }
425 return op->op_next;
4633a7c4 426 }
a0d0e21e
LW
427}
428
429PP(pp_readline)
430{
30901a8a
FC
431 dSP;
432 if (TOPs) {
433 SvGETMAGIC(TOPs);
fc99edcf 434 tryAMAGICunTARGETlist(iter_amg, 0);
30901a8a
FC
435 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
436 }
437 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
6e592b3a
BM
438 if (!isGV_with_GP(PL_last_in_gv)) {
439 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
159b6efe 440 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
8efb3254 441 else {
f5284f61 442 dSP;
ad64d0ec 443 XPUSHs(MUTABLE_SV(PL_last_in_gv));
f5284f61 444 PUTBACK;
897d3989 445 Perl_pp_rv2gv(aTHX);
159b6efe 446 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
84ee769f
FC
447 if (PL_last_in_gv == (GV *)&PL_sv_undef)
448 PL_last_in_gv = NULL;
449 else
450 assert(isGV_with_GP(PL_last_in_gv));
f5284f61
IZ
451 }
452 }
a0d0e21e
LW
453 return do_readline();
454}
455
456PP(pp_eq)
457{
20b7effb 458 dSP;
33efebe6
DM
459 SV *left, *right;
460
a42d0242 461 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
462 right = POPs;
463 left = TOPs;
464 SETs(boolSV(
465 (SvIOK_notUV(left) && SvIOK_notUV(right))
466 ? (SvIVX(left) == SvIVX(right))
467 : ( do_ncmp(left, right) == 0)
468 ));
469 RETURN;
a0d0e21e
LW
470}
471
b1c05ba5
DM
472
473/* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
474
a0d0e21e
LW
475PP(pp_preinc)
476{
20b7effb 477 dSP;
17058fe0
FC
478 const bool inc =
479 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
5d9574c1 480 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
cb077ed2 481 Perl_croak_no_modify();
5d9574c1 482 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
17058fe0 483 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
55497cff 484 {
17058fe0 485 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
55497cff 486 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 487 }
28e5dec8 488 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
17058fe0
FC
489 if (inc) sv_inc(TOPs);
490 else sv_dec(TOPs);
a0d0e21e
LW
491 SvSETMAGIC(TOPs);
492 return NORMAL;
493}
494
b1c05ba5
DM
495
496/* also used for: pp_orassign() */
497
a0d0e21e
LW
498PP(pp_or)
499{
20b7effb 500 dSP;
f410a211 501 PERL_ASYNC_CHECK();
a0d0e21e
LW
502 if (SvTRUE(TOPs))
503 RETURN;
504 else {
c960fc3b
SP
505 if (PL_op->op_type == OP_OR)
506 --SP;
a0d0e21e
LW
507 RETURNOP(cLOGOP->op_other);
508 }
509}
510
b1c05ba5
DM
511
512/* also used for: pp_dor() pp_dorassign() */
513
25a55bd7 514PP(pp_defined)
c963b151 515{
20b7effb 516 dSP;
eb578fdb 517 SV* sv;
6136c704 518 bool defined;
25a55bd7 519 const int op_type = PL_op->op_type;
ea5195b7 520 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
c963b151 521
6136c704 522 if (is_dor) {
f410a211 523 PERL_ASYNC_CHECK();
25a55bd7 524 sv = TOPs;
5d9574c1 525 if (UNLIKELY(!sv || !SvANY(sv))) {
2bd49cfc
NC
526 if (op_type == OP_DOR)
527 --SP;
25a55bd7
SP
528 RETURNOP(cLOGOP->op_other);
529 }
b7c44293
RGS
530 }
531 else {
532 /* OP_DEFINED */
25a55bd7 533 sv = POPs;
5d9574c1 534 if (UNLIKELY(!sv || !SvANY(sv)))
25a55bd7 535 RETPUSHNO;
b7c44293 536 }
25a55bd7 537
6136c704 538 defined = FALSE;
c963b151
BD
539 switch (SvTYPE(sv)) {
540 case SVt_PVAV:
541 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 542 defined = TRUE;
c963b151
BD
543 break;
544 case SVt_PVHV:
545 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 546 defined = TRUE;
c963b151
BD
547 break;
548 case SVt_PVCV:
549 if (CvROOT(sv) || CvXSUB(sv))
25a55bd7 550 defined = TRUE;
c963b151
BD
551 break;
552 default:
5b295bef 553 SvGETMAGIC(sv);
c963b151 554 if (SvOK(sv))
25a55bd7 555 defined = TRUE;
6136c704 556 break;
c963b151 557 }
6136c704
AL
558
559 if (is_dor) {
c960fc3b
SP
560 if(defined)
561 RETURN;
562 if(op_type == OP_DOR)
563 --SP;
25a55bd7 564 RETURNOP(cLOGOP->op_other);
25a55bd7 565 }
d9aa96a4
SP
566 /* assuming OP_DEFINED */
567 if(defined)
568 RETPUSHYES;
569 RETPUSHNO;
c963b151
BD
570}
571
a0d0e21e
LW
572PP(pp_add)
573{
20b7effb 574 dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
575 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
576 svr = TOPs;
577 svl = TOPm1s;
578
800401ee 579 useleft = USE_LEFT(svl);
28e5dec8
JH
580#ifdef PERL_PRESERVE_IVUV
581 /* We must see if we can perform the addition with integers if possible,
582 as the integer code detects overflow while the NV code doesn't.
583 If either argument hasn't had a numeric conversion yet attempt to get
584 the IV. It's important to do this now, rather than just assuming that
585 it's not IOK as a PV of "9223372036854775806" may not take well to NV
586 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
587 integer in case the second argument is IV=9223372036854775806
588 We can (now) rely on sv_2iv to do the right thing, only setting the
589 public IOK flag if the value in the NV (or PV) slot is truly integer.
590
591 A side effect is that this also aggressively prefers integer maths over
7dca457a
NC
592 fp maths for integer values.
593
a00b5bd3 594 How to detect overflow?
7dca457a
NC
595
596 C 99 section 6.2.6.1 says
597
598 The range of nonnegative values of a signed integer type is a subrange
599 of the corresponding unsigned integer type, and the representation of
600 the same value in each type is the same. A computation involving
601 unsigned operands can never overflow, because a result that cannot be
602 represented by the resulting unsigned integer type is reduced modulo
603 the number that is one greater than the largest value that can be
604 represented by the resulting type.
605
606 (the 9th paragraph)
607
608 which I read as "unsigned ints wrap."
609
610 signed integer overflow seems to be classed as "exception condition"
611
612 If an exceptional condition occurs during the evaluation of an
613 expression (that is, if the result is not mathematically defined or not
614 in the range of representable values for its type), the behavior is
615 undefined.
616
617 (6.5, the 5th paragraph)
618
619 I had assumed that on 2s complement machines signed arithmetic would
620 wrap, hence coded pp_add and pp_subtract on the assumption that
621 everything perl builds on would be happy. After much wailing and
622 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
623 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
624 unsigned code below is actually shorter than the old code. :-)
625 */
626
01f91bf2 627 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
628 /* Unless the left argument is integer in range we are going to have to
629 use NV maths. Hence only attempt to coerce the right argument if
630 we know the left is integer. */
eb578fdb 631 UV auv = 0;
9c5ffd7c 632 bool auvok = FALSE;
7dca457a
NC
633 bool a_valid = 0;
634
28e5dec8 635 if (!useleft) {
7dca457a
NC
636 auv = 0;
637 a_valid = auvok = 1;
638 /* left operand is undef, treat as zero. + 0 is identity,
639 Could SETi or SETu right now, but space optimise by not adding
640 lots of code to speed up what is probably a rarish case. */
641 } else {
642 /* Left operand is defined, so is it IV? */
01f91bf2 643 if (SvIV_please_nomg(svl)) {
800401ee
JH
644 if ((auvok = SvUOK(svl)))
645 auv = SvUVX(svl);
7dca457a 646 else {
eb578fdb 647 const IV aiv = SvIVX(svl);
7dca457a
NC
648 if (aiv >= 0) {
649 auv = aiv;
650 auvok = 1; /* Now acting as a sign flag. */
53e2bfb7
DM
651 } else {
652 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
7dca457a
NC
653 }
654 }
655 a_valid = 1;
28e5dec8
JH
656 }
657 }
7dca457a
NC
658 if (a_valid) {
659 bool result_good = 0;
660 UV result;
eb578fdb 661 UV buv;
800401ee 662 bool buvok = SvUOK(svr);
a00b5bd3 663
7dca457a 664 if (buvok)
800401ee 665 buv = SvUVX(svr);
7dca457a 666 else {
eb578fdb 667 const IV biv = SvIVX(svr);
7dca457a
NC
668 if (biv >= 0) {
669 buv = biv;
670 buvok = 1;
671 } else
53e2bfb7 672 buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
7dca457a
NC
673 }
674 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 675 else "IV" now, independent of how it came in.
7dca457a
NC
676 if a, b represents positive, A, B negative, a maps to -A etc
677 a + b => (a + b)
678 A + b => -(a - b)
679 a + B => (a - b)
680 A + B => -(a + b)
681 all UV maths. negate result if A negative.
682 add if signs same, subtract if signs differ. */
683
684 if (auvok ^ buvok) {
685 /* Signs differ. */
686 if (auv >= buv) {
687 result = auv - buv;
688 /* Must get smaller */
689 if (result <= auv)
690 result_good = 1;
691 } else {
692 result = buv - auv;
693 if (result <= buv) {
694 /* result really should be -(auv-buv). as its negation
695 of true value, need to swap our result flag */
696 auvok = !auvok;
697 result_good = 1;
28e5dec8
JH
698 }
699 }
7dca457a
NC
700 } else {
701 /* Signs same */
702 result = auv + buv;
703 if (result >= auv)
704 result_good = 1;
705 }
706 if (result_good) {
707 SP--;
708 if (auvok)
28e5dec8 709 SETu( result );
7dca457a
NC
710 else {
711 /* Negate result */
712 if (result <= (UV)IV_MIN)
53e2bfb7
DM
713 SETi(result == (UV)IV_MIN
714 ? IV_MIN : -(IV)result);
7dca457a
NC
715 else {
716 /* result valid, but out of range for IV. */
717 SETn( -(NV)result );
28e5dec8
JH
718 }
719 }
7dca457a
NC
720 RETURN;
721 } /* Overflow, drop through to NVs. */
28e5dec8
JH
722 }
723 }
724#endif
a0d0e21e 725 {
6f1401dc 726 NV value = SvNV_nomg(svr);
4efa5a16 727 (void)POPs;
28e5dec8
JH
728 if (!useleft) {
729 /* left operand is undef, treat as zero. + 0.0 is identity. */
730 SETn(value);
731 RETURN;
732 }
6f1401dc 733 SETn( value + SvNV_nomg(svl) );
28e5dec8 734 RETURN;
a0d0e21e
LW
735 }
736}
737
b1c05ba5
DM
738
739/* also used for: pp_aelemfast_lex() */
740
a0d0e21e
LW
741PP(pp_aelemfast)
742{
20b7effb 743 dSP;
93bad3fd 744 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
8f878375 745 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
a3b680e6 746 const U32 lval = PL_op->op_flags & OPf_MOD;
b024352e 747 SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
3280af22 748 SV *sv = (svp ? *svp : &PL_sv_undef);
b024352e
DM
749
750 if (UNLIKELY(!svp && lval))
751 DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
752
6ff81951 753 EXTEND(SP, 1);
39cf747a 754 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 755 mg_get(sv);
be6c24e0 756 PUSHs(sv);
a0d0e21e
LW
757 RETURN;
758}
759
760PP(pp_join)
761{
20b7effb 762 dSP; dMARK; dTARGET;
a0d0e21e
LW
763 MARK++;
764 do_join(TARG, *MARK, MARK, SP);
765 SP = MARK;
766 SETs(TARG);
767 RETURN;
768}
769
770PP(pp_pushre)
771{
20b7effb 772 dSP;
44a8e56a
PP
773#ifdef DEBUGGING
774 /*
775 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
776 * will be enough to hold an OP*.
777 */
c4420975 778 SV* const sv = sv_newmortal();
44a8e56a
PP
779 sv_upgrade(sv, SVt_PVLV);
780 LvTYPE(sv) = '/';
533c011a 781 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
44a8e56a
PP
782 XPUSHs(sv);
783#else
ad64d0ec 784 XPUSHs(MUTABLE_SV(PL_op));
44a8e56a 785#endif
a0d0e21e
LW
786 RETURN;
787}
788
789/* Oversized hot code. */
790
b1c05ba5
DM
791/* also used for: pp_say() */
792
a0d0e21e
LW
793PP(pp_print)
794{
20b7effb 795 dSP; dMARK; dORIGMARK;
eb578fdb 796 PerlIO *fp;
236988e4 797 MAGIC *mg;
159b6efe
NC
798 GV * const gv
799 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 800 IO *io = GvIO(gv);
5b468f54 801
9c9f25b8 802 if (io
ad64d0ec 803 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 804 {
01bb7c6d 805 had_magic:
68dc0745 806 if (MARK == ORIGMARK) {
1c846c1f 807 /* If using default handle then we need to make space to
a60c0954
NIS
808 * pass object as 1st arg, so move other args up ...
809 */
4352c267 810 MEXTEND(SP, 1);
68dc0745
PP
811 ++MARK;
812 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
813 ++SP;
814 }
3e0cb5de 815 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
94bc412f
NC
816 mg,
817 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
818 | (PL_op->op_type == OP_SAY
819 ? TIED_METHOD_SAY : 0)), sp - mark);
236988e4 820 }
9c9f25b8 821 if (!io) {
68b590d9 822 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
ad64d0ec 823 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 824 goto had_magic;
51087808 825 report_evil_fh(gv);
93189314 826 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
827 goto just_say_no;
828 }
829 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
830 if (IoIFP(io))
831 report_wrongway_fh(gv, '<');
51087808 832 else
7716c5c5 833 report_evil_fh(gv);
93189314 834 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
835 goto just_say_no;
836 }
837 else {
e23d9e2f 838 SV * const ofs = GvSV(PL_ofsgv); /* $, */
a0d0e21e 839 MARK++;
e23d9e2f 840 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
a0d0e21e
LW
841 while (MARK <= SP) {
842 if (!do_print(*MARK, fp))
843 break;
844 MARK++;
845 if (MARK <= SP) {
e23d9e2f
CS
846 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
847 if (!do_print(GvSV(PL_ofsgv), fp)) {
a0d0e21e
LW
848 MARK--;
849 break;
850 }
851 }
852 }
853 }
854 else {
855 while (MARK <= SP) {
856 if (!do_print(*MARK, fp))
857 break;
858 MARK++;
859 }
860 }
861 if (MARK <= SP)
862 goto just_say_no;
863 else {
cfc4a7da
GA
864 if (PL_op->op_type == OP_SAY) {
865 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
866 goto just_say_no;
867 }
868 else if (PL_ors_sv && SvOK(PL_ors_sv))
7889fe52 869 if (!do_print(PL_ors_sv, fp)) /* $\ */
a0d0e21e
LW
870 goto just_say_no;
871
872 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 873 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
874 goto just_say_no;
875 }
876 }
877 SP = ORIGMARK;
e52fd6f4 878 XPUSHs(&PL_sv_yes);
a0d0e21e
LW
879 RETURN;
880
881 just_say_no:
882 SP = ORIGMARK;
e52fd6f4 883 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
884 RETURN;
885}
886
b1c05ba5
DM
887
888/* also used for: pp_rv2hv() */
bdaf10a5 889/* also called directly by pp_lvavref */
b1c05ba5 890
a0d0e21e
LW
891PP(pp_rv2av)
892{
20b7effb 893 dSP; dTOPss;
cde874ca 894 const I32 gimme = GIMME_V;
13c59d41
MH
895 static const char an_array[] = "an ARRAY";
896 static const char a_hash[] = "a HASH";
bdaf10a5
FC
897 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
898 || PL_op->op_type == OP_LVAVREF;
d83b45b8 899 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 900
9026059d 901 SvGETMAGIC(sv);
a0d0e21e 902 if (SvROK(sv)) {
5d9574c1 903 if (UNLIKELY(SvAMAGIC(sv))) {
93d7320b 904 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
93d7320b 905 }
17ab7946 906 sv = SvRV(sv);
5d9574c1 907 if (UNLIKELY(SvTYPE(sv) != type))
dcbac5bb 908 /* diag_listed_as: Not an ARRAY reference */
13c59d41 909 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
5d9574c1
DM
910 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
911 && PL_op->op_private & OPpLVAL_INTRO))
3da99855 912 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e 913 }
5d9574c1 914 else if (UNLIKELY(SvTYPE(sv) != type)) {
67955e0c 915 GV *gv;
1c846c1f 916
6e592b3a 917 if (!isGV_with_GP(sv)) {
13c59d41 918 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
dc3c76f8
NC
919 type, &sp);
920 if (!gv)
921 RETURN;
35cd451c
GS
922 }
923 else {
159b6efe 924 gv = MUTABLE_GV(sv);
a0d0e21e 925 }
ad64d0ec 926 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 927 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 928 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
9f527363
FC
929 }
930 if (PL_op->op_flags & OPf_REF) {
17ab7946 931 SETs(sv);
a0d0e21e 932 RETURN;
9f527363 933 }
5d9574c1 934 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
40c94d11
FC
935 const I32 flags = is_lvalue_sub();
936 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 937 if (gimme != G_ARRAY)
042560a6 938 goto croak_cant_return;
17ab7946 939 SETs(sv);
78f9721b 940 RETURN;
40c94d11 941 }
a0d0e21e
LW
942 }
943
17ab7946 944 if (is_pp_rv2av) {
502c6561 945 AV *const av = MUTABLE_AV(sv);
636fe681 946 /* The guts of pp_rv2av */
96913b52 947 if (gimme == G_ARRAY) {
d5524600
DM
948 SP--;
949 PUTBACK;
950 S_pushav(aTHX_ av);
951 SPAGAIN;
1c846c1f 952 }
96913b52
VP
953 else if (gimme == G_SCALAR) {
954 dTARGET;
c70927a6 955 const SSize_t maxarg = AvFILL(av) + 1;
96913b52 956 SETi(maxarg);
93965878 957 }
17ab7946
NC
958 } else {
959 /* The guts of pp_rv2hv */
96913b52
VP
960 if (gimme == G_ARRAY) { /* array wanted */
961 *PL_stack_sp = sv;
981b7185 962 return Perl_do_kv(aTHX);
96913b52 963 }
c8fe3bdf 964 else if ((PL_op->op_private & OPpTRUEBOOL
adc42c31 965 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
c8fe3bdf
FC
966 && block_gimme() == G_VOID ))
967 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
968 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
96913b52 969 else if (gimme == G_SCALAR) {
1a8bdda9 970 dTARG;
96913b52 971 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
96913b52
VP
972 SETTARG;
973 }
17ab7946 974 }
be85d344 975 RETURN;
042560a6
NC
976
977 croak_cant_return:
978 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
979 is_pp_rv2av ? "array" : "hash");
77e217c6 980 RETURN;
a0d0e21e
LW
981}
982
10c8fecd 983STATIC void
fb8f4cf8 984S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
10c8fecd 985{
7918f24d
NC
986 PERL_ARGS_ASSERT_DO_ODDBALL;
987
fb8f4cf8 988 if (*oddkey) {
6d822dc4 989 if (ckWARN(WARN_MISC)) {
a3b680e6 990 const char *err;
fb8f4cf8
RZ
991 if (oddkey == firstkey &&
992 SvROK(*oddkey) &&
993 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
994 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
10c8fecd 995 {
a3b680e6 996 err = "Reference found where even-sized list expected";
10c8fecd
GS
997 }
998 else
a3b680e6 999 err = "Odd number of elements in hash assignment";
f1f66076 1000 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
10c8fecd 1001 }
6d822dc4 1002
10c8fecd
GS
1003 }
1004}
1005
a0d0e21e
LW
1006PP(pp_aassign)
1007{
27da23d5 1008 dVAR; dSP;
3280af22
NIS
1009 SV **lastlelem = PL_stack_sp;
1010 SV **lastrelem = PL_stack_base + POPMARK;
1011 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
1012 SV **firstlelem = lastrelem + 1;
1013
eb578fdb
KW
1014 SV **relem;
1015 SV **lelem;
a0d0e21e 1016
eb578fdb
KW
1017 SV *sv;
1018 AV *ary;
a0d0e21e 1019
54310121 1020 I32 gimme;
a0d0e21e 1021 HV *hash;
c70927a6 1022 SSize_t i;
a0d0e21e 1023 int magic;
88e2091b 1024 U32 lval = 0;
5637b936 1025
3280af22 1026 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
ca65944e 1027 gimme = GIMME_V;
88e2091b
RZ
1028 if (gimme == G_ARRAY)
1029 lval = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e
LW
1030
1031 /* If there's a common identifier on both sides we have to take
1032 * special care that assigning the identifier on the left doesn't
1033 * clobber a value on the right that's used later in the list.
acdea6f0 1034 * Don't bother if LHS is just an empty hash or array.
a0d0e21e 1035 */
acdea6f0 1036
ff2a62e0 1037 if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
acdea6f0
DM
1038 && (
1039 firstlelem != lastlelem
1040 || ! ((sv = *firstlelem))
1041 || SvMAGICAL(sv)
1042 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1043 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1b95d04f 1044 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
acdea6f0
DM
1045 )
1046 ) {
cc5e57d2 1047 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd 1048 for (relem = firstrelem; relem <= lastrelem; relem++) {
5d9574c1 1049 if (LIKELY((sv = *relem))) {
a1f49e72 1050 TAINT_NOT; /* Each item is independent */
61e5f455
NC
1051
1052 /* Dear TODO test in t/op/sort.t, I love you.
1053 (It's relying on a panic, not a "semi-panic" from newSVsv()
1054 and then an assertion failure below.) */
5d9574c1 1055 if (UNLIKELY(SvIS_FREED(sv))) {
61e5f455
NC
1056 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1057 (void*)sv);
1058 }
2203fb5a
FC
1059 /* Not newSVsv(), as it does not allow copy-on-write,
1060 resulting in wasteful copies. We need a second copy of
1061 a temp here, hence the SV_NOSTEAL. */
1062 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1063 |SV_NOSTEAL);
a1f49e72 1064 }
10c8fecd 1065 }
a0d0e21e
LW
1066 }
1067
1068 relem = firstrelem;
1069 lelem = firstlelem;
4608196e
RGS
1070 ary = NULL;
1071 hash = NULL;
10c8fecd 1072
5d9574c1 1073 while (LIKELY(lelem <= lastlelem)) {
bdaf10a5 1074 bool alias = FALSE;
bbce6d69 1075 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e 1076 sv = *lelem++;
bdaf10a5
FC
1077 if (UNLIKELY(!sv)) {
1078 alias = TRUE;
1079 sv = *lelem++;
1080 ASSUME(SvTYPE(sv) == SVt_PVAV);
1081 }
a0d0e21e
LW
1082 switch (SvTYPE(sv)) {
1083 case SVt_PVAV:
60edcf09 1084 ary = MUTABLE_AV(sv);
748a9306 1085 magic = SvMAGICAL(ary) != 0;
60edcf09
FC
1086 ENTER;
1087 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1088 av_clear(ary);
7e42bd57 1089 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
1090 i = 0;
1091 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 1092 SV **didstore;
5d9574c1 1093 if (LIKELY(*relem))
ce0d59fd 1094 SvGETMAGIC(*relem); /* before newSV, in case it dies */
bdaf10a5
FC
1095 if (LIKELY(!alias)) {
1096 sv = newSV(0);
1097 sv_setsv_nomg(sv, *relem);
1098 *relem = sv;
1099 }
1100 else {
1101 if (!SvROK(*relem))
1102 DIE(aTHX_ "Assigned value is not a reference");
1103 if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1104 /* diag_listed_as: Assigned value is not %s reference */
1105 DIE(aTHX_
1106 "Assigned value is not a SCALAR reference");
1107 if (lval)
1108 *relem = sv_mortalcopy(*relem);
1109 /* XXX else check for weak refs? */
1110 sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1111 }
1112 relem++;
5117ca91
GS
1113 didstore = av_store(ary,i++,sv);
1114 if (magic) {
18024492
FC
1115 if (!didstore)
1116 sv_2mortal(sv);
8ef24240 1117 if (SvSMAGICAL(sv))
fb73857a 1118 mg_set(sv);
5117ca91 1119 }
bbce6d69 1120 TAINT_NOT;
a0d0e21e 1121 }
5d9574c1 1122 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
ad64d0ec 1123 SvSETMAGIC(MUTABLE_SV(ary));
60edcf09 1124 LEAVE;
a0d0e21e 1125 break;
10c8fecd 1126 case SVt_PVHV: { /* normal hash */
a0d0e21e 1127 SV *tmpstr;
1c4ea384
RZ
1128 int odd;
1129 int duplicates = 0;
45960564 1130 SV** topelem = relem;
1c4ea384 1131 SV **firsthashrelem = relem;
a0d0e21e 1132
60edcf09 1133 hash = MUTABLE_HV(sv);
748a9306 1134 magic = SvMAGICAL(hash) != 0;
1c4ea384
RZ
1135
1136 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
5d9574c1 1137 if (UNLIKELY(odd)) {
fb8f4cf8 1138 do_oddball(lastrelem, firsthashrelem);
1d2b3927
HS
1139 /* we have firstlelem to reuse, it's not needed anymore
1140 */
1c4ea384
RZ
1141 *(lastrelem+1) = &PL_sv_undef;
1142 }
1143
60edcf09
FC
1144 ENTER;
1145 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1146 hv_clear(hash);
5d9574c1 1147 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
5117ca91 1148 HE *didstore;
1c4ea384 1149 assert(*relem);
632b9d6f
FC
1150 /* Copy the key if aassign is called in lvalue context,
1151 to avoid having the next op modify our rhs. Copy
1152 it also if it is gmagical, lest it make the
1153 hv_store_ent call below croak, leaking the value. */
1154 sv = lval || SvGMAGICAL(*relem)
1155 ? sv_mortalcopy(*relem)
1156 : *relem;
45960564 1157 relem++;
1c4ea384 1158 assert(*relem);
632b9d6f
FC
1159 SvGETMAGIC(*relem);
1160 tmpstr = newSV(0);
1161 sv_setsv_nomg(tmpstr,*relem++); /* value */
a88bf2bc 1162 if (gimme == G_ARRAY) {
45960564
DM
1163 if (hv_exists_ent(hash, sv, 0))
1164 /* key overwrites an existing entry */
1165 duplicates += 2;
a88bf2bc 1166 else {
45960564 1167 /* copy element back: possibly to an earlier
1d2b3927
HS
1168 * stack location if we encountered dups earlier,
1169 * possibly to a later stack location if odd */
45960564
DM
1170 *topelem++ = sv;
1171 *topelem++ = tmpstr;
1172 }
1173 }
5117ca91 1174 didstore = hv_store_ent(hash,sv,tmpstr,0);
632b9d6f
FC
1175 if (magic) {
1176 if (!didstore) sv_2mortal(tmpstr);
1177 SvSETMAGIC(tmpstr);
1178 }
bbce6d69 1179 TAINT_NOT;
8e07c86e 1180 }
60edcf09 1181 LEAVE;
1c4ea384
RZ
1182 if (duplicates && gimme == G_ARRAY) {
1183 /* at this point we have removed the duplicate key/value
1184 * pairs from the stack, but the remaining values may be
1185 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1186 * the (a 2), but the stack now probably contains
1187 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1188 * obliterates the earlier key. So refresh all values. */
1189 lastrelem -= duplicates;
1190 relem = firsthashrelem;
1191 while (relem < lastrelem+odd) {
1192 HE *he;
1193 he = hv_fetch_ent(hash, *relem++, 0, 0);
1194 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1195 }
1196 }
1197 if (odd && gimme == G_ARRAY) lastrelem++;
a0d0e21e
LW
1198 }
1199 break;
1200 default:
6fc92669
GS
1201 if (SvIMMORTAL(sv)) {
1202 if (relem <= lastrelem)
1203 relem++;
1204 break;
a0d0e21e
LW
1205 }
1206 if (relem <= lastrelem) {
5d9574c1 1207 if (UNLIKELY(
1c70fb82
FC
1208 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1209 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
5d9574c1 1210 ))
1c70fb82
FC
1211 Perl_warner(aTHX_
1212 packWARN(WARN_MISC),
1213 "Useless assignment to a temporary"
1214 );
a0d0e21e
LW
1215 sv_setsv(sv, *relem);
1216 *(relem++) = sv;
1217 }
1218 else
3280af22 1219 sv_setsv(sv, &PL_sv_undef);
8ef24240 1220 SvSETMAGIC(sv);
a0d0e21e
LW
1221 break;
1222 }
1223 }
5d9574c1 1224 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
985213f2 1225 /* Will be used to set PL_tainting below */
dfff4baf
BF
1226 Uid_t tmp_uid = PerlProc_getuid();
1227 Uid_t tmp_euid = PerlProc_geteuid();
1228 Gid_t tmp_gid = PerlProc_getgid();
1229 Gid_t tmp_egid = PerlProc_getegid();
985213f2 1230
b469f1e0 1231 /* XXX $> et al currently silently ignore failures */
3280af22 1232 if (PL_delaymagic & DM_UID) {
a0d0e21e 1233#ifdef HAS_SETRESUID
b469f1e0
JH
1234 PERL_UNUSED_RESULT(
1235 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1236 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1237 (Uid_t)-1));
56febc5e
AD
1238#else
1239# ifdef HAS_SETREUID
b469f1e0
JH
1240 PERL_UNUSED_RESULT(
1241 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1242 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
56febc5e
AD
1243# else
1244# ifdef HAS_SETRUID
b28d0864 1245 if ((PL_delaymagic & DM_UID) == DM_RUID) {
b469f1e0 1246 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
b28d0864 1247 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1248 }
56febc5e
AD
1249# endif /* HAS_SETRUID */
1250# ifdef HAS_SETEUID
b28d0864 1251 if ((PL_delaymagic & DM_UID) == DM_EUID) {
b469f1e0 1252 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
b28d0864 1253 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1254 }
56febc5e 1255# endif /* HAS_SETEUID */
b28d0864 1256 if (PL_delaymagic & DM_UID) {
985213f2 1257 if (PL_delaymagic_uid != PL_delaymagic_euid)
cea2e8a9 1258 DIE(aTHX_ "No setreuid available");
b469f1e0 1259 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
a0d0e21e 1260 }
56febc5e
AD
1261# endif /* HAS_SETREUID */
1262#endif /* HAS_SETRESUID */
04783dc7 1263
985213f2
AB
1264 tmp_uid = PerlProc_getuid();
1265 tmp_euid = PerlProc_geteuid();
a0d0e21e 1266 }
b469f1e0 1267 /* XXX $> et al currently silently ignore failures */
3280af22 1268 if (PL_delaymagic & DM_GID) {
a0d0e21e 1269#ifdef HAS_SETRESGID
b469f1e0
JH
1270 PERL_UNUSED_RESULT(
1271 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1272 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1273 (Gid_t)-1));
56febc5e
AD
1274#else
1275# ifdef HAS_SETREGID
b469f1e0
JH
1276 PERL_UNUSED_RESULT(
1277 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1278 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
56febc5e
AD
1279# else
1280# ifdef HAS_SETRGID
b28d0864 1281 if ((PL_delaymagic & DM_GID) == DM_RGID) {
b469f1e0 1282 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
b28d0864 1283 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1284 }
56febc5e
AD
1285# endif /* HAS_SETRGID */
1286# ifdef HAS_SETEGID
b28d0864 1287 if ((PL_delaymagic & DM_GID) == DM_EGID) {
b469f1e0 1288 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
b28d0864 1289 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1290 }
56febc5e 1291# endif /* HAS_SETEGID */
b28d0864 1292 if (PL_delaymagic & DM_GID) {
985213f2 1293 if (PL_delaymagic_gid != PL_delaymagic_egid)
cea2e8a9 1294 DIE(aTHX_ "No setregid available");
b469f1e0 1295 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
a0d0e21e 1296 }
56febc5e
AD
1297# endif /* HAS_SETREGID */
1298#endif /* HAS_SETRESGID */
04783dc7 1299
985213f2
AB
1300 tmp_gid = PerlProc_getgid();
1301 tmp_egid = PerlProc_getegid();
a0d0e21e 1302 }
284167a5 1303 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
9a9b5ec9
DM
1304#ifdef NO_TAINT_SUPPORT
1305 PERL_UNUSED_VAR(tmp_uid);
1306 PERL_UNUSED_VAR(tmp_euid);
1307 PERL_UNUSED_VAR(tmp_gid);
1308 PERL_UNUSED_VAR(tmp_egid);
1309#endif
a0d0e21e 1310 }
3280af22 1311 PL_delaymagic = 0;
54310121 1312
54310121
PP
1313 if (gimme == G_VOID)
1314 SP = firstrelem - 1;
1315 else if (gimme == G_SCALAR) {
1316 dTARGET;
1317 SP = firstrelem;
231cbeb2 1318 SETi(lastrelem - firstrelem + 1);
54310121
PP
1319 }
1320 else {
1c4ea384 1321 if (ary || hash)
1d2b3927
HS
1322 /* note that in this case *firstlelem may have been overwritten
1323 by sv_undef in the odd hash case */
a0d0e21e 1324 SP = lastrelem;
1c4ea384 1325 else {
a0d0e21e 1326 SP = firstrelem + (lastlelem - firstlelem);
1c4ea384
RZ
1327 lelem = firstlelem + (relem - firstrelem);
1328 while (relem <= SP)
1329 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1330 }
a0d0e21e 1331 }
08aeb9f7 1332
54310121 1333 RETURN;
a0d0e21e
LW
1334}
1335
8782bef2
GB
1336PP(pp_qr)
1337{
20b7effb 1338 dSP;
eb578fdb 1339 PMOP * const pm = cPMOP;
fe578d7f 1340 REGEXP * rx = PM_GETRE(pm);
10599a69 1341 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
c4420975 1342 SV * const rv = sv_newmortal();
d63c20f2
DM
1343 CV **cvp;
1344 CV *cv;
288b8c02
NC
1345
1346 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
1347 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1348 loathe to use it here, but it seems to be the right fix. Or close.
1349 The key part appears to be that it's essential for pp_qr to return a new
1350 object (SV), which implies that there needs to be an effective way to
1351 generate a new SV from the existing SV that is pre-compiled in the
1352 optree. */
1353 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
1354 SvROK_on(rv);
1355
8d919b0a 1356 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
5d9574c1 1357 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
d63c20f2 1358 *cvp = cv_clone(cv);
fc2b2dca 1359 SvREFCNT_dec_NN(cv);
d63c20f2
DM
1360 }
1361
288b8c02 1362 if (pkg) {
f815daf2 1363 HV *const stash = gv_stashsv(pkg, GV_ADD);
fc2b2dca 1364 SvREFCNT_dec_NN(pkg);
288b8c02
NC
1365 (void)sv_bless(rv, stash);
1366 }
1367
5d9574c1 1368 if (UNLIKELY(RX_ISTAINTED(rx))) {
e08e52cf 1369 SvTAINTED_on(rv);
9274aefd
DM
1370 SvTAINTED_on(SvRV(rv));
1371 }
c8c13c22 1372 XPUSHs(rv);
1373 RETURN;
8782bef2
GB
1374}
1375
a0d0e21e
LW
1376PP(pp_match)
1377{
20b7effb 1378 dSP; dTARG;
eb578fdb 1379 PMOP *pm = cPMOP;
d65afb4b 1380 PMOP *dynpm = pm;
eb578fdb 1381 const char *s;
5c144d81 1382 const char *strend;
99a90e59 1383 SSize_t curpos = 0; /* initial pos() or current $+[0] */
a0d0e21e 1384 I32 global;
7fadf4a7 1385 U8 r_flags = 0;
5c144d81 1386 const char *truebase; /* Start of string */
eb578fdb 1387 REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1388 bool rxtainted;
82334630 1389 const I32 gimme = GIMME_V;
a0d0e21e 1390 STRLEN len;
a3b680e6 1391 const I32 oldsave = PL_savestack_ix;
e60df1fa 1392 I32 had_zerolen = 0;
b1422d62 1393 MAGIC *mg = NULL;
a0d0e21e 1394
533c011a 1395 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1396 TARG = POPs;
6ffceeb7 1397 else if (ARGTARG)
59f00321 1398 GETTARGET;
a0d0e21e 1399 else {
54b9620d 1400 TARG = DEFSV;
a0d0e21e
LW
1401 EXTEND(SP,1);
1402 }
d9f424b2 1403
c277df42 1404 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
1405 /* Skip get-magic if this is a qr// clone, because regcomp has
1406 already done it. */
f1d31338 1407 truebase = ReANY(rx)->mother_re
69dc4b30
FC
1408 ? SvPV_nomg_const(TARG, len)
1409 : SvPV_const(TARG, len);
f1d31338 1410 if (!truebase)
2269b42e 1411 DIE(aTHX_ "panic: pp_match");
f1d31338 1412 strend = truebase + len;
284167a5
SM
1413 rxtainted = (RX_ISTAINTED(rx) ||
1414 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1415 TAINT_NOT;
a0d0e21e 1416
6c864ec2 1417 /* We need to know this in case we fail out early - pos() must be reset */
de0df3c0
MH
1418 global = dynpm->op_pmflags & PMf_GLOBAL;
1419
d65afb4b 1420 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
1421 if (
1422#ifdef USE_ITHREADS
1423 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1424#else
1425 pm->op_pmflags & PMf_USED
1426#endif
1427 ) {
e5dc5375 1428 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
de0df3c0 1429 goto nope;
a0d0e21e
LW
1430 }
1431
7e313637
FC
1432 /* empty pattern special-cased to use last successful pattern if
1433 possible, except for qr// */
8d919b0a 1434 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
7e313637 1435 && PL_curpm) {
3280af22 1436 pm = PL_curpm;
aaa362c4 1437 rx = PM_GETRE(pm);
a0d0e21e 1438 }
d65afb4b 1439
389ecb56 1440 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
75d43e96
FC
1441 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1442 UVuf" < %"IVdf")\n",
1443 (UV)len, (IV)RX_MINLEN(rx)));
de0df3c0 1444 goto nope;
e5dc5375 1445 }
c277df42 1446
8ef97b0e 1447 /* get pos() if //g */
de0df3c0 1448 if (global) {
b1422d62 1449 mg = mg_find_mglob(TARG);
8ef97b0e 1450 if (mg && mg->mg_len >= 0) {
25fdce4a 1451 curpos = MgBYTEPOS(mg, TARG, truebase, len);
8ef97b0e
DM
1452 /* last time pos() was set, it was zero-length match */
1453 if (mg->mg_flags & MGf_MINMATCH)
1454 had_zerolen = 1;
1455 }
a0d0e21e 1456 }
8ef97b0e 1457
6e240d0b 1458#ifdef PERL_SAWAMPERSAND
a41aa44d 1459 if ( RX_NPARENS(rx)
6502e081 1460 || PL_sawampersand
6502e081 1461 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 1462 || (dynpm->op_pmflags & PMf_KEEPCOPY)
6e240d0b
FC
1463 )
1464#endif
1465 {
6502e081
DM
1466 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1467 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1468 * only on the first iteration. Therefore we need to copy $' as well
1469 * as $&, to make the rest of the string available for captures in
1470 * subsequent iterations */
1471 if (! (global && gimme == G_ARRAY))
1472 r_flags |= REXEC_COPY_SKIP_POST;
1473 };
5b0e71e9
DM
1474#ifdef PERL_SAWAMPERSAND
1475 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1476 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1477 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1478#endif
22e551b9 1479
f1d31338
DM
1480 s = truebase;
1481
d7be1480 1482 play_it_again:
985afbc1 1483 if (global)
03c83e26 1484 s = truebase + curpos;
f722798b 1485
77da2310 1486 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
03c83e26 1487 had_zerolen, TARG, NULL, r_flags))
03b6c93d 1488 goto nope;
77da2310
NC
1489
1490 PL_curpm = pm;
985afbc1 1491 if (dynpm->op_pmflags & PMf_ONCE)
c737faaf 1492#ifdef USE_ITHREADS
77da2310 1493 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 1494#else
77da2310 1495 dynpm->op_pmflags |= PMf_USED;
c737faaf 1496#endif
a0d0e21e 1497
72311751
GS
1498 if (rxtainted)
1499 RX_MATCH_TAINTED_on(rx);
1500 TAINT_IF(RX_MATCH_TAINTED(rx));
35c2ccc3
DM
1501
1502 /* update pos */
1503
1504 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
b1422d62 1505 if (!mg)
35c2ccc3 1506 mg = sv_magicext_mglob(TARG);
25fdce4a 1507 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
adf51885
DM
1508 if (RX_ZERO_LEN(rx))
1509 mg->mg_flags |= MGf_MINMATCH;
1510 else
1511 mg->mg_flags &= ~MGf_MINMATCH;
35c2ccc3
DM
1512 }
1513
bf9dff51
DM
1514 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1515 LEAVE_SCOPE(oldsave);
1516 RETPUSHYES;
1517 }
1518
88ab22af
DM
1519 /* push captures on stack */
1520
bf9dff51 1521 {
07bc277f 1522 const I32 nparens = RX_NPARENS(rx);
a3b680e6 1523 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 1524
c277df42 1525 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1526 EXTEND(SP, nparens + i);
1527 EXTEND_MORTAL(nparens + i);
1528 for (i = !i; i <= nparens; i++) {
a0d0e21e 1529 PUSHs(sv_newmortal());
5d9574c1
DM
1530 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1531 && RX_OFFS(rx)[i].end != -1 ))
1532 {
07bc277f 1533 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
f1d31338 1534 const char * const s = RX_OFFS(rx)[i].start + truebase;
5d9574c1
DM
1535 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1536 || len < 0 || len > strend - s))
5637ef5b
NC
1537 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1538 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1539 (long) i, (long) RX_OFFS(rx)[i].start,
1540 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
a0d0e21e 1541 sv_setpvn(*SP, s, len);
cce850e4 1542 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1543 SvUTF8_on(*SP);
a0d0e21e
LW
1544 }
1545 }
1546 if (global) {
0e0b3e82 1547 curpos = (UV)RX_OFFS(rx)[0].end;
03c83e26 1548 had_zerolen = RX_ZERO_LEN(rx);
c277df42 1549 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1550 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1551 goto play_it_again;
1552 }
4633a7c4 1553 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1554 RETURN;
1555 }
e5964223 1556 NOT_REACHED; /* NOTREACHED */
a0d0e21e 1557
7b52d656 1558 nope:
d65afb4b 1559 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
b1422d62
DM
1560 if (!mg)
1561 mg = mg_find_mglob(TARG);
1562 if (mg)
1563 mg->mg_len = -1;
a0d0e21e 1564 }
4633a7c4 1565 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1566 if (gimme == G_ARRAY)
1567 RETURN;
1568 RETPUSHNO;
1569}
1570
1571OP *
864dbfa3 1572Perl_do_readline(pTHX)
a0d0e21e 1573{
20b7effb 1574 dSP; dTARGETSTACKED;
eb578fdb 1575 SV *sv;
a0d0e21e
LW
1576 STRLEN tmplen = 0;
1577 STRLEN offset;
760ac839 1578 PerlIO *fp;
eb578fdb
KW
1579 IO * const io = GvIO(PL_last_in_gv);
1580 const I32 type = PL_op->op_type;
a3b680e6 1581 const I32 gimme = GIMME_V;
a0d0e21e 1582
6136c704 1583 if (io) {
50db69d8 1584 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 1585 if (mg) {
3e0cb5de 1586 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 1587 if (gimme == G_SCALAR) {
50db69d8
NC
1588 SPAGAIN;
1589 SvSetSV_nosteal(TARG, TOPs);
1590 SETTARG;
6136c704 1591 }
50db69d8 1592 return NORMAL;
0b7c7b4f 1593 }
e79b0511 1594 }
4608196e 1595 fp = NULL;
a0d0e21e
LW
1596 if (io) {
1597 fp = IoIFP(io);
1598 if (!fp) {
1599 if (IoFLAGS(io) & IOf_ARGV) {
1600 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1601 IoLINES(io) = 0;
b9f2b683 1602 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1603 IoFLAGS(io) &= ~IOf_START;
d5eb9a46 1604 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
4bac9ae4 1605 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
76f68e9b 1606 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3280af22 1607 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1608 fp = IoIFP(io);
1609 goto have_fp;
a0d0e21e
LW
1610 }
1611 }
157fb5a1 1612 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e 1613 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1614 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1615 }
1616 }
0d44d22b
NC
1617 else if (type == OP_GLOB)
1618 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1619 }
1620 else if (type == OP_GLOB)
1621 SP--;
7716c5c5 1622 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 1623 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 1624 }
a0d0e21e
LW
1625 }
1626 if (!fp) {
041457d9 1627 if ((!io || !(IoFLAGS(io) & IOf_START))
de7dabb6
TC
1628 && ckWARN(WARN_CLOSED)
1629 && type != OP_GLOB)
041457d9 1630 {
de7dabb6 1631 report_evil_fh(PL_last_in_gv);
3f4520fe 1632 }
54310121 1633 if (gimme == G_SCALAR) {
79628082 1634 /* undef TARG, and push that undefined value */
ba92458f 1635 if (type != OP_RCATLINE) {
aab1202a 1636 sv_setsv(TARG,NULL);
ba92458f 1637 }
a0d0e21e
LW
1638 PUSHTARG;
1639 }
1640 RETURN;
1641 }
a2008d6d 1642 have_fp:
54310121 1643 if (gimme == G_SCALAR) {
a0d0e21e 1644 sv = TARG;
0f722b55
RGS
1645 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1646 mg_get(sv);
48de12d9
RGS
1647 if (SvROK(sv)) {
1648 if (type == OP_RCATLINE)
5668452f 1649 SvPV_force_nomg_nolen(sv);
48de12d9
RGS
1650 else
1651 sv_unref(sv);
1652 }
f7877b28 1653 else if (isGV_with_GP(sv)) {
5668452f 1654 SvPV_force_nomg_nolen(sv);
f7877b28 1655 }
862a34c6 1656 SvUPGRADE(sv, SVt_PV);
a0d0e21e 1657 tmplen = SvLEN(sv); /* remember if already alloced */
e3918bb7 1658 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
f72e8700
JJ
1659 /* try short-buffering it. Please update t/op/readline.t
1660 * if you change the growth length.
1661 */
1662 Sv_Grow(sv, 80);
1663 }
2b5e58c4
AMS
1664 offset = 0;
1665 if (type == OP_RCATLINE && SvOK(sv)) {
1666 if (!SvPOK(sv)) {
5668452f 1667 SvPV_force_nomg_nolen(sv);
2b5e58c4 1668 }
a0d0e21e 1669 offset = SvCUR(sv);
2b5e58c4 1670 }
a0d0e21e 1671 }
54310121 1672 else {
561b68a9 1673 sv = sv_2mortal(newSV(80));
54310121
PP
1674 offset = 0;
1675 }
fbad3eb5 1676
3887d568
AP
1677 /* This should not be marked tainted if the fp is marked clean */
1678#define MAYBE_TAINT_LINE(io, sv) \
1679 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1680 TAINT; \
1681 SvTAINTED_on(sv); \
1682 }
1683
684bef36 1684/* delay EOF state for a snarfed empty file */
fbad3eb5 1685#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1686 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1687 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1688
a0d0e21e 1689 for (;;) {
09e8efcc 1690 PUTBACK;
fbad3eb5 1691 if (!sv_gets(sv, fp, offset)
2d726892
TF
1692 && (type == OP_GLOB
1693 || SNARF_EOF(gimme, PL_rs, io, sv)
1694 || PerlIO_error(fp)))
fbad3eb5 1695 {
760ac839 1696 PerlIO_clearerr(fp);
a0d0e21e 1697 if (IoFLAGS(io) & IOf_ARGV) {
157fb5a1 1698 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e
LW
1699 if (fp)
1700 continue;
3280af22 1701 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1702 }
1703 else if (type == OP_GLOB) {
a2a5de95
NC
1704 if (!do_close(PL_last_in_gv, FALSE)) {
1705 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1706 "glob failed (child exited with status %d%s)",
1707 (int)(STATUS_CURRENT >> 8),
1708 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1709 }
a0d0e21e 1710 }
54310121 1711 if (gimme == G_SCALAR) {
ba92458f
AE
1712 if (type != OP_RCATLINE) {
1713 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1714 SvOK_off(TARG);
ba92458f 1715 }
09e8efcc 1716 SPAGAIN;
a0d0e21e
LW
1717 PUSHTARG;
1718 }
3887d568 1719 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1720 RETURN;
1721 }
3887d568 1722 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1723 IoLINES(io)++;
b9fee9ba 1724 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1725 SvSETMAGIC(sv);
09e8efcc 1726 SPAGAIN;
a0d0e21e 1727 XPUSHs(sv);
a0d0e21e 1728 if (type == OP_GLOB) {
349d4f2f 1729 const char *t1;
a0d0e21e 1730
3280af22 1731 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 1732 char * const tmps = SvEND(sv) - 1;
aa07b2f6 1733 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 1734 *tmps = '\0';
b162af07 1735 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
1736 }
1737 }
349d4f2f 1738 for (t1 = SvPVX_const(sv); *t1; t1++)
b51c3e77
CB
1739#ifdef __VMS
1740 if (strchr("*%?", *t1))
1741#else
7ad1e72d 1742 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
b51c3e77 1743#endif
a0d0e21e 1744 break;
349d4f2f 1745 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1746 (void)POPs; /* Unmatched wildcard? Chuck it... */
1747 continue;
1748 }
2d79bf7f 1749 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
1750 if (ckWARN(WARN_UTF8)) {
1751 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1752 const STRLEN len = SvCUR(sv) - offset;
1753 const U8 *f;
1754
1755 if (!is_utf8_string_loc(s, len, &f))
1756 /* Emulate :encoding(utf8) warning in the same case. */
1757 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1758 "utf8 \"\\x%02X\" does not map to Unicode",
1759 f < (U8*)SvEND(sv) ? *f : 0);
1760 }
a0d0e21e 1761 }
54310121 1762 if (gimme == G_ARRAY) {
a0d0e21e 1763 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 1764 SvPV_shrink_to_cur(sv);
a0d0e21e 1765 }
561b68a9 1766 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
1767 continue;
1768 }
54310121 1769 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 1770 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
1771 const STRLEN new_len
1772 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 1773 SvPV_renew(sv, new_len);
a0d0e21e
LW
1774 }
1775 RETURN;
1776 }
1777}
1778
a0d0e21e
LW
1779PP(pp_helem)
1780{
20b7effb 1781 dSP;
760ac839 1782 HE* he;
ae77835f 1783 SV **svp;
c445ea15 1784 SV * const keysv = POPs;
85fbaab2 1785 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
1786 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1787 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1788 SV *sv;
92970b93 1789 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 1790 bool preeminent = TRUE;
a0d0e21e 1791
d9dc8e0c 1792 assert(SvTYPE(hv) == SVt_PVHV);
d4c19fe8 1793
92970b93 1794 if (localizing) {
d4c19fe8
AL
1795 MAGIC *mg;
1796 HV *stash;
d30e492c
VP
1797
1798 /* If we can determine whether the element exist,
1799 * Try to preserve the existenceness of a tied hash
1800 * element by using EXISTS and DELETE if possible.
1801 * Fallback to FETCH and STORE otherwise. */
2c5f48c2 1802 if (SvCANEXISTDELETE(hv))
d30e492c 1803 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 1804 }
d30e492c 1805
5f9d7e2b 1806 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
d4c19fe8 1807 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 1808 if (lval) {
746f6409 1809 if (!svp || !*svp || *svp == &PL_sv_undef) {
68dc0745
PP
1810 SV* lv;
1811 SV* key2;
2d8e6c8d 1812 if (!defer) {
be2597df 1813 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 1814 }
68dc0745
PP
1815 lv = sv_newmortal();
1816 sv_upgrade(lv, SVt_PVLV);
1817 LvTYPE(lv) = 'y';
6136c704 1818 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
fc2b2dca 1819 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
b37c2d43 1820 LvTARG(lv) = SvREFCNT_inc_simple(hv);
68dc0745
PP
1821 LvTARGLEN(lv) = 1;
1822 PUSHs(lv);
1823 RETURN;
1824 }
92970b93 1825 if (localizing) {
bfcb3514 1826 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 1827 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
1828 else if (preeminent)
1829 save_helem_flags(hv, keysv, svp,
1830 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1831 else
1832 SAVEHDELETE(hv, keysv);
5f05dabc 1833 }
9026059d
GG
1834 else if (PL_op->op_private & OPpDEREF) {
1835 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1836 RETURN;
1837 }
a0d0e21e 1838 }
746f6409 1839 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
1840 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1841 * was to make C<local $tied{foo} = $tied{foo}> possible.
1842 * However, it seems no longer to be needed for that purpose, and
1843 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1844 * would loop endlessly since the pos magic is getting set on the
1845 * mortal copy and lost. However, the copy has the effect of
1846 * triggering the get magic, and losing it altogether made things like
1847 * c<$tied{foo};> in void context no longer do get magic, which some
1848 * code relied on. Also, delayed triggering of magic on @+ and friends
1849 * meant the original regex may be out of scope by now. So as a
1850 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1851 * being called too many times). */
39cf747a 1852 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 1853 mg_get(sv);
be6c24e0 1854 PUSHs(sv);
a0d0e21e
LW
1855 RETURN;
1856}
1857
fedf30e1
DM
1858
1859/* a stripped-down version of Perl_softref2xv() for use by
1860 * pp_multideref(), which doesn't use PL_op->op_flags */
1861
1862GV *
1863S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
1864 const svtype type)
1865{
1866 if (PL_op->op_private & HINT_STRICT_REFS) {
1867 if (SvOK(sv))
1868 Perl_die(aTHX_ PL_no_symref_sv, sv,
1869 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
1870 else
1871 Perl_die(aTHX_ PL_no_usym, what);
1872 }
1873 if (!SvOK(sv))
1874 Perl_die(aTHX_ PL_no_usym, what);
1875 return gv_fetchsv_nomg(sv, GV_ADD, type);
1876}
1877
1878
79815f56
DM
1879/* Handle one or more aggregate derefs and array/hash indexings, e.g.
1880 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
fedf30e1
DM
1881 *
1882 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
79815f56
DM
1883 * Each of these either contains a set of actions, or an argument, such as
1884 * an IV to use as an array index, or a lexical var to retrieve.
1885 * Several actions re stored per UV; we keep shifting new actions off the
1886 * one UV, and only reload when it becomes zero.
fedf30e1
DM
1887 */
1888
1889PP(pp_multideref)
1890{
1891 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
1892 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
1893 UV actions = items->uv;
1894
1895 assert(actions);
1896 /* this tells find_uninit_var() where we're up to */
1897 PL_multideref_pc = items;
1898
1899 while (1) {
1900 /* there are three main classes of action; the first retrieve
1901 * the initial AV or HV from a variable or the stack; the second
1902 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
1903 * the third an unrolled (/DREFHV, rv2hv, helem).
1904 */
1905 switch (actions & MDEREF_ACTION_MASK) {
1906
1907 case MDEREF_reload:
1908 actions = (++items)->uv;
1909 continue;
1910
1911 case MDEREF_AV_padav_aelem: /* $lex[...] */
1912 sv = PAD_SVl((++items)->pad_offset);
1913 goto do_AV_aelem;
1914
1915 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
1916 sv = UNOP_AUX_item_sv(++items);
1917 assert(isGV_with_GP(sv));
1918 sv = (SV*)GvAVn((GV*)sv);
1919 goto do_AV_aelem;
1920
1921 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
1922 {
1923 dSP;
1924 sv = POPs;
1925 PUTBACK;
1926 goto do_AV_rv2av_aelem;
1927 }
1928
1929 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
1930 sv = UNOP_AUX_item_sv(++items);
1931 assert(isGV_with_GP(sv));
1932 sv = GvSVn((GV*)sv);
1933 goto do_AV_vivify_rv2av_aelem;
1934
1935 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
1936 sv = PAD_SVl((++items)->pad_offset);
1937 /* FALLTHROUGH */
1938
1939 do_AV_vivify_rv2av_aelem:
1940 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
1941 /* this is the OPpDEREF action normally found at the end of
1942 * ops like aelem, helem, rv2sv */
1943 sv = vivify_ref(sv, OPpDEREF_AV);
1944 /* FALLTHROUGH */
1945
1946 do_AV_rv2av_aelem:
1947 /* this is basically a copy of pp_rv2av when it just has the
1948 * sKR/1 flags */
1949 SvGETMAGIC(sv);
1950 if (LIKELY(SvROK(sv))) {
1951 if (UNLIKELY(SvAMAGIC(sv))) {
1952 sv = amagic_deref_call(sv, to_av_amg);
1953 }
1954 sv = SvRV(sv);
1955 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
1956 DIE(aTHX_ "Not an ARRAY reference");
1957 }
1958 else if (SvTYPE(sv) != SVt_PVAV) {
1959 if (!isGV_with_GP(sv))
1960 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
1961 sv = MUTABLE_SV(GvAVn((GV*)sv));
1962 }
1963 /* FALLTHROUGH */
1964
1965 do_AV_aelem:
1966 {
1967 /* retrieve the key; this may be either a lexical or package
1968 * var (whose index/ptr is stored as an item) or a signed
1969 * integer constant stored as an item.
1970 */
1971 SV *elemsv;
1972 IV elem = 0; /* to shut up stupid compiler warnings */
1973
1974
1975 assert(SvTYPE(sv) == SVt_PVAV);
1976
1977 switch (actions & MDEREF_INDEX_MASK) {
1978 case MDEREF_INDEX_none:
1979 goto finish;
1980 case MDEREF_INDEX_const:
1981 elem = (++items)->iv;
1982 break;
1983 case MDEREF_INDEX_padsv:
1984 elemsv = PAD_SVl((++items)->pad_offset);
1985 goto check_elem;
1986 case MDEREF_INDEX_gvsv:
1987 elemsv = UNOP_AUX_item_sv(++items);
1988 assert(isGV_with_GP(elemsv));
1989 elemsv = GvSVn((GV*)elemsv);
1990 check_elem:
1991 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
1992 && ckWARN(WARN_MISC)))
1993 Perl_warner(aTHX_ packWARN(WARN_MISC),
1994 "Use of reference \"%"SVf"\" as array index",
1995 SVfARG(elemsv));
1996 /* the only time that S_find_uninit_var() needs this
1997 * is to determine which index value triggered the
1998 * undef warning. So just update it here. Note that
1999 * since we don't save and restore this var (e.g. for
2000 * tie or overload execution), its value will be
2001 * meaningless apart from just here */
2002 PL_multideref_pc = items;
2003 elem = SvIV(elemsv);
2004 break;
2005 }
2006
2007
2008 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2009
2010 if (!(actions & MDEREF_FLAG_last)) {
2011 SV** svp = av_fetch((AV*)sv, elem, 1);
2012 if (!svp || ! (sv=*svp))
2013 DIE(aTHX_ PL_no_aelem, elem);
2014 break;
2015 }
2016
2017 if (PL_op->op_private &
2018 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2019 {
2020 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2021 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2022 }
2023 else {
2024 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2025 sv = av_delete((AV*)sv, elem, discard);
2026 if (discard)
2027 return NORMAL;
2028 if (!sv)
2029 sv = &PL_sv_undef;
2030 }
2031 }
2032 else {
2033 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2034 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2035 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2036 bool preeminent = TRUE;
2037 AV *const av = (AV*)sv;
2038 SV** svp;
2039
2040 if (UNLIKELY(localizing)) {
2041 MAGIC *mg;
2042 HV *stash;
2043
2044 /* If we can determine whether the element exist,
2045 * Try to preserve the existenceness of a tied array
2046 * element by using EXISTS and DELETE if possible.
2047 * Fallback to FETCH and STORE otherwise. */
2048 if (SvCANEXISTDELETE(av))
2049 preeminent = av_exists(av, elem);
2050 }
2051
2052 svp = av_fetch(av, elem, lval && !defer);
2053
2054 if (lval) {
2055 if (!svp || !(sv = *svp)) {
2056 IV len;
2057 if (!defer)
2058 DIE(aTHX_ PL_no_aelem, elem);
2059 len = av_tindex(av);
2060 sv = sv_2mortal(newSVavdefelem(av,
2061 /* Resolve a negative index now, unless it points
2062 * before the beginning of the array, in which
2063 * case record it for error reporting in
2064 * magic_setdefelem. */
2065 elem < 0 && len + elem >= 0
2066 ? len + elem : elem, 1));
2067 }
2068 else {
2069 if (UNLIKELY(localizing)) {
2070 if (preeminent) {
2071 save_aelem(av, elem, svp);
2072 sv = *svp; /* may have changed */
2073 }
2074 else
2075 SAVEADELETE(av, elem);
2076 }
2077 }
2078 }
2079 else {
2080 sv = (svp ? *svp : &PL_sv_undef);
2081 /* see note in pp_helem() */
2082 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2083 mg_get(sv);
2084 }
2085 }
2086
2087 }
2088 finish:
2089 {
2090 dSP;
2091 XPUSHs(sv);
2092 RETURN;
2093 }
2094 /* NOTREACHED */
2095
2096
2097
2098
2099 case MDEREF_HV_padhv_helem: /* $lex{...} */
2100 sv = PAD_SVl((++items)->pad_offset);
2101 goto do_HV_helem;
2102
2103 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
2104 sv = UNOP_AUX_item_sv(++items);
2105 assert(isGV_with_GP(sv));
2106 sv = (SV*)GvHVn((GV*)sv);
2107 goto do_HV_helem;
2108
2109 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
2110 {
2111 dSP;
2112 sv = POPs;
2113 PUTBACK;
2114 goto do_HV_rv2hv_helem;
2115 }
2116
2117 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
2118 sv = UNOP_AUX_item_sv(++items);
2119 assert(isGV_with_GP(sv));
2120 sv = GvSVn((GV*)sv);
2121 goto do_HV_vivify_rv2hv_helem;
2122
2123 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
2124 sv = PAD_SVl((++items)->pad_offset);
2125 /* FALLTHROUGH */
2126
2127 do_HV_vivify_rv2hv_helem:
2128 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
2129 /* this is the OPpDEREF action normally found at the end of
2130 * ops like aelem, helem, rv2sv */
2131 sv = vivify_ref(sv, OPpDEREF_HV);
2132 /* FALLTHROUGH */
2133
2134 do_HV_rv2hv_helem:
2135 /* this is basically a copy of pp_rv2hv when it just has the
2136 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2137
2138 SvGETMAGIC(sv);
2139 if (LIKELY(SvROK(sv))) {
2140 if (UNLIKELY(SvAMAGIC(sv))) {
2141 sv = amagic_deref_call(sv, to_hv_amg);
2142 }
2143 sv = SvRV(sv);
2144 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2145 DIE(aTHX_ "Not a HASH reference");
2146 }
2147 else if (SvTYPE(sv) != SVt_PVHV) {
2148 if (!isGV_with_GP(sv))
2149 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2150 sv = MUTABLE_SV(GvHVn((GV*)sv));
2151 }
2152 /* FALLTHROUGH */
2153
2154 do_HV_helem:
2155 {
2156 /* retrieve the key; this may be either a lexical / package
2157 * var or a string constant, whose index/ptr is stored as an
2158 * item
2159 */
2160 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2161
2162 assert(SvTYPE(sv) == SVt_PVHV);
2163
2164 switch (actions & MDEREF_INDEX_MASK) {
2165 case MDEREF_INDEX_none:
2166 goto finish;
2167
2168 case MDEREF_INDEX_const:
2169 keysv = UNOP_AUX_item_sv(++items);
2170 break;
2171
2172 case MDEREF_INDEX_padsv:
2173 keysv = PAD_SVl((++items)->pad_offset);
2174 break;
2175
2176 case MDEREF_INDEX_gvsv:
2177 keysv = UNOP_AUX_item_sv(++items);
2178 keysv = GvSVn((GV*)keysv);
2179 break;
2180 }
2181
2182 /* see comment above about setting this var */
2183 PL_multideref_pc = items;
2184
2185
2186 /* ensure that candidate CONSTs have been HEKified */
2187 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2188 || SvTYPE(keysv) >= SVt_PVMG
2189 || !SvOK(keysv)
2190 || SvROK(keysv)
2191 || SvIsCOW_shared_hash(keysv));
2192
2193 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2194
2195 if (!(actions & MDEREF_FLAG_last)) {
2196 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2197 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2198 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2199 break;
2200 }
2201
2202 if (PL_op->op_private &
2203 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2204 {
2205 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2206 sv = hv_exists_ent((HV*)sv, keysv, 0)
2207 ? &PL_sv_yes : &PL_sv_no;
2208 }
2209 else {
2210 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2211 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2212 if (discard)
2213 return NORMAL;
2214 if (!sv)
2215 sv = &PL_sv_undef;
2216 }
2217 }
2218 else {
2219 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2220 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2221 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2222 bool preeminent = TRUE;
2223 SV **svp;
2224 HV * const hv = (HV*)sv;
2225 HE* he;
2226
2227 if (UNLIKELY(localizing)) {
2228 MAGIC *mg;
2229 HV *stash;
2230
2231 /* If we can determine whether the element exist,
2232 * Try to preserve the existenceness of a tied hash
2233 * element by using EXISTS and DELETE if possible.
2234 * Fallback to FETCH and STORE otherwise. */
2235 if (SvCANEXISTDELETE(hv))
2236 preeminent = hv_exists_ent(hv, keysv, 0);
2237 }
2238
2239 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2240 svp = he ? &HeVAL(he) : NULL;
2241
2242
2243 if (lval) {
2244 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2245 SV* lv;
2246 SV* key2;
2247 if (!defer)
2248 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2249 lv = sv_newmortal();
2250 sv_upgrade(lv, SVt_PVLV);
2251 LvTYPE(lv) = 'y';
2252 sv_magic(lv, key2 = newSVsv(keysv),
2253 PERL_MAGIC_defelem, NULL, 0);
2254 /* sv_magic() increments refcount */
2255 SvREFCNT_dec_NN(key2);
2256 LvTARG(lv) = SvREFCNT_inc_simple(hv);
2257 LvTARGLEN(lv) = 1;
2258 sv = lv;
2259 }
2260 else {
2261 if (localizing) {
2262 if (HvNAME_get(hv) && isGV(sv))
2263 save_gp(MUTABLE_GV(sv),
2264 !(PL_op->op_flags & OPf_SPECIAL));
2265 else if (preeminent) {
2266 save_helem_flags(hv, keysv, svp,
2267 (PL_op->op_flags & OPf_SPECIAL)
2268 ? 0 : SAVEf_SETMAGIC);
2269 sv = *svp; /* may have changed */
2270 }
2271 else
2272 SAVEHDELETE(hv, keysv);
2273 }
2274 }
2275 }
2276 else {
2277 sv = (svp && *svp ? *svp : &PL_sv_undef);
2278 /* see note in pp_helem() */
2279 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2280 mg_get(sv);
2281 }
2282 }
2283 goto finish;
2284 }
2285
2286 } /* switch */
2287
2288 actions >>= MDEREF_SHIFT;
2289 } /* while */
2290 /* NOTREACHED */
2291}
2292
2293
a0d0e21e
LW
2294PP(pp_iter)
2295{
20b7effb 2296 dSP;
eb578fdb 2297 PERL_CONTEXT *cx;
7d6c2cef 2298 SV *oldsv;
1d7c1841 2299 SV **itersvp;
a0d0e21e 2300
924508f0 2301 EXTEND(SP, 1);
a0d0e21e 2302 cx = &cxstack[cxstack_ix];
1d7c1841 2303 itersvp = CxITERVAR(cx);
a48ce6be
DM
2304
2305 switch (CxTYPE(cx)) {
17c91640 2306
b552b52c
DM
2307 case CXt_LOOP_LAZYSV: /* string increment */
2308 {
2309 SV* cur = cx->blk_loop.state_u.lazysv.cur;
2310 SV *end = cx->blk_loop.state_u.lazysv.end;
2311 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2312 It has SvPVX of "" and SvCUR of 0, which is what we want. */
2313 STRLEN maxlen = 0;
2314 const char *max = SvPV_const(end, maxlen);
5d9574c1 2315 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
b552b52c
DM
2316 RETPUSHNO;
2317
2318 oldsv = *itersvp;
5d9574c1 2319 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
b552b52c
DM
2320 /* safe to reuse old SV */
2321 sv_setsv(oldsv, cur);
a48ce6be 2322 }
b552b52c
DM
2323 else
2324 {
2325 /* we need a fresh SV every time so that loop body sees a
2326 * completely new SV for closures/references to work as
2327 * they used to */
2328 *itersvp = newSVsv(cur);
fc2b2dca 2329 SvREFCNT_dec_NN(oldsv);
b552b52c
DM
2330 }
2331 if (strEQ(SvPVX_const(cur), max))
2332 sv_setiv(cur, 0); /* terminate next time */
2333 else
2334 sv_inc(cur);
2335 break;
2336 }
a48ce6be 2337
fcef60b4
DM
2338 case CXt_LOOP_LAZYIV: /* integer increment */
2339 {
2340 IV cur = cx->blk_loop.state_u.lazyiv.cur;
5d9574c1 2341 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
89ea2908 2342 RETPUSHNO;
7f61b687 2343
fcef60b4 2344 oldsv = *itersvp;
3db8f154 2345 /* don't risk potential race */
5d9574c1 2346 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
eaa5c2d6 2347 /* safe to reuse old SV */
fcef60b4 2348 sv_setiv(oldsv, cur);
eaa5c2d6 2349 }
1c846c1f 2350 else
eaa5c2d6
GA
2351 {
2352 /* we need a fresh SV every time so that loop body sees a
2353 * completely new SV for closures/references to work as they
2354 * used to */
fcef60b4 2355 *itersvp = newSViv(cur);
fc2b2dca 2356 SvREFCNT_dec_NN(oldsv);
eaa5c2d6 2357 }
a2309040 2358
5d9574c1 2359 if (UNLIKELY(cur == IV_MAX)) {
cdc1aa42
NC
2360 /* Handle end of range at IV_MAX */
2361 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2362 } else
2363 ++cx->blk_loop.state_u.lazyiv.cur;
a48ce6be 2364 break;
fcef60b4 2365 }
a48ce6be 2366
b552b52c 2367 case CXt_LOOP_FOR: /* iterate array */
7d6c2cef 2368 {
89ea2908 2369
7d6c2cef
DM
2370 AV *av = cx->blk_loop.state_u.ary.ary;
2371 SV *sv;
2372 bool av_is_stack = FALSE;
a8a20bb6 2373 IV ix;
7d6c2cef 2374
de080daa
DM
2375 if (!av) {
2376 av_is_stack = TRUE;
2377 av = PL_curstack;
2378 }
2379 if (PL_op->op_private & OPpITER_REVERSED) {
a8a20bb6 2380 ix = --cx->blk_loop.state_u.ary.ix;
5d9574c1 2381 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
de080daa 2382 RETPUSHNO;
de080daa
DM
2383 }
2384 else {
a8a20bb6 2385 ix = ++cx->blk_loop.state_u.ary.ix;
5d9574c1 2386 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
de080daa 2387 RETPUSHNO;
a8a20bb6 2388 }
de080daa 2389
5d9574c1 2390 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
a8a20bb6
DM
2391 SV * const * const svp = av_fetch(av, ix, FALSE);
2392 sv = svp ? *svp : NULL;
2393 }
2394 else {
2395 sv = AvARRAY(av)[ix];
de080daa 2396 }
ef3e5ea9 2397
d39c26a6
FC
2398 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
2399 SvSetMagicSV(*itersvp, sv);
2400 break;
2401 }
2402
5d9574c1
DM
2403 if (LIKELY(sv)) {
2404 if (UNLIKELY(SvIS_FREED(sv))) {
f38aa882
DM
2405 *itersvp = NULL;
2406 Perl_croak(aTHX_ "Use of freed value in iteration");
2407 }
60779a30 2408 if (SvPADTMP(sv)) {
8e079c2a 2409 sv = newSVsv(sv);
60779a30 2410 }
8e079c2a
FC
2411 else {
2412 SvTEMP_off(sv);
2413 SvREFCNT_inc_simple_void_NN(sv);
2414 }
de080daa 2415 }
a600f7e6 2416 else if (!av_is_stack) {
199f858d 2417 sv = newSVavdefelem(av, ix, 0);
de080daa 2418 }
a600f7e6
FC
2419 else
2420 sv = &PL_sv_undef;
a0d0e21e 2421
de080daa
DM
2422 oldsv = *itersvp;
2423 *itersvp = sv;
2424 SvREFCNT_dec(oldsv);
de080daa 2425 break;
7d6c2cef 2426 }
a48ce6be
DM
2427
2428 default:
2429 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2430 }
b552b52c 2431 RETPUSHYES;
a0d0e21e
LW
2432}
2433
ef07e810
DM
2434/*
2435A description of how taint works in pattern matching and substitution.
2436
284167a5
SM
2437This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2438NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2439
4e19c54b 2440While the pattern is being assembled/concatenated and then compiled,
284167a5
SM
2441PL_tainted will get set (via TAINT_set) if any component of the pattern
2442is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
2443the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1738e041
DM
2444TAINT_get). It will also be set if any component of the pattern matches
2445based on locale-dependent behavior.
ef07e810 2446
0ab462a6
DM
2447When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2448the pattern is marked as tainted. This means that subsequent usage, such
284167a5
SM
2449as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2450on the new pattern too.
ef07e810 2451
272d35c9 2452RXf_TAINTED_SEEN is used post-execution by the get magic code
ef07e810
DM
2453of $1 et al to indicate whether the returned value should be tainted.
2454It is the responsibility of the caller of the pattern (i.e. pp_match,
2455pp_subst etc) to set this flag for any other circumstances where $1 needs
2456to be tainted.
2457
2458The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2459
2460There are three possible sources of taint
2461 * the source string
2462 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2463 * the replacement string (or expression under /e)
2464
2465There are four destinations of taint and they are affected by the sources
2466according to the rules below:
2467
2468 * the return value (not including /r):
2469 tainted by the source string and pattern, but only for the
2470 number-of-iterations case; boolean returns aren't tainted;
2471 * the modified string (or modified copy under /r):
2472 tainted by the source string, pattern, and replacement strings;
2473 * $1 et al:
2474 tainted by the pattern, and under 'use re "taint"', by the source
2475 string too;
2476 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2477 should always be unset before executing subsequent code.
2478
2479The overall action of pp_subst is:
2480
2481 * at the start, set bits in rxtainted indicating the taint status of
2482 the various sources.
2483
2484 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2485 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2486 pattern has subsequently become tainted via locale ops.
2487
2488 * If control is being passed to pp_substcont to execute a /e block,
2489 save rxtainted in the CXt_SUBST block, for future use by
2490 pp_substcont.
2491
2492 * Whenever control is being returned to perl code (either by falling
2493 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2494 use the flag bits in rxtainted to make all the appropriate types of
0ab462a6
DM
2495 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2496 et al will appear tainted.
ef07e810
DM
2497
2498pp_match is just a simpler version of the above.
2499
2500*/
2501
a0d0e21e
LW
2502PP(pp_subst)
2503{
20b7effb 2504 dSP; dTARG;
eb578fdb 2505 PMOP *pm = cPMOP;
a0d0e21e 2506 PMOP *rpm = pm;
eb578fdb 2507 char *s;
a0d0e21e 2508 char *strend;
5c144d81 2509 const char *c;
a0d0e21e 2510 STRLEN clen;
3c6ef0a5
FC
2511 SSize_t iters = 0;
2512 SSize_t maxiters;
a0d0e21e 2513 bool once;
ef07e810
DM
2514 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2515 See "how taint works" above */
a0d0e21e 2516 char *orig;
1ed74d04 2517 U8 r_flags;
eb578fdb 2518 REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
2519 STRLEN len;
2520 int force_on_match = 0;
0bcc34c2 2521 const I32 oldsave = PL_savestack_ix;
792b2c16 2522 STRLEN slen;
26a74523 2523 bool doutf8 = FALSE; /* whether replacement is in utf8 */
db2c6cb3 2524#ifdef PERL_ANY_COW
ed252734
NC
2525 bool is_cow;
2526#endif
a0714e2c 2527 SV *nsv = NULL;
b770e143 2528 /* known replacement string? */
eb578fdb 2529 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
a0d0e21e 2530
f410a211
NC
2531 PERL_ASYNC_CHECK();
2532
533c011a 2533 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 2534 TARG = POPs;
6ffceeb7 2535 else if (ARGTARG)
59f00321 2536 GETTARGET;
a0d0e21e 2537 else {
54b9620d 2538 TARG = DEFSV;
a0d0e21e 2539 EXTEND(SP,1);
1c846c1f 2540 }
d9f424b2 2541
64534138 2542 SvGETMAGIC(TARG); /* must come before cow check */
db2c6cb3 2543#ifdef PERL_ANY_COW
ed252734
NC
2544 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2545 because they make integers such as 256 "false". */
2546 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2547#else
765f542d
NC
2548 if (SvIsCOW(TARG))
2549 sv_force_normal_flags(TARG,0);
ed252734 2550#endif
8ca8a454 2551 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
8ca8a454
NC
2552 && (SvREADONLY(TARG)
2553 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2554 || SvTYPE(TARG) > SVt_PVLV)
2555 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
cb077ed2 2556 Perl_croak_no_modify();
8ec5e241
NIS
2557 PUTBACK;
2558
6ac6605d
DM
2559 orig = SvPV_nomg(TARG, len);
2560 /* note we don't (yet) force the var into being a string; if we fail
2561 * to match, we leave as-is; on successful match howeverm, we *will*
2562 * coerce into a string, then repeat the match */
4499db73 2563 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
a0d0e21e 2564 force_on_match = 1;
20be6587
DM
2565
2566 /* only replace once? */
2567 once = !(rpm->op_pmflags & PMf_GLOBAL);
2568
ef07e810 2569 /* See "how taint works" above */
284167a5 2570 if (TAINTING_get) {
20be6587
DM
2571 rxtainted = (
2572 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
284167a5 2573 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
20be6587
DM
2574 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2575 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2576 ? SUBST_TAINT_BOOLRET : 0));
2577 TAINT_NOT;
2578 }
a12c0f56 2579
a0d0e21e 2580 force_it:
6ac6605d
DM
2581 if (!pm || !orig)
2582 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
a0d0e21e 2583
6ac6605d
DM
2584 strend = orig + len;
2585 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
792b2c16
JH
2586 maxiters = 2 * slen + 10; /* We can match twice at each
2587 position, once with zero-length,
2588 second time with non-zero. */
a0d0e21e 2589
6a97c51d 2590 if (!RX_PRELEN(rx) && PL_curpm
8d919b0a 2591 && !ReANY(rx)->mother_re) {
3280af22 2592 pm = PL_curpm;
aaa362c4 2593 rx = PM_GETRE(pm);
a0d0e21e 2594 }
6502e081 2595
6e240d0b 2596#ifdef PERL_SAWAMPERSAND
6502e081
DM
2597 r_flags = ( RX_NPARENS(rx)
2598 || PL_sawampersand
6502e081 2599 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 2600 || (rpm->op_pmflags & PMf_KEEPCOPY)
6502e081
DM
2601 )
2602 ? REXEC_COPY_STR
2603 : 0;
6e240d0b
FC
2604#else
2605 r_flags = REXEC_COPY_STR;
2606#endif
7fba1cd6 2607
0395280b 2608 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
8b64c330 2609 {
5e79dfb9
DM
2610 SPAGAIN;
2611 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2612 LEAVE_SCOPE(oldsave);
2613 RETURN;
2614 }
1754320d
FC
2615 PL_curpm = pm;
2616
71be2cbc 2617 /* known replacement string? */
f272994b 2618 if (dstr) {
8514a05a
JH
2619 /* replacement needing upgrading? */
2620 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2621 nsv = sv_newmortal();
4a176938 2622 SvSetSV(nsv, dstr);
47e13f24 2623 if (IN_ENCODING)
ad2de1b2 2624 sv_recode_to_utf8(nsv, _get_encoding());
8514a05a
JH
2625 else
2626 sv_utf8_upgrade(nsv);
5c144d81 2627 c = SvPV_const(nsv, clen);
4a176938
JH
2628 doutf8 = TRUE;
2629 }
2630 else {
5c144d81 2631 c = SvPV_const(dstr, clen);
4a176938 2632 doutf8 = DO_UTF8(dstr);
8514a05a 2633 }
bb933b9b
FC
2634
2635 if (SvTAINTED(dstr))
2636 rxtainted |= SUBST_TAINT_REPL;
f272994b
A
2637 }
2638 else {
6136c704 2639 c = NULL;
f272994b
A
2640 doutf8 = FALSE;
2641 }
2642
71be2cbc 2643 /* can do inplace substitution? */
ed252734 2644 if (c
db2c6cb3 2645#ifdef PERL_ANY_COW
ed252734
NC
2646 && !is_cow
2647#endif
fbfb1899 2648 && (I32)clen <= RX_MINLENRET(rx)
9cefd268
FC
2649 && ( once
2650 || !(r_flags & REXEC_COPY_STR)
2651 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2652 )
dbc200c5 2653 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
8ca8a454
NC
2654 && (!doutf8 || SvUTF8(TARG))
2655 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
8b030b38 2656 {
ec911639 2657
db2c6cb3 2658#ifdef PERL_ANY_COW
ed252734 2659 if (SvIsCOW(TARG)) {
f7a8268c 2660 if (!force_on_match)
ed252734 2661 goto have_a_cow;
f7a8268c 2662 assert(SvVOK(TARG));
ed252734
NC
2663 }
2664#endif
71be2cbc 2665 if (force_on_match) {
6ac6605d
DM
2666 /* redo the first match, this time with the orig var
2667 * forced into being a string */
71be2cbc 2668 force_on_match = 0;
6ac6605d 2669 orig = SvPV_force_nomg(TARG, len);
71be2cbc
PP
2670 goto force_it;
2671 }
39b40493 2672
71be2cbc 2673 if (once) {
c67ab8f2 2674 char *d, *m;
20be6587
DM
2675 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2676 rxtainted |= SUBST_TAINT_PAT;
07bc277f
NC
2677 m = orig + RX_OFFS(rx)[0].start;
2678 d = orig + RX_OFFS(rx)[0].end;
71be2cbc
PP
2679 s = orig;
2680 if (m - s > strend - d) { /* faster to shorten from end */
2ec7214c 2681 I32 i;
71be2cbc
PP
2682 if (clen) {
2683 Copy(c, m, clen, char);
2684 m += clen;
a0d0e21e 2685 }
71be2cbc
PP
2686 i = strend - d;
2687 if (i > 0) {
2688 Move(d, m, i, char);
2689 m += i;
a0d0e21e 2690 }
71be2cbc
PP
2691 *m = '\0';
2692 SvCUR_set(TARG, m - s);
2693 }
2ec7214c
DM
2694 else { /* faster from front */
2695 I32 i = m - s;
71be2cbc 2696 d -= clen;
2ec7214c
DM
2697 if (i > 0)
2698 Move(s, d - i, i, char);
71be2cbc 2699 sv_chop(TARG, d-i);
71be2cbc 2700 if (clen)
c947cd8d 2701 Copy(c, d, clen, char);
71be2cbc 2702 }
8ec5e241 2703 SPAGAIN;
8ca8a454 2704 PUSHs(&PL_sv_yes);
71be2cbc
PP
2705 }
2706 else {
c67ab8f2 2707 char *d, *m;
0395280b 2708 d = s = RX_OFFS(rx)[0].start + orig;
71be2cbc 2709 do {
2b25edcf 2710 I32 i;
5d9574c1 2711 if (UNLIKELY(iters++ > maxiters))
cea2e8a9 2712 DIE(aTHX_ "Substitution loop");
5d9574c1 2713 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
20be6587 2714 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2715 m = RX_OFFS(rx)[0].start + orig;
155aba94 2716 if ((i = m - s)) {
71be2cbc
PP
2717 if (s != d)
2718 Move(s, d, i, char);
2719 d += i;
a0d0e21e 2720 }
71be2cbc
PP
2721 if (clen) {
2722 Copy(c, d, clen, char);
2723 d += clen;
2724 }
07bc277f 2725 s = RX_OFFS(rx)[0].end + orig;
7ce41e5c
FC
2726 } while (CALLREGEXEC(rx, s, strend, orig,
2727 s == m, /* don't match same null twice */
f722798b 2728 TARG, NULL,
d5e7783a 2729 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
71be2cbc 2730 if (s != d) {
2b25edcf 2731 I32 i = strend - s;
aa07b2f6 2732 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 2733 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2734 }
8ec5e241 2735 SPAGAIN;
3c6ef0a5 2736 mPUSHi(iters);
a0d0e21e
LW
2737 }
2738 }
ff6e92e8 2739 else {
1754320d 2740 bool first;
c67ab8f2 2741 char *m;
1754320d 2742 SV *repl;
a0d0e21e 2743 if (force_on_match) {
6ac6605d
DM
2744 /* redo the first match, this time with the orig var
2745 * forced into being a string */
a0d0e21e 2746 force_on_match = 0;
0c1438a1
NC
2747 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2748 /* I feel that it should be possible to avoid this mortal copy
2749 given that the code below copies into a new destination.
2750 However, I suspect it isn't worth the complexity of
2751 unravelling the C<goto force_it> for the small number of
2752 cases where it would be viable to drop into the copy code. */
2753 TARG = sv_2mortal(newSVsv(TARG));
2754 }
6ac6605d 2755 orig = SvPV_force_nomg(TARG, len);
a0d0e21e
LW
2756 goto force_it;
2757 }
db2c6cb3 2758#ifdef PERL_ANY_COW
ed252734
NC
2759 have_a_cow:
2760#endif
20be6587
DM
2761 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2762 rxtainted |= SUBST_TAINT_PAT;
1754320d 2763 repl = dstr;
0395280b
DM
2764 s = RX_OFFS(rx)[0].start + orig;
2765 dstr = newSVpvn_flags(orig, s-orig,
2766 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
a0d0e21e 2767 if (!c) {
eb578fdb 2768 PERL_CONTEXT *cx;
8ec5e241 2769 SPAGAIN;
0395280b 2770 m = orig;
20be6587
DM
2771 /* note that a whole bunch of local vars are saved here for
2772 * use by pp_substcont: here's a list of them in case you're
2773 * searching for places in this sub that uses a particular var:
2774 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2775 * s m strend rx once */
a0d0e21e 2776 PUSHSUBST(cx);
20e98b0f 2777 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
a0d0e21e 2778 }
1754320d 2779 first = TRUE;
a0d0e21e 2780 do {
5d9574c1 2781 if (UNLIKELY(iters++ > maxiters))
cea2e8a9 2782 DIE(aTHX_ "Substitution loop");
5d9574c1 2783 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
20be6587 2784 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2785 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
c67ab8f2
DM
2786 char *old_s = s;
2787 char *old_orig = orig;
6502e081 2788 assert(RX_SUBOFFSET(rx) == 0);
c67ab8f2 2789
07bc277f 2790 orig = RX_SUBBEG(rx);
c67ab8f2
DM
2791 s = orig + (old_s - old_orig);
2792 strend = s + (strend - old_s);
a0d0e21e 2793 }
07bc277f 2794 m = RX_OFFS(rx)[0].start + orig;
64534138 2795 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
07bc277f 2796 s = RX_OFFS(rx)[0].end + orig;
1754320d
FC
2797 if (first) {
2798 /* replacement already stringified */
2799 if (clen)
64534138 2800 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
1754320d
FC
2801 first = FALSE;
2802 }
2803 else {
47e13f24 2804 if (IN_ENCODING) {
1754320d
FC
2805 if (!nsv) nsv = sv_newmortal();
2806 sv_copypv(nsv, repl);
ad2de1b2 2807 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
1754320d
FC
2808 sv_catsv(dstr, nsv);
2809 }
2810 else sv_catsv(dstr, repl);
5d9574c1 2811 if (UNLIKELY(SvTAINTED(repl)))
bb933b9b 2812 rxtainted |= SUBST_TAINT_REPL;
1754320d 2813 }
a0d0e21e
LW
2814 if (once)
2815 break;
f9f4320a 2816 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
d5e7783a
DM
2817 TARG, NULL,
2818 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
64534138 2819 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
748a9306 2820
8ca8a454
NC
2821 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2822 /* From here on down we're using the copy, and leaving the original
2823 untouched. */
2824 TARG = dstr;
2825 SPAGAIN;
2826 PUSHs(dstr);
2827 } else {
db2c6cb3 2828#ifdef PERL_ANY_COW
8ca8a454
NC
2829 /* The match may make the string COW. If so, brilliant, because
2830 that's just saved us one malloc, copy and free - the regexp has
2831 donated the old buffer, and we malloc an entirely new one, rather
2832 than the regexp malloc()ing a buffer and copying our original,
2833 only for us to throw it away here during the substitution. */
2834 if (SvIsCOW(TARG)) {
2835 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2836 } else
ed252734 2837#endif
8ca8a454
NC
2838 {
2839 SvPV_free(TARG);
2840 }
2841 SvPV_set(TARG, SvPVX(dstr));
2842 SvCUR_set(TARG, SvCUR(dstr));
2843 SvLEN_set(TARG, SvLEN(dstr));
64534138 2844 SvFLAGS(TARG) |= SvUTF8(dstr);
8ca8a454 2845 SvPV_set(dstr, NULL);
748a9306 2846
8ca8a454 2847 SPAGAIN;
3c6ef0a5 2848 mPUSHi(iters);
8ca8a454
NC
2849 }
2850 }
2851
2852 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2853 (void)SvPOK_only_UTF8(TARG);
a0d0e21e 2854 }
20be6587 2855
ef07e810 2856 /* See "how taint works" above */
284167a5 2857 if (TAINTING_get) {
20be6587
DM
2858 if ((rxtainted & SUBST_TAINT_PAT) ||
2859 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2860 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2861 )
2862 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2863
2864 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2865 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2866 )
2867 SvTAINTED_on(TOPs); /* taint return value */
2868 else
2869 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2870
2871 /* needed for mg_set below */
284167a5
SM
2872 TAINT_set(
2873 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2874 );
20be6587
DM
2875 SvTAINT(TARG);
2876 }
2877 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2878 TAINT_NOT;
f1a76097
DM
2879 LEAVE_SCOPE(oldsave);
2880 RETURN;
a0d0e21e
LW
2881}
2882
2883PP(pp_grepwhile)
2884{
20b7effb 2885 dSP;
a0d0e21e
LW
2886
2887 if (SvTRUEx(POPs))
3280af22
NIS
2888 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2889 ++*PL_markstack_ptr;
b2a2a901 2890 FREETMPS;
d343c3ef 2891 LEAVE_with_name("grep_item"); /* exit inner scope */
a0d0e21e
LW
2892
2893 /* All done yet? */
5d9574c1 2894 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
a0d0e21e 2895 I32 items;
c4420975 2896 const I32 gimme = GIMME_V;
a0d0e21e 2897
d343c3ef 2898 LEAVE_with_name("grep"); /* exit outer scope */
a0d0e21e 2899 (void)POPMARK; /* pop src */
3280af22 2900 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2901 (void)POPMARK; /* pop dst */
3280af22 2902 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2903 if (gimme == G_SCALAR) {
7cc47870 2904 if (PL_op->op_private & OPpGREP_LEX) {
c4420975 2905 SV* const sv = sv_newmortal();
7cc47870
RGS
2906 sv_setiv(sv, items);
2907 PUSHs(sv);
2908 }
2909 else {
2910 dTARGET;
2911 XPUSHi(items);
2912 }
a0d0e21e 2913 }
54310121
PP
2914 else if (gimme == G_ARRAY)
2915 SP += items;
a0d0e21e
LW
2916 RETURN;
2917 }
2918 else {
2919 SV *src;
2920
d343c3ef 2921 ENTER_with_name("grep_item"); /* enter inner scope */
1d7c1841 2922 SAVEVPTR(PL_curpm);
a0d0e21e 2923
3280af22 2924 src = PL_stack_base[*PL_markstack_ptr];
60779a30 2925 if (SvPADTMP(src)) {
a0ed822e
FC
2926 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2927 PL_tmps_floor++;
2928 }
a0d0e21e 2929 SvTEMP_off(src);
59f00321
RGS
2930 if (PL_op->op_private & OPpGREP_LEX)
2931 PAD_SVl(PL_op->op_targ) = src;
2932 else
414bf5ae 2933 DEFSV_set(src);
a0d0e21e
LW
2934
2935 RETURNOP(cLOGOP->op_other);
2936 }
2937}
2938
2939PP(pp_leavesub)
2940{
20b7effb 2941 dSP;
a0d0e21e
LW
2942 SV **mark;
2943 SV **newsp;
2944 PMOP *newpm;
2945 I32 gimme;
eb578fdb 2946 PERL_CONTEXT *cx;
b0d9ce38 2947 SV *sv;
a0d0e21e 2948
9850bf21
RH
2949 if (CxMULTICALL(&cxstack[cxstack_ix]))
2950 return 0;
2951
a0d0e21e 2952 POPBLOCK(cx,newpm);
5dd42e15 2953 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2954
a1f49e72 2955 TAINT_NOT;
a0d0e21e
LW
2956 if (gimme == G_SCALAR) {
2957 MARK = newsp + 1;
5d9574c1 2958 if (LIKELY(MARK <= SP)) {
a8bba7fa 2959 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
6f48390a
FC
2960 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2961 && !SvMAGICAL(TOPs)) {
a29cdaf0
IZ
2962 *MARK = SvREFCNT_inc(TOPs);
2963 FREETMPS;
2964 sv_2mortal(*MARK);
cd06dffe
GS
2965 }
2966 else {
959e3673 2967 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2968 FREETMPS;
959e3673 2969 *MARK = sv_mortalcopy(sv);
fc2b2dca 2970 SvREFCNT_dec_NN(sv);
a29cdaf0 2971 }
cd06dffe 2972 }
6f48390a
FC
2973 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2974 && !SvMAGICAL(TOPs)) {
767eda44 2975 *MARK = TOPs;
767eda44 2976 }
cd06dffe 2977 else
767eda44 2978 *MARK = sv_mortalcopy(TOPs);
cd06dffe
GS
2979 }
2980 else {
f86702cc 2981 MEXTEND(MARK, 0);
3280af22 2982 *MARK = &PL_sv_undef;
a0d0e21e
LW
2983 }
2984 SP = MARK;
2985 }
54310121 2986 else if (gimme == G_ARRAY) {
f86702cc 2987 for (MARK = newsp + 1; MARK <= SP; MARK++) {
6f48390a
FC
2988 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2989 || SvMAGICAL(*MARK)) {
f86702cc 2990 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2991 TAINT_NOT; /* Each item is independent */
2992 }
f86702cc 2993 }
a0d0e21e 2994 }
f86702cc 2995 PUTBACK;
1c846c1f 2996
a57c6685 2997 LEAVE;
b0d9ce38 2998 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
25375124 2999 cxstack_ix--;
3280af22 3000 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 3001
b0d9ce38 3002 LEAVESUB(sv);
f39bc417 3003 return cx->blk_sub.retop;
a0d0e21e
LW
3004}
3005
3006PP(pp_entersub)
3007{
20b7effb 3008 dSP; dPOPss;
a0d0e21e 3009 GV *gv;
eb578fdb
KW
3010 CV *cv;
3011 PERL_CONTEXT *cx;
5d94fbed 3012 I32 gimme;
a9c4fd4e 3013 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e 3014
f5719c02 3015 if (UNLIKELY(!sv))
cea2e8a9 3016 DIE(aTHX_ "Not a CODE reference");
f5719c02
DM
3017 /* This is overwhelmingly the most common case: */
3018 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
313107ce
DM
3019 switch (SvTYPE(sv)) {
3020 case SVt_PVGV:
3021 we_have_a_glob:
3022 if (!(cv = GvCVu((const GV *)sv))) {
3023 HV *stash;
3024 cv = sv_2cv(sv, &stash, &gv, 0);
3025 }
3026 if (!cv) {
3027 ENTER;
3028 SAVETMPS;
3029 goto try_autoload;
3030 }
3031 break;
3032 case SVt_PVLV:
3033 if(isGV_with_GP(sv)) goto we_have_a_glob;
924ba076 3034 /* FALLTHROUGH */
313107ce
DM
3035 default:
3036 if (sv == &PL_sv_yes) { /* unfound import, ignore */
3037 if (hasargs)
3038 SP = PL_stack_base + POPMARK;
3039 else
3040 (void)POPMARK;
3041 RETURN;
3042 }
3043 SvGETMAGIC(sv);
3044 if (SvROK(sv)) {
3045 if (SvAMAGIC(sv)) {
3046 sv = amagic_deref_call(sv, to_cv_amg);
3047 /* Don't SPAGAIN here. */
3048 }
3049 }
3050 else {
3051 const char *sym;
3052 STRLEN len;
3053 if (!SvOK(sv))
3054 DIE(aTHX_ PL_no_usym, "a subroutine");
3055 sym = SvPV_nomg_const(sv, len);
3056 if (PL_op->op_private & HINT_STRICT_REFS)
3057 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
3058 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
3059 break;
3060 }
3061 cv = MUTABLE_CV(SvRV(sv));
3062 if (SvTYPE(cv) == SVt_PVCV)
3063 break;
924ba076 3064 /* FALLTHROUGH */
313107ce
DM
3065 case SVt_PVHV:
3066 case SVt_PVAV:
3067 DIE(aTHX_ "Not a CODE reference");
3068 /* This is the second most common case: */
3069 case SVt_PVCV:
3070 cv = MUTABLE_CV(sv);
3071 break;
3072 }
f5719c02 3073 }
a0d0e21e 3074
a57c6685 3075 ENTER;
a0d0e21e
LW
3076
3077 retry:
f5719c02 3078 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
541ed3a9 3079 DIE(aTHX_ "Closure prototype called");
f5719c02 3080 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
2f349aa0
NC
3081 GV* autogv;
3082 SV* sub_name;
3083
3084 /* anonymous or undef'd function leaves us no recourse */
ae77754a
FC
3085 if (CvLEXICAL(cv) && CvHASGV(cv))
3086 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
ecf05a58 3087 SVfARG(cv_name(cv, NULL, 0)));
ae77754a 3088 if (CvANON(cv) || !CvHASGV(cv)) {
2f349aa0 3089 DIE(aTHX_ "Undefined subroutine called");
7d2057d8 3090 }
2f349aa0
NC
3091
3092 /* autoloaded stub? */
ae77754a 3093 if (cv != GvCV(gv = CvGV(cv))) {
2f349aa0
NC
3094 cv = GvCV(gv);
3095 }
3096 /* should call AUTOLOAD now? */
3097 else {
7b52d656 3098 try_autoload:
d1089224
BF
3099 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
3100 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2f349aa0
NC
3101 {
3102 cv = GvCV(autogv);
3103 }
2f349aa0 3104 else {
c220e1a1 3105 sorry:
2f349aa0 3106 sub_name = sv_newmortal();
6136c704 3107 gv_efullname3(sub_name, gv, NULL);
be2597df 3108 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2f349aa0
NC
3109 }
3110 }
3111 if (!cv)
c220e1a1 3112 goto sorry;
2f349aa0 3113 goto retry;
a0d0e21e
LW
3114 }
3115
f5719c02
DM
3116 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
3117 && !CvNODEBUG(cv)))
3118 {
005a8a35 3119 Perl_get_db_sub(aTHX_ &sv, cv);
a9ef256d
NC
3120 if (CvISXSUB(cv))
3121 PL_curcopdb = PL_curcop;
1ad62f64 3122 if (CvLVALUE(cv)) {
3123 /* check for lsub that handles lvalue subroutines */
07b605e5 3124 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
1ad62f64 3125 /* if lsub not found then fall back to DB::sub */
3126 if (!cv) cv = GvCV(PL_DBsub);
3127 } else {
3128 cv = GvCV(PL_DBsub);
3129 }
a9ef256d 3130
ccafdc96
RGS
3131 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
3132 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 3133 }
a0d0e21e 3134
f5719c02
DM
3135 gimme = GIMME_V;
3136
aed2304a 3137 if (!(CvISXSUB(cv))) {
f1025168 3138 /* This path taken at least 75% of the time */
a0d0e21e 3139 dMARK;
b70d5558 3140 PADLIST * const padlist = CvPADLIST(cv);
3689ad62 3141 I32 depth;
f5719c02 3142
a0d0e21e
LW
3143 PUSHBLOCK(cx, CXt_SUB, MARK);
3144 PUSHSUB(cx);
f39bc417 3145 cx->blk_sub.retop = PL_op->op_next;
3689ad62 3146 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3a76ca88 3147 PERL_STACK_OVERFLOW_CHECK();
3689ad62 3148 pad_push(padlist, depth);
a0d0e21e 3149 }
3a76ca88 3150 SAVECOMPPAD();
3689ad62 3151 PAD_SET_CUR_NOSAVE(padlist, depth);
f5719c02 3152 if (LIKELY(hasargs)) {
10533ace 3153 AV *const av = MUTABLE_AV(PAD_SVl(0));
bdf02c57
DM
3154 SSize_t items;
3155 AV **defavp;
3156
f5719c02 3157 if (UNLIKELY(AvREAL(av))) {
221373f0
GS
3158 /* @_ is normally not REAL--this should only ever
3159 * happen when DB::sub() calls things that modify @_ */
3160 av_clear(av);
3161 AvREAL_off(av);
3162 AvREIFY_on(av);
3163 }
bdf02c57
DM
3164 defavp = &GvAV(PL_defgv);
3165 cx->blk_sub.savearray = *defavp;
3166 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
dd2155a4 3167 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 3168 cx->blk_sub.argarray = av;
bdf02c57 3169 items = SP - MARK;
a0d0e21e 3170
f5719c02 3171 if (UNLIKELY(items - 1 > AvMAX(av))) {
77d27ef6
SF
3172 SV **ary = AvALLOC(av);
3173 AvMAX(av) = items - 1;
3174 Renew(ary, items, SV*);
3175 AvALLOC(av) = ary;
3176 AvARRAY(av) = ary;
3177 }
3178
bdf02c57 3179 Copy(MARK+1,AvARRAY(av),items,SV*);
93965878 3180 AvFILLp(av) = items - 1;
1c846c1f 3181
b479c9f2 3182 MARK = AvARRAY(av);
a0d0e21e
LW
3183 while (items--) {
3184 if (*MARK)
b479c9f2 3185 {
60779a30 3186 if (SvPADTMP(*MARK)) {
b479c9f2 3187 *MARK = sv_mortalcopy(*MARK);
60779a30 3188 }
a0d0e21e 3189 SvTEMP_off(*MARK);
b479c9f2 3190 }
a0d0e21e
LW
3191 MARK++;
3192 }
3193 }
b479c9f2 3194 SAVETMPS;
f5719c02
DM
3195 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3196 !CvLVALUE(cv)))
da1dff94 3197 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
4a925ff6
GS
3198 /* warning must come *after* we fully set up the context
3199 * stuff so that __WARN__ handlers can safely dounwind()
3200 * if they want to
3201 */
3689ad62 3202 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
f5719c02
DM
3203 && ckWARN(WARN_RECURSION)
3204 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
4a925ff6 3205 sub_crush_depth(cv);
a0d0e21e
LW
3206 RETURNOP(CvSTART(cv));
3207 }
f1025168 3208 else {
de935cc9 3209 SSize_t markix = TOPMARK;
f1025168 3210
b479c9f2 3211 SAVETMPS;
3a76ca88 3212 PUTBACK;
f1025168 3213
f5719c02 3214 if (UNLIKELY(((PL_op->op_private
4587c532
FC
3215 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
3216 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
f5719c02 3217 !CvLVALUE(cv)))
4587c532
FC
3218 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3219
f5719c02 3220 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3a76ca88
RGS
3221 /* Need to copy @_ to stack. Alternative may be to
3222 * switch stack to @_, and copy return values
3223 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3224 AV * const av = GvAV(PL_defgv);
ad39f3a2 3225 const SSize_t items = AvFILL(av) + 1;
3a76ca88
RGS
3226
3227 if (items) {
dd2a7f90 3228 SSize_t i = 0;
ad39f3a2 3229 const bool m = cBOOL(SvRMAGICAL(av));
3a76ca88
RGS
3230 /* Mark is at the end of the stack. */
3231 EXTEND(SP, items);
dd2a7f90 3232 for (; i < items; ++i)
ad39f3a2
FC
3233 {
3234 SV *sv;
3235 if (m) {
3236 SV ** const svp = av_fetch(av, i, 0);
3237 sv = svp ? *svp : NULL;
3238 }
3239 else sv = AvARRAY(av)[i];
3240 if (sv) SP[i+1] = sv;
dd2a7f90 3241 else {
199f858d 3242 SP[i+1] = newSVavdefelem(av, i, 1);
dd2a7f90 3243 }
ad39f3a2 3244 }
3a76ca88
RGS
3245 SP += items;
3246 PUTBACK ;
3247 }
3248 }
3455055f
FC
3249 else {
3250 SV **mark = PL_stack_base + markix;
de935cc9 3251 SSize_t items = SP - mark;
3455055f
FC
3252 while (items--) {
3253 mark++;
60779a30 3254 if (*mark && SvPADTMP(*mark)) {
3455055f 3255 *mark = sv_mortalcopy(*mark);
60779a30 3256 }
3455055f
FC
3257 }
3258 }
3a76ca88 3259 /* We assume first XSUB in &DB::sub is the called one. */
f5719c02 3260 if (UNLIKELY(PL_curcopdb)) {
3a76ca88
RGS
3261 SAVEVPTR(PL_curcop);
3262 PL_curcop = PL_curcopdb;
3263 PL_curcopdb = NULL;
3264 }
3265 /* Do we need to open block here? XXXX */
72df79cf 3266
3267 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3268 assert(CvXSUB(cv));
16c91539 3269 CvXSUB(cv)(aTHX_ cv);
3a76ca88
RGS
3270
3271 /* Enforce some sanity in scalar context. */
89a18b40
DM
3272 if (gimme == G_SCALAR) {
3273 SV **svp = PL_stack_base + markix + 1;
3274 if (svp != PL_stack_sp) {
3275 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
3276 PL_stack_sp = svp;
3277 }
3a76ca88 3278 }
a57c6685 3279 LEAVE;
f1025168
NC
3280 return NORMAL;
3281 }
a0d0e21e
LW
3282}
3283
44a8e56a 3284void
864dbfa3 3285Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 3286{
7918f24d
NC
3287 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3288
44a8e56a 3289 if (CvANON(cv))
9014280d 3290 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 3291 else {
35c1215d 3292 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
ecf05a58 3293 SVfARG(cv_name(cv,NULL,0)));
44a8e56a
PP
3294 }
3295}
3296
a0d0e21e
LW
3297PP(pp_aelem)
3298{
20b7effb 3299 dSP;
a0d0e21e 3300 SV** svp;
a3b680e6 3301 SV* const elemsv = POPs;
d804643f 3302 IV elem = SvIV(elemsv);
502c6561 3303 AV *const av = MUTABLE_AV(POPs);
e1ec3a88 3304 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
bbfdc870 3305 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4ad10a0b
VP
3306 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3307 bool preeminent = TRUE;
be6c24e0 3308 SV *sv;
a0d0e21e 3309
5d9574c1 3310 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
95b63a38
JH
3311 Perl_warner(aTHX_ packWARN(WARN_MISC),
3312 "Use of reference \"%"SVf"\" as array index",
be2597df 3313 SVfARG(elemsv));
5d9574c1 3314 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
a0d0e21e 3315 RETPUSHUNDEF;
4ad10a0b 3316
5d9574c1 3317 if (UNLIKELY(localizing)) {
4ad10a0b
VP
3318 MAGIC *mg;
3319 HV *stash;
3320
3321 /* If we can determine whether the element exist,
3322 * Try to preserve the existenceness of a tied array
3323 * element by using EXISTS and DELETE if possible.
3324 * Fallback to FETCH and STORE otherwise. */
3325 if (SvCANEXISTDELETE(av))
3326 preeminent = av_exists(av, elem);
3327 }
3328
68dc0745 3329 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 3330 if (lval) {
2b573ace 3331#ifdef PERL_MALLOC_WRAP
2b573ace 3332 if (SvUOK(elemsv)) {
a9c4fd4e 3333 const UV uv = SvUV(elemsv);
2b573ace
JH
3334 elem = uv > IV_MAX ? IV_MAX : uv;
3335 }
3336 else if (SvNOK(elemsv))
3337 elem = (IV)SvNV(elemsv);
a3b680e6
AL
3338 if (elem > 0) {
3339 static const char oom_array_extend[] =
3340 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 3341 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 3342 }
2b573ace 3343#endif
ce0d59fd 3344 if (!svp || !*svp) {
bbfdc870 3345 IV len;
68dc0745 3346 if (!defer)
cea2e8a9 3347 DIE(aTHX_ PL_no_aelem, elem);
b9f2b683 3348 len = av_tindex(av);
199f858d 3349 mPUSHs(newSVavdefelem(av,
bbfdc870
FC
3350 /* Resolve a negative index now, unless it points before the
3351 beginning of the array, in which case record it for error
3352 reporting in magic_setdefelem. */
199f858d
FC
3353 elem < 0 && len + elem >= 0 ? len + elem : elem,
3354 1));
68dc0745
PP
3355 RETURN;
3356 }
5d9574c1 3357 if (UNLIKELY(localizing)) {
4ad10a0b
VP
3358 if (preeminent)
3359 save_aelem(av, elem, svp);
3360 else
3361 SAVEADELETE(av, elem);
3362 }
9026059d
GG
3363 else if (PL_op->op_private & OPpDEREF) {
3364 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3365 RETURN;
3366 }
a0d0e21e 3367 }
3280af22 3368 sv = (svp ? *svp : &PL_sv_undef);
39cf747a 3369 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 3370 mg_get(sv);
be6c24e0 3371 PUSHs(sv);
a0d0e21e
LW
3372 RETURN;
3373}
3374
9026059d 3375SV*
864dbfa3 3376Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 3377{
7918f24d
NC
3378 PERL_ARGS_ASSERT_VIVIFY_REF;
3379
5b295bef 3380 SvGETMAGIC(sv);
02a9e968
CS
3381 if (!SvOK(sv)) {
3382 if (SvREADONLY(sv))
cb077ed2 3383 Perl_croak_no_modify();
43230e26 3384 prepare_SV_for_RV(sv);
68dc0745 3385 switch (to_what) {
5f05dabc 3386 case OPpDEREF_SV:
561b68a9 3387 SvRV_set(sv, newSV(0));
5f05dabc
PP
3388 break;
3389 case OPpDEREF_AV:
ad64d0ec 3390 SvRV_set(sv, MUTABLE_SV(newAV()));
5f05dabc
PP
3391 break;
3392 case OPpDEREF_HV:
ad64d0ec 3393 SvRV_set(sv, MUTABLE_SV(newHV()));
5f05dabc
PP
3394 break;
3395 }
02a9e968
CS
3396 SvROK_on(sv);
3397 SvSETMAGIC(sv);
7e482323 3398 SvGETMAGIC(sv);
02a9e968 3399 }
9026059d
GG
3400 if (SvGMAGICAL(sv)) {
3401 /* copy the sv without magic to prevent magic from being
3402 executed twice */
3403 SV* msv = sv_newmortal();
3404 sv_setsv_nomg(msv, sv);
3405 return msv;
3406 }
3407 return sv;
02a9e968
CS
3408}
3409
7d6c333c 3410PERL_STATIC_INLINE HV *
3411S_opmethod_stash(pTHX_ SV* meth)
f5d5a27c 3412{
a0d0e21e 3413 SV* ob;
56304f61 3414 HV* stash;
b55b14d0 3415
d648ffcb 3416 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
f226e9be
FC
3417 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3418 "package or object reference", SVfARG(meth)),
3419 (SV *)NULL)
3420 : *(PL_stack_base + TOPMARK + 1);
f5d5a27c 3421
7d6c333c 3422 PERL_ARGS_ASSERT_OPMETHOD_STASH;
d648ffcb 3423
5d9574c1 3424 if (UNLIKELY(!sv))
7156e69a 3425 undefined:
a214957f
VP
3426 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3427 SVfARG(meth));
4f1b7578 3428
d648ffcb 3429 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
3430 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
3431 stash = gv_stashsv(sv, GV_CACHE_ONLY);
7d6c333c 3432 if (stash) return stash;
d648ffcb 3433 }
3434
a0d0e21e 3435 if (SvROK(sv))
ad64d0ec 3436 ob = MUTABLE_SV(SvRV(sv));
7156e69a 3437 else if (!SvOK(sv)) goto undefined;
a77c16f7
FC
3438 else if (isGV_with_GP(sv)) {
3439 if (!GvIO(sv))
3440 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3441 "without a package or object reference",
3442 SVfARG(meth));
3443 ob = sv;
3444 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3445 assert(!LvTARGLEN(ob));
3446 ob = LvTARG(ob);
3447 assert(ob);
3448 }
3449 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3450 }
a0d0e21e 3451 else {
89269094 3452 /* this isn't a reference */
a0d0e21e 3453 GV* iogv;
f937af42 3454 STRLEN packlen;
89269094 3455 const char * const packname = SvPV_nomg_const(sv, packlen);
d283e876 3456 const U32 packname_utf8 = SvUTF8(sv);
3457 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
7d6c333c 3458 if (stash) return stash;
081fc587 3459
89269094 3460 if (!(iogv = gv_fetchpvn_flags(
d283e876 3461 packname, packlen, packname_utf8, SVt_PVIO
da6b625f 3462 )) ||
ad64d0ec 3463 !(ob=MUTABLE_SV(GvIO(iogv))))
a0d0e21e 3464 {
af09ea45 3465 /* this isn't the name of a filehandle either */
89269094 3466 if (!packlen)
834a4ddd 3467 {
7156e69a
FC
3468 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3469 "without a package or object reference",
3470 SVfARG(meth));
834a4ddd 3471 }
af09ea45 3472 /* assume it's a package name */