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