This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
don't create a copy of keys if it's not LVALUE context
[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;
88e2091b 995 U32 lval = 0;
5637b936 996
3280af22 997 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
ca65944e 998 gimme = GIMME_V;
88e2091b
RZ
999 if (gimme == G_ARRAY)
1000 lval = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e
LW
1001
1002 /* If there's a common identifier on both sides we have to take
1003 * special care that assigning the identifier on the left doesn't
1004 * clobber a value on the right that's used later in the list.
acdea6f0 1005 * Don't bother if LHS is just an empty hash or array.
a0d0e21e 1006 */
acdea6f0
DM
1007
1008 if ( (PL_op->op_private & OPpASSIGN_COMMON)
1009 && (
1010 firstlelem != lastlelem
1011 || ! ((sv = *firstlelem))
1012 || SvMAGICAL(sv)
1013 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1014 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1b95d04f 1015 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
acdea6f0
DM
1016 )
1017 ) {
cc5e57d2 1018 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd 1019 for (relem = firstrelem; relem <= lastrelem; relem++) {
155aba94 1020 if ((sv = *relem)) {
a1f49e72 1021 TAINT_NOT; /* Each item is independent */
61e5f455
NC
1022
1023 /* Dear TODO test in t/op/sort.t, I love you.
1024 (It's relying on a panic, not a "semi-panic" from newSVsv()
1025 and then an assertion failure below.) */
1026 if (SvIS_FREED(sv)) {
1027 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1028 (void*)sv);
1029 }
2203fb5a
FC
1030 /* Not newSVsv(), as it does not allow copy-on-write,
1031 resulting in wasteful copies. We need a second copy of
1032 a temp here, hence the SV_NOSTEAL. */
1033 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1034 |SV_NOSTEAL);
a1f49e72 1035 }
10c8fecd 1036 }
a0d0e21e
LW
1037 }
1038
1039 relem = firstrelem;
1040 lelem = firstlelem;
4608196e
RGS
1041 ary = NULL;
1042 hash = NULL;
10c8fecd 1043
a0d0e21e 1044 while (lelem <= lastlelem) {
bbce6d69 1045 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e
LW
1046 sv = *lelem++;
1047 switch (SvTYPE(sv)) {
1048 case SVt_PVAV:
60edcf09 1049 ary = MUTABLE_AV(sv);
748a9306 1050 magic = SvMAGICAL(ary) != 0;
60edcf09
FC
1051 ENTER;
1052 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1053 av_clear(ary);
7e42bd57 1054 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
1055 i = 0;
1056 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 1057 SV **didstore;
a0d0e21e 1058 assert(*relem);
18024492
FC
1059 SvGETMAGIC(*relem); /* before newSV, in case it dies */
1060 sv = newSV(0);
1061 sv_setsv_nomg(sv, *relem);
a0d0e21e 1062 *(relem++) = sv;
5117ca91
GS
1063 didstore = av_store(ary,i++,sv);
1064 if (magic) {
18024492
FC
1065 if (!didstore)
1066 sv_2mortal(sv);
8ef24240 1067 if (SvSMAGICAL(sv))
fb73857a 1068 mg_set(sv);
5117ca91 1069 }
bbce6d69 1070 TAINT_NOT;
a0d0e21e 1071 }
354b0578 1072 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 1073 SvSETMAGIC(MUTABLE_SV(ary));
60edcf09 1074 LEAVE;
a0d0e21e 1075 break;
10c8fecd 1076 case SVt_PVHV: { /* normal hash */
a0d0e21e 1077 SV *tmpstr;
1c4ea384
RZ
1078 int odd;
1079 int duplicates = 0;
45960564 1080 SV** topelem = relem;
1c4ea384 1081 SV **firsthashrelem = relem;
a0d0e21e 1082
60edcf09 1083 hash = MUTABLE_HV(sv);
748a9306 1084 magic = SvMAGICAL(hash) != 0;
1c4ea384
RZ
1085
1086 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1087 if ( odd ) {
1088 do_oddball(hash, lastrelem, firsthashrelem);
1089 /* we have lelem to reuse, it's not needed anymore */
1090 *(lastrelem+1) = &PL_sv_undef;
1091 }
1092
60edcf09
FC
1093 ENTER;
1094 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1095 hv_clear(hash);
1c4ea384 1096 while (relem < lastrelem+odd) { /* gobble up all the rest */
5117ca91 1097 HE *didstore;
1c4ea384 1098 assert(*relem);
88e2091b 1099 sv = lval ? sv_mortalcopy(*relem) : *relem;
45960564 1100 relem++;
1c4ea384
RZ
1101 assert(*relem);
1102 tmpstr = sv_mortalcopy( *relem++ ); /* value */
a88bf2bc 1103 if (gimme == G_ARRAY) {
45960564
DM
1104 if (hv_exists_ent(hash, sv, 0))
1105 /* key overwrites an existing entry */
1106 duplicates += 2;
a88bf2bc 1107 else {
45960564
DM
1108 /* copy element back: possibly to an earlier
1109 * stack location if we encountered dups earlier */
1110 *topelem++ = sv;
1111 *topelem++ = tmpstr;
1112 }
1113 }
5117ca91 1114 didstore = hv_store_ent(hash,sv,tmpstr,0);
9c744f4f 1115 if (didstore) SvREFCNT_inc_simple_void_NN(tmpstr);
1c4ea384 1116 if (magic) SvSETMAGIC(tmpstr);
bbce6d69 1117 TAINT_NOT;
8e07c86e 1118 }
60edcf09 1119 LEAVE;
1c4ea384
RZ
1120 if (duplicates && gimme == G_ARRAY) {
1121 /* at this point we have removed the duplicate key/value
1122 * pairs from the stack, but the remaining values may be
1123 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1124 * the (a 2), but the stack now probably contains
1125 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1126 * obliterates the earlier key. So refresh all values. */
1127 lastrelem -= duplicates;
1128 relem = firsthashrelem;
1129 while (relem < lastrelem+odd) {
1130 HE *he;
1131 he = hv_fetch_ent(hash, *relem++, 0, 0);
1132 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1133 }
1134 }
1135 if (odd && gimme == G_ARRAY) lastrelem++;
a0d0e21e
LW
1136 }
1137 break;
1138 default:
6fc92669
GS
1139 if (SvIMMORTAL(sv)) {
1140 if (relem <= lastrelem)
1141 relem++;
1142 break;
a0d0e21e
LW
1143 }
1144 if (relem <= lastrelem) {
1c70fb82
FC
1145 if (
1146 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1147 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1148 )
1149 Perl_warner(aTHX_
1150 packWARN(WARN_MISC),
1151 "Useless assignment to a temporary"
1152 );
a0d0e21e
LW
1153 sv_setsv(sv, *relem);
1154 *(relem++) = sv;
1155 }
1156 else
3280af22 1157 sv_setsv(sv, &PL_sv_undef);
8ef24240 1158 SvSETMAGIC(sv);
a0d0e21e
LW
1159 break;
1160 }
1161 }
3280af22 1162 if (PL_delaymagic & ~DM_DELAY) {
985213f2
AB
1163 /* Will be used to set PL_tainting below */
1164 UV tmp_uid = PerlProc_getuid();
1165 UV tmp_euid = PerlProc_geteuid();
1166 UV tmp_gid = PerlProc_getgid();
1167 UV tmp_egid = PerlProc_getegid();
1168
3280af22 1169 if (PL_delaymagic & DM_UID) {
a0d0e21e 1170#ifdef HAS_SETRESUID
985213f2
AB
1171 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1172 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
fb934a90 1173 (Uid_t)-1);
56febc5e
AD
1174#else
1175# ifdef HAS_SETREUID
985213f2
AB
1176 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1177 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
56febc5e
AD
1178# else
1179# ifdef HAS_SETRUID
b28d0864 1180 if ((PL_delaymagic & DM_UID) == DM_RUID) {
985213f2 1181 (void)setruid(PL_delaymagic_uid);
b28d0864 1182 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1183 }
56febc5e
AD
1184# endif /* HAS_SETRUID */
1185# ifdef HAS_SETEUID
b28d0864 1186 if ((PL_delaymagic & DM_UID) == DM_EUID) {
985213f2 1187 (void)seteuid(PL_delaymagic_euid);
b28d0864 1188 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1189 }
56febc5e 1190# endif /* HAS_SETEUID */
b28d0864 1191 if (PL_delaymagic & DM_UID) {
985213f2 1192 if (PL_delaymagic_uid != PL_delaymagic_euid)
cea2e8a9 1193 DIE(aTHX_ "No setreuid available");
985213f2 1194 (void)PerlProc_setuid(PL_delaymagic_uid);
a0d0e21e 1195 }
56febc5e
AD
1196# endif /* HAS_SETREUID */
1197#endif /* HAS_SETRESUID */
985213f2
AB
1198 tmp_uid = PerlProc_getuid();
1199 tmp_euid = PerlProc_geteuid();
a0d0e21e 1200 }
3280af22 1201 if (PL_delaymagic & DM_GID) {
a0d0e21e 1202#ifdef HAS_SETRESGID
985213f2
AB
1203 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1204 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
fb934a90 1205 (Gid_t)-1);
56febc5e
AD
1206#else
1207# ifdef HAS_SETREGID
985213f2
AB
1208 (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1209 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
56febc5e
AD
1210# else
1211# ifdef HAS_SETRGID
b28d0864 1212 if ((PL_delaymagic & DM_GID) == DM_RGID) {
985213f2 1213 (void)setrgid(PL_delaymagic_gid);
b28d0864 1214 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1215 }
56febc5e
AD
1216# endif /* HAS_SETRGID */
1217# ifdef HAS_SETEGID
b28d0864 1218 if ((PL_delaymagic & DM_GID) == DM_EGID) {
985213f2 1219 (void)setegid(PL_delaymagic_egid);
b28d0864 1220 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1221 }
56febc5e 1222# endif /* HAS_SETEGID */
b28d0864 1223 if (PL_delaymagic & DM_GID) {
985213f2 1224 if (PL_delaymagic_gid != PL_delaymagic_egid)
cea2e8a9 1225 DIE(aTHX_ "No setregid available");
985213f2 1226 (void)PerlProc_setgid(PL_delaymagic_gid);
a0d0e21e 1227 }
56febc5e
AD
1228# endif /* HAS_SETREGID */
1229#endif /* HAS_SETRESGID */
985213f2
AB
1230 tmp_gid = PerlProc_getgid();
1231 tmp_egid = PerlProc_getegid();
a0d0e21e 1232 }
284167a5 1233 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
a0d0e21e 1234 }
3280af22 1235 PL_delaymagic = 0;
54310121 1236
54310121
PP
1237 if (gimme == G_VOID)
1238 SP = firstrelem - 1;
1239 else if (gimme == G_SCALAR) {
1240 dTARGET;
1241 SP = firstrelem;
231cbeb2 1242 SETi(lastrelem - firstrelem + 1);
54310121
PP
1243 }
1244 else {
1c4ea384 1245 if (ary || hash)
a0d0e21e 1246 SP = lastrelem;
1c4ea384 1247 else {
a0d0e21e 1248 SP = firstrelem + (lastlelem - firstlelem);
1c4ea384
RZ
1249 lelem = firstlelem + (relem - firstrelem);
1250 while (relem <= SP)
1251 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1252 }
a0d0e21e 1253 }
08aeb9f7 1254
54310121 1255 RETURN;
a0d0e21e
LW
1256}
1257
8782bef2
GB
1258PP(pp_qr)
1259{
97aff369 1260 dVAR; dSP;
eb578fdb 1261 PMOP * const pm = cPMOP;
fe578d7f 1262 REGEXP * rx = PM_GETRE(pm);
10599a69 1263 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
c4420975 1264 SV * const rv = sv_newmortal();
d63c20f2
DM
1265 CV **cvp;
1266 CV *cv;
288b8c02
NC
1267
1268 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
1269 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1270 loathe to use it here, but it seems to be the right fix. Or close.
1271 The key part appears to be that it's essential for pp_qr to return a new
1272 object (SV), which implies that there needs to be an effective way to
1273 generate a new SV from the existing SV that is pre-compiled in the
1274 optree. */
1275 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
1276 SvROK_on(rv);
1277
8d919b0a 1278 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
d63c20f2
DM
1279 if ((cv = *cvp) && CvCLONE(*cvp)) {
1280 *cvp = cv_clone(cv);
fc2b2dca 1281 SvREFCNT_dec_NN(cv);
d63c20f2
DM
1282 }
1283
288b8c02 1284 if (pkg) {
f815daf2 1285 HV *const stash = gv_stashsv(pkg, GV_ADD);
fc2b2dca 1286 SvREFCNT_dec_NN(pkg);
288b8c02
NC
1287 (void)sv_bless(rv, stash);
1288 }
1289
284167a5 1290 if (RX_ISTAINTED(rx)) {
e08e52cf 1291 SvTAINTED_on(rv);
9274aefd
DM
1292 SvTAINTED_on(SvRV(rv));
1293 }
c8c13c22 1294 XPUSHs(rv);
1295 RETURN;
8782bef2
GB
1296}
1297
a0d0e21e
LW
1298PP(pp_match)
1299{
97aff369 1300 dVAR; dSP; dTARG;
eb578fdb 1301 PMOP *pm = cPMOP;
d65afb4b 1302 PMOP *dynpm = pm;
eb578fdb
KW
1303 const char *t;
1304 const char *s;
5c144d81 1305 const char *strend;
a0d0e21e 1306 I32 global;
1ed74d04 1307 U8 r_flags = REXEC_CHECKED;
5c144d81 1308 const char *truebase; /* Start of string */
eb578fdb 1309 REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1310 bool rxtainted;
a3b680e6 1311 const I32 gimme = GIMME;
a0d0e21e 1312 STRLEN len;
748a9306 1313 I32 minmatch = 0;
a3b680e6 1314 const I32 oldsave = PL_savestack_ix;
f86702cc 1315 I32 update_minmatch = 1;
e60df1fa 1316 I32 had_zerolen = 0;
58e23c8d 1317 U32 gpos = 0;
a0d0e21e 1318
533c011a 1319 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1320 TARG = POPs;
59f00321
RGS
1321 else if (PL_op->op_private & OPpTARGET_MY)
1322 GETTARGET;
a0d0e21e 1323 else {
54b9620d 1324 TARG = DEFSV;
a0d0e21e
LW
1325 EXTEND(SP,1);
1326 }
d9f424b2 1327
c277df42 1328 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
1329 /* Skip get-magic if this is a qr// clone, because regcomp has
1330 already done it. */
8d919b0a 1331 s = ReANY(rx)->mother_re
69dc4b30
FC
1332 ? SvPV_nomg_const(TARG, len)
1333 : SvPV_const(TARG, len);
a0d0e21e 1334 if (!s)
2269b42e 1335 DIE(aTHX_ "panic: pp_match");
890ce7af 1336 strend = s + len;
284167a5
SM
1337 rxtainted = (RX_ISTAINTED(rx) ||
1338 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1339 TAINT_NOT;
a0d0e21e 1340
a30b2f1f 1341 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 1342
6c864ec2 1343 /* We need to know this in case we fail out early - pos() must be reset */
de0df3c0
MH
1344 global = dynpm->op_pmflags & PMf_GLOBAL;
1345
d65afb4b 1346 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
1347 if (
1348#ifdef USE_ITHREADS
1349 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1350#else
1351 pm->op_pmflags & PMf_USED
1352#endif
1353 ) {
e5dc5375 1354 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
de0df3c0 1355 goto nope;
a0d0e21e
LW
1356 }
1357
7e313637
FC
1358 /* empty pattern special-cased to use last successful pattern if
1359 possible, except for qr// */
8d919b0a 1360 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
7e313637 1361 && PL_curpm) {
3280af22 1362 pm = PL_curpm;
aaa362c4 1363 rx = PM_GETRE(pm);
a0d0e21e 1364 }
d65afb4b 1365
e5dc5375
KW
1366 if (RX_MINLEN(rx) > (I32)len) {
1367 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
de0df3c0 1368 goto nope;
e5dc5375 1369 }
c277df42 1370
a0d0e21e 1371 truebase = t = s;
ad94a511
IZ
1372
1373 /* XXXX What part of this is needed with true \G-support? */
de0df3c0 1374 if (global) {
07bc277f 1375 RX_OFFS(rx)[0].start = -1;
a0d0e21e 1376 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
c445ea15 1377 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
565764a8 1378 if (mg && mg->mg_len >= 0) {
07bc277f
NC
1379 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1380 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1381 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
0ef3e39e 1382 r_flags |= REXEC_IGNOREPOS;
07bc277f
NC
1383 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1384 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
58e23c8d
YO
1385 gpos = mg->mg_len;
1386 else
07bc277f
NC
1387 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1388 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
f86702cc 1389 update_minmatch = 0;
748a9306 1390 }
a0d0e21e
LW
1391 }
1392 }
6e240d0b 1393#ifdef PERL_SAWAMPERSAND
a41aa44d 1394 if ( RX_NPARENS(rx)
6502e081 1395 || PL_sawampersand
6502e081 1396 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
6e240d0b
FC
1397 )
1398#endif
1399 {
6502e081
DM
1400 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1401 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1402 * only on the first iteration. Therefore we need to copy $' as well
1403 * as $&, to make the rest of the string available for captures in
1404 * subsequent iterations */
1405 if (! (global && gimme == G_ARRAY))
1406 r_flags |= REXEC_COPY_SKIP_POST;
1407 };
22e551b9 1408
d7be1480 1409 play_it_again:
07bc277f
NC
1410 if (global && RX_OFFS(rx)[0].start != -1) {
1411 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
e5dc5375
KW
1412 if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
1413 DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
a0d0e21e 1414 goto nope;
e5dc5375 1415 }
f86702cc 1416 if (update_minmatch++)
e60df1fa 1417 minmatch = had_zerolen;
a0d0e21e 1418 }
07bc277f 1419 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
3c8556c3 1420 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
5c144d81
NC
1421 /* FIXME - can PL_bostr be made const char *? */
1422 PL_bostr = (char *)truebase;
f9f4320a 1423 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
f722798b
IZ
1424
1425 if (!s)
1426 goto nope;
6e240d0b 1427#ifdef PERL_SAWAMPERSAND
07bc277f 1428 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
14977893 1429 && !PL_sawampersand
07bc277f 1430 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
05b4157f 1431 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
f722798b 1432 goto yup;
6e240d0b 1433#endif
a0d0e21e 1434 }
77da2310
NC
1435 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1436 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1437 goto ret_no;
1438
1439 PL_curpm = pm;
1440 if (dynpm->op_pmflags & PMf_ONCE) {
c737faaf 1441#ifdef USE_ITHREADS
77da2310 1442 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 1443#else
77da2310 1444 dynpm->op_pmflags |= PMf_USED;
c737faaf 1445#endif
a0d0e21e 1446 }
a0d0e21e
LW
1447
1448 gotcha:
72311751
GS
1449 if (rxtainted)
1450 RX_MATCH_TAINTED_on(rx);
1451 TAINT_IF(RX_MATCH_TAINTED(rx));
a0d0e21e 1452 if (gimme == G_ARRAY) {
07bc277f 1453 const I32 nparens = RX_NPARENS(rx);
a3b680e6 1454 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 1455
c277df42 1456 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1457 EXTEND(SP, nparens + i);
1458 EXTEND_MORTAL(nparens + i);
1459 for (i = !i; i <= nparens; i++) {
a0d0e21e 1460 PUSHs(sv_newmortal());
07bc277f
NC
1461 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1462 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1463 s = RX_OFFS(rx)[i].start + truebase;
1464 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
290deeac 1465 len < 0 || len > strend - s)
5637ef5b
NC
1466 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1467 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1468 (long) i, (long) RX_OFFS(rx)[i].start,
1469 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
a0d0e21e 1470 sv_setpvn(*SP, s, len);
cce850e4 1471 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1472 SvUTF8_on(*SP);
a0d0e21e
LW
1473 }
1474 }
1475 if (global) {
d65afb4b 1476 if (dynpm->op_pmflags & PMf_CONTINUE) {
6136c704 1477 MAGIC* mg = NULL;
0af80b60
HS
1478 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1479 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1480 if (!mg) {
d83f0a82
NC
1481#ifdef PERL_OLD_COPY_ON_WRITE
1482 if (SvIsCOW(TARG))
1483 sv_force_normal_flags(TARG, 0);
1484#endif
1485 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1486 &PL_vtbl_mglob, NULL, 0);
0af80b60 1487 }
07bc277f
NC
1488 if (RX_OFFS(rx)[0].start != -1) {
1489 mg->mg_len = RX_OFFS(rx)[0].end;
1490 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
0af80b60
HS
1491 mg->mg_flags |= MGf_MINMATCH;
1492 else
1493 mg->mg_flags &= ~MGf_MINMATCH;
1494 }
1495 }
07bc277f
NC
1496 had_zerolen = (RX_OFFS(rx)[0].start != -1
1497 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1498 == (UV)RX_OFFS(rx)[0].end));
c277df42 1499 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1500 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1501 goto play_it_again;
1502 }
ffc61ed2 1503 else if (!nparens)
bde848c5 1504 XPUSHs(&PL_sv_yes);
4633a7c4 1505 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1506 RETURN;
1507 }
1508 else {
1509 if (global) {
cbbf8932 1510 MAGIC* mg;
a0d0e21e 1511 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
14befaf4 1512 mg = mg_find(TARG, PERL_MAGIC_regex_global);
cbbf8932
AL
1513 else
1514 mg = NULL;
a0d0e21e 1515 if (!mg) {
d83f0a82
NC
1516#ifdef PERL_OLD_COPY_ON_WRITE
1517 if (SvIsCOW(TARG))
1518 sv_force_normal_flags(TARG, 0);
1519#endif
1520 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1521 &PL_vtbl_mglob, NULL, 0);
a0d0e21e 1522 }
07bc277f
NC
1523 if (RX_OFFS(rx)[0].start != -1) {
1524 mg->mg_len = RX_OFFS(rx)[0].end;
1525 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
748a9306
LW
1526 mg->mg_flags |= MGf_MINMATCH;
1527 else
1528 mg->mg_flags &= ~MGf_MINMATCH;
1529 }
a0d0e21e 1530 }
4633a7c4 1531 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1532 RETPUSHYES;
1533 }
1534
6e240d0b 1535#ifdef PERL_SAWAMPERSAND
f722798b 1536yup: /* Confirmed by INTUIT */
6e240d0b 1537#endif
72311751
GS
1538 if (rxtainted)
1539 RX_MATCH_TAINTED_on(rx);
1540 TAINT_IF(RX_MATCH_TAINTED(rx));
3280af22 1541 PL_curpm = pm;
c737faaf
YO
1542 if (dynpm->op_pmflags & PMf_ONCE) {
1543#ifdef USE_ITHREADS
1544 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1545#else
1546 dynpm->op_pmflags |= PMf_USED;
1547#endif
1548 }
cf93c79d 1549 if (RX_MATCH_COPIED(rx))
07bc277f 1550 Safefree(RX_SUBBEG(rx));
cf93c79d 1551 RX_MATCH_COPIED_off(rx);
07bc277f 1552 RX_SUBBEG(rx) = NULL;
a0d0e21e 1553 if (global) {
5c144d81 1554 /* FIXME - should rx->subbeg be const char *? */
07bc277f 1555 RX_SUBBEG(rx) = (char *) truebase;
6502e081
DM
1556 RX_SUBOFFSET(rx) = 0;
1557 RX_SUBCOFFSET(rx) = 0;
07bc277f 1558 RX_OFFS(rx)[0].start = s - truebase;
a30b2f1f 1559 if (RX_MATCH_UTF8(rx)) {
07bc277f
NC
1560 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1561 RX_OFFS(rx)[0].end = t - truebase;
60aeb6fd
NIS
1562 }
1563 else {
07bc277f 1564 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
60aeb6fd 1565 }
07bc277f 1566 RX_SUBLEN(rx) = strend - truebase;
a0d0e21e 1567 goto gotcha;
1c846c1f 1568 }
6e240d0b
FC
1569#ifdef PERL_SAWAMPERSAND
1570 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1571#endif
1572 {
14977893 1573 I32 off;
db2c6cb3
FC
1574#ifdef PERL_ANY_COW
1575 if (SvCANCOW(TARG)) {
ed252734
NC
1576 if (DEBUG_C_TEST) {
1577 PerlIO_printf(Perl_debug_log,
1578 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
6c9570dc 1579 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
ed252734
NC
1580 (int)(t-truebase));
1581 }
bdd9a1b1
NC
1582 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1583 RX_SUBBEG(rx)
1584 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1585 assert (SvPOKp(RX_SAVED_COPY(rx)));
ed252734
NC
1586 } else
1587#endif
1588 {
14977893 1589
07bc277f 1590 RX_SUBBEG(rx) = savepvn(t, strend - t);
db2c6cb3 1591#ifdef PERL_ANY_COW
bdd9a1b1 1592 RX_SAVED_COPY(rx) = NULL;
ed252734
NC
1593#endif
1594 }
07bc277f 1595 RX_SUBLEN(rx) = strend - t;
6502e081
DM
1596 RX_SUBOFFSET(rx) = 0;
1597 RX_SUBCOFFSET(rx) = 0;
14977893 1598 RX_MATCH_COPIED_on(rx);
07bc277f
NC
1599 off = RX_OFFS(rx)[0].start = s - t;
1600 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
14977893 1601 }
6e240d0b 1602#ifdef PERL_SAWAMPERSAND
14977893 1603 else { /* startp/endp are used by @- @+. */
07bc277f
NC
1604 RX_OFFS(rx)[0].start = s - truebase;
1605 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
14977893 1606 }
6e240d0b 1607#endif
7e1a2c8d
DM
1608 /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
1609 assert(!RX_NPARENS(rx));
1610 RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
4633a7c4 1611 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1612 RETPUSHYES;
1613
1614nope:
a0d0e21e 1615ret_no:
d65afb4b 1616 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e 1617 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
6136c704 1618 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1619 if (mg)
565764a8 1620 mg->mg_len = -1;
a0d0e21e
LW
1621 }
1622 }
4633a7c4 1623 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1624 if (gimme == G_ARRAY)
1625 RETURN;
1626 RETPUSHNO;
1627}
1628
1629OP *
864dbfa3 1630Perl_do_readline(pTHX)
a0d0e21e 1631{
27da23d5 1632 dVAR; dSP; dTARGETSTACKED;
eb578fdb 1633 SV *sv;
a0d0e21e
LW
1634 STRLEN tmplen = 0;
1635 STRLEN offset;
760ac839 1636 PerlIO *fp;
eb578fdb
KW
1637 IO * const io = GvIO(PL_last_in_gv);
1638 const I32 type = PL_op->op_type;
a3b680e6 1639 const I32 gimme = GIMME_V;
a0d0e21e 1640
6136c704 1641 if (io) {
50db69d8 1642 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 1643 if (mg) {
50db69d8 1644 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 1645 if (gimme == G_SCALAR) {
50db69d8
NC
1646 SPAGAIN;
1647 SvSetSV_nosteal(TARG, TOPs);
1648 SETTARG;
6136c704 1649 }
50db69d8 1650 return NORMAL;
0b7c7b4f 1651 }
e79b0511 1652 }
4608196e 1653 fp = NULL;
a0d0e21e
LW
1654 if (io) {
1655 fp = IoIFP(io);
1656 if (!fp) {
1657 if (IoFLAGS(io) & IOf_ARGV) {
1658 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1659 IoLINES(io) = 0;
3280af22 1660 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1661 IoFLAGS(io) &= ~IOf_START;
4608196e 1662 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
4bac9ae4 1663 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
76f68e9b 1664 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3280af22 1665 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1666 fp = IoIFP(io);
1667 goto have_fp;
a0d0e21e
LW
1668 }
1669 }
3280af22 1670 fp = nextargv(PL_last_in_gv);
a0d0e21e 1671 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1672 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1673 }
1674 }
0d44d22b
NC
1675 else if (type == OP_GLOB)
1676 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1677 }
1678 else if (type == OP_GLOB)
1679 SP--;
7716c5c5 1680 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 1681 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 1682 }
a0d0e21e
LW
1683 }
1684 if (!fp) {
041457d9
DM
1685 if ((!io || !(IoFLAGS(io) & IOf_START))
1686 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1687 {
3f4520fe 1688 if (type == OP_GLOB)
63922903 1689 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
af8c498a
GS
1690 "glob failed (can't start child: %s)",
1691 Strerror(errno));
69282e91 1692 else
831e4cc3 1693 report_evil_fh(PL_last_in_gv);
3f4520fe 1694 }
54310121 1695 if (gimme == G_SCALAR) {
79628082 1696 /* undef TARG, and push that undefined value */
ba92458f
AE
1697 if (type != OP_RCATLINE) {
1698 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1699 SvOK_off(TARG);
ba92458f 1700 }
a0d0e21e
LW
1701 PUSHTARG;
1702 }
1703 RETURN;
1704 }
a2008d6d 1705 have_fp:
54310121 1706 if (gimme == G_SCALAR) {
a0d0e21e 1707 sv = TARG;
0f722b55
RGS
1708 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1709 mg_get(sv);
48de12d9
RGS
1710 if (SvROK(sv)) {
1711 if (type == OP_RCATLINE)
5668452f 1712 SvPV_force_nomg_nolen(sv);
48de12d9
RGS
1713 else
1714 sv_unref(sv);
1715 }
f7877b28 1716 else if (isGV_with_GP(sv)) {
5668452f 1717 SvPV_force_nomg_nolen(sv);
f7877b28 1718 }
862a34c6 1719 SvUPGRADE(sv, SVt_PV);
a0d0e21e 1720 tmplen = SvLEN(sv); /* remember if already alloced */
e3918bb7 1721 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
f72e8700
JJ
1722 /* try short-buffering it. Please update t/op/readline.t
1723 * if you change the growth length.
1724 */
1725 Sv_Grow(sv, 80);
1726 }
2b5e58c4
AMS
1727 offset = 0;
1728 if (type == OP_RCATLINE && SvOK(sv)) {
1729 if (!SvPOK(sv)) {
5668452f 1730 SvPV_force_nomg_nolen(sv);
2b5e58c4 1731 }
a0d0e21e 1732 offset = SvCUR(sv);
2b5e58c4 1733 }
a0d0e21e 1734 }
54310121 1735 else {
561b68a9 1736 sv = sv_2mortal(newSV(80));
54310121
PP
1737 offset = 0;
1738 }
fbad3eb5 1739
3887d568
AP
1740 /* This should not be marked tainted if the fp is marked clean */
1741#define MAYBE_TAINT_LINE(io, sv) \
1742 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1743 TAINT; \
1744 SvTAINTED_on(sv); \
1745 }
1746
684bef36 1747/* delay EOF state for a snarfed empty file */
fbad3eb5 1748#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1749 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1750 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1751
a0d0e21e 1752 for (;;) {
09e8efcc 1753 PUTBACK;
fbad3eb5 1754 if (!sv_gets(sv, fp, offset)
2d726892
TF
1755 && (type == OP_GLOB
1756 || SNARF_EOF(gimme, PL_rs, io, sv)
1757 || PerlIO_error(fp)))
fbad3eb5 1758 {
760ac839 1759 PerlIO_clearerr(fp);
a0d0e21e 1760 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1761 fp = nextargv(PL_last_in_gv);
a0d0e21e
LW
1762 if (fp)
1763 continue;
3280af22 1764 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1765 }
1766 else if (type == OP_GLOB) {
a2a5de95
NC
1767 if (!do_close(PL_last_in_gv, FALSE)) {
1768 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1769 "glob failed (child exited with status %d%s)",
1770 (int)(STATUS_CURRENT >> 8),
1771 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1772 }
a0d0e21e 1773 }
54310121 1774 if (gimme == G_SCALAR) {
ba92458f
AE
1775 if (type != OP_RCATLINE) {
1776 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1777 SvOK_off(TARG);
ba92458f 1778 }
09e8efcc 1779 SPAGAIN;
a0d0e21e
LW
1780 PUSHTARG;
1781 }
3887d568 1782 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1783 RETURN;
1784 }
3887d568 1785 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1786 IoLINES(io)++;
b9fee9ba 1787 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1788 SvSETMAGIC(sv);
09e8efcc 1789 SPAGAIN;
a0d0e21e 1790 XPUSHs(sv);
a0d0e21e 1791 if (type == OP_GLOB) {
349d4f2f 1792 const char *t1;
a0d0e21e 1793
3280af22 1794 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 1795 char * const tmps = SvEND(sv) - 1;
aa07b2f6 1796 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 1797 *tmps = '\0';
b162af07 1798 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
1799 }
1800 }
349d4f2f 1801 for (t1 = SvPVX_const(sv); *t1; t1++)
937b2e03 1802 if (!isALNUMC(*t1) &&
349d4f2f 1803 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
a0d0e21e 1804 break;
349d4f2f 1805 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1806 (void)POPs; /* Unmatched wildcard? Chuck it... */
1807 continue;
1808 }
2d79bf7f 1809 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
1810 if (ckWARN(WARN_UTF8)) {
1811 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1812 const STRLEN len = SvCUR(sv) - offset;
1813 const U8 *f;
1814
1815 if (!is_utf8_string_loc(s, len, &f))
1816 /* Emulate :encoding(utf8) warning in the same case. */
1817 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1818 "utf8 \"\\x%02X\" does not map to Unicode",
1819 f < (U8*)SvEND(sv) ? *f : 0);
1820 }
a0d0e21e 1821 }
54310121 1822 if (gimme == G_ARRAY) {
a0d0e21e 1823 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 1824 SvPV_shrink_to_cur(sv);
a0d0e21e 1825 }
561b68a9 1826 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
1827 continue;
1828 }
54310121 1829 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 1830 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
1831 const STRLEN new_len
1832 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 1833 SvPV_renew(sv, new_len);
a0d0e21e
LW
1834 }
1835 RETURN;
1836 }
1837}
1838
a0d0e21e
LW
1839PP(pp_helem)
1840{
97aff369 1841 dVAR; dSP;
760ac839 1842 HE* he;
ae77835f 1843 SV **svp;
c445ea15 1844 SV * const keysv = POPs;
85fbaab2 1845 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
1846 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1847 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1848 SV *sv;
92970b93 1849 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 1850 bool preeminent = TRUE;
a0d0e21e 1851
d4c19fe8 1852 if (SvTYPE(hv) != SVt_PVHV)
a0d0e21e 1853 RETPUSHUNDEF;
d4c19fe8 1854
92970b93 1855 if (localizing) {
d4c19fe8
AL
1856 MAGIC *mg;
1857 HV *stash;
d30e492c
VP
1858
1859 /* If we can determine whether the element exist,
1860 * Try to preserve the existenceness of a tied hash
1861 * element by using EXISTS and DELETE if possible.
1862 * Fallback to FETCH and STORE otherwise. */
2c5f48c2 1863 if (SvCANEXISTDELETE(hv))
d30e492c 1864 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 1865 }
d30e492c 1866
5f9d7e2b 1867 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
d4c19fe8 1868 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 1869 if (lval) {
746f6409 1870 if (!svp || !*svp || *svp == &PL_sv_undef) {
68dc0745
PP
1871 SV* lv;
1872 SV* key2;
2d8e6c8d 1873 if (!defer) {
be2597df 1874 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 1875 }
68dc0745
PP
1876 lv = sv_newmortal();
1877 sv_upgrade(lv, SVt_PVLV);
1878 LvTYPE(lv) = 'y';
6136c704 1879 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
fc2b2dca 1880 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
b37c2d43 1881 LvTARG(lv) = SvREFCNT_inc_simple(hv);
68dc0745
PP
1882 LvTARGLEN(lv) = 1;
1883 PUSHs(lv);
1884 RETURN;
1885 }
92970b93 1886 if (localizing) {
bfcb3514 1887 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 1888 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
1889 else if (preeminent)
1890 save_helem_flags(hv, keysv, svp,
1891 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1892 else
1893 SAVEHDELETE(hv, keysv);
5f05dabc 1894 }
9026059d
GG
1895 else if (PL_op->op_private & OPpDEREF) {
1896 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1897 RETURN;
1898 }
a0d0e21e 1899 }
746f6409 1900 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
1901 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1902 * was to make C<local $tied{foo} = $tied{foo}> possible.
1903 * However, it seems no longer to be needed for that purpose, and
1904 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1905 * would loop endlessly since the pos magic is getting set on the
1906 * mortal copy and lost. However, the copy has the effect of
1907 * triggering the get magic, and losing it altogether made things like
1908 * c<$tied{foo};> in void context no longer do get magic, which some
1909 * code relied on. Also, delayed triggering of magic on @+ and friends
1910 * meant the original regex may be out of scope by now. So as a
1911 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1912 * being called too many times). */
39cf747a 1913 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 1914 mg_get(sv);
be6c24e0 1915 PUSHs(sv);
a0d0e21e
LW
1916 RETURN;
1917}
1918
a0d0e21e
LW
1919PP(pp_iter)
1920{
97aff369 1921 dVAR; dSP;
eb578fdb 1922 PERL_CONTEXT *cx;
7d6c2cef 1923 SV *oldsv;
1d7c1841 1924 SV **itersvp;
a0d0e21e 1925
924508f0 1926 EXTEND(SP, 1);
a0d0e21e 1927 cx = &cxstack[cxstack_ix];
1d7c1841 1928 itersvp = CxITERVAR(cx);
a48ce6be
DM
1929
1930 switch (CxTYPE(cx)) {
17c91640 1931
b552b52c
DM
1932 case CXt_LOOP_LAZYSV: /* string increment */
1933 {
1934 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1935 SV *end = cx->blk_loop.state_u.lazysv.end;
1936 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1937 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1938 STRLEN maxlen = 0;
1939 const char *max = SvPV_const(end, maxlen);
1940 if (SvNIOK(cur) || SvCUR(cur) > maxlen)
1941 RETPUSHNO;
1942
1943 oldsv = *itersvp;
1944 if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1945 /* safe to reuse old SV */
1946 sv_setsv(oldsv, cur);
a48ce6be 1947 }
b552b52c
DM
1948 else
1949 {
1950 /* we need a fresh SV every time so that loop body sees a
1951 * completely new SV for closures/references to work as
1952 * they used to */
1953 *itersvp = newSVsv(cur);
fc2b2dca 1954 SvREFCNT_dec_NN(oldsv);
b552b52c
DM
1955 }
1956 if (strEQ(SvPVX_const(cur), max))
1957 sv_setiv(cur, 0); /* terminate next time */
1958 else
1959 sv_inc(cur);
1960 break;
1961 }
a48ce6be 1962
fcef60b4
DM
1963 case CXt_LOOP_LAZYIV: /* integer increment */
1964 {
1965 IV cur = cx->blk_loop.state_u.lazyiv.cur;
1966 if (cur > cx->blk_loop.state_u.lazyiv.end)
89ea2908 1967 RETPUSHNO;
7f61b687 1968
fcef60b4 1969 oldsv = *itersvp;
3db8f154 1970 /* don't risk potential race */
fcef60b4 1971 if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
eaa5c2d6 1972 /* safe to reuse old SV */
fcef60b4 1973 sv_setiv(oldsv, cur);
eaa5c2d6 1974 }
1c846c1f 1975 else
eaa5c2d6
GA
1976 {
1977 /* we need a fresh SV every time so that loop body sees a
1978 * completely new SV for closures/references to work as they
1979 * used to */
fcef60b4 1980 *itersvp = newSViv(cur);
fc2b2dca 1981 SvREFCNT_dec_NN(oldsv);
eaa5c2d6 1982 }
a2309040 1983
fcef60b4 1984 if (cur == IV_MAX) {
cdc1aa42
NC
1985 /* Handle end of range at IV_MAX */
1986 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1987 } else
1988 ++cx->blk_loop.state_u.lazyiv.cur;
a48ce6be 1989 break;
fcef60b4 1990 }
a48ce6be 1991
b552b52c 1992 case CXt_LOOP_FOR: /* iterate array */
7d6c2cef 1993 {
89ea2908 1994
7d6c2cef
DM
1995 AV *av = cx->blk_loop.state_u.ary.ary;
1996 SV *sv;
1997 bool av_is_stack = FALSE;
a8a20bb6 1998 IV ix;
7d6c2cef 1999
de080daa
DM
2000 if (!av) {
2001 av_is_stack = TRUE;
2002 av = PL_curstack;
2003 }
2004 if (PL_op->op_private & OPpITER_REVERSED) {
a8a20bb6
DM
2005 ix = --cx->blk_loop.state_u.ary.ix;
2006 if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
de080daa 2007 RETPUSHNO;
de080daa
DM
2008 }
2009 else {
a8a20bb6
DM
2010 ix = ++cx->blk_loop.state_u.ary.ix;
2011 if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
de080daa 2012 RETPUSHNO;
a8a20bb6 2013 }
de080daa 2014
a8a20bb6
DM
2015 if (SvMAGICAL(av) || AvREIFY(av)) {
2016 SV * const * const svp = av_fetch(av, ix, FALSE);
2017 sv = svp ? *svp : NULL;
2018 }
2019 else {
2020 sv = AvARRAY(av)[ix];
de080daa 2021 }
ef3e5ea9 2022
de080daa 2023 if (sv) {
f38aa882
DM
2024 if (SvIS_FREED(sv)) {
2025 *itersvp = NULL;
2026 Perl_croak(aTHX_ "Use of freed value in iteration");
2027 }
de080daa
DM
2028 SvTEMP_off(sv);
2029 SvREFCNT_inc_simple_void_NN(sv);
2030 }
2031 else
2032 sv = &PL_sv_undef;
f38aa882 2033
de080daa
DM
2034 if (!av_is_stack && sv == &PL_sv_undef) {
2035 SV *lv = newSV_type(SVt_PVLV);
2036 LvTYPE(lv) = 'y';
2037 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2038 LvTARG(lv) = SvREFCNT_inc_simple(av);
f38aa882 2039 LvTARGOFF(lv) = ix;
de080daa
DM
2040 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2041 sv = lv;
2042 }
a0d0e21e 2043
de080daa
DM
2044 oldsv = *itersvp;
2045 *itersvp = sv;
2046 SvREFCNT_dec(oldsv);
de080daa 2047 break;
7d6c2cef 2048 }
a48ce6be
DM
2049
2050 default:
2051 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2052 }
b552b52c 2053 RETPUSHYES;
a0d0e21e
LW
2054}
2055
ef07e810
DM
2056/*
2057A description of how taint works in pattern matching and substitution.
2058
284167a5
SM
2059This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2060NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2061
4e19c54b 2062While the pattern is being assembled/concatenated and then compiled,
284167a5
SM
2063PL_tainted will get set (via TAINT_set) if any component of the pattern
2064is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
2065the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2066TAINT_get).
ef07e810 2067
0ab462a6
DM
2068When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2069the pattern is marked as tainted. This means that subsequent usage, such
284167a5
SM
2070as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2071on the new pattern too.
ef07e810
DM
2072
2073During execution of a pattern, locale-variant ops such as ALNUML set the
2074local flag RF_tainted. At the end of execution, the engine sets the
0ab462a6
DM
2075RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2076otherwise.
ef07e810
DM
2077
2078In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2079of $1 et al to indicate whether the returned value should be tainted.
2080It is the responsibility of the caller of the pattern (i.e. pp_match,
2081pp_subst etc) to set this flag for any other circumstances where $1 needs
2082to be tainted.
2083
2084The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2085
2086There are three possible sources of taint
2087 * the source string
2088 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2089 * the replacement string (or expression under /e)
2090
2091There are four destinations of taint and they are affected by the sources
2092according to the rules below:
2093
2094 * the return value (not including /r):
2095 tainted by the source string and pattern, but only for the
2096 number-of-iterations case; boolean returns aren't tainted;
2097 * the modified string (or modified copy under /r):
2098 tainted by the source string, pattern, and replacement strings;
2099 * $1 et al:
2100 tainted by the pattern, and under 'use re "taint"', by the source
2101 string too;
2102 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2103 should always be unset before executing subsequent code.
2104
2105The overall action of pp_subst is:
2106
2107 * at the start, set bits in rxtainted indicating the taint status of
2108 the various sources.
2109
2110 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2111 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2112 pattern has subsequently become tainted via locale ops.
2113
2114 * If control is being passed to pp_substcont to execute a /e block,
2115 save rxtainted in the CXt_SUBST block, for future use by
2116 pp_substcont.
2117
2118 * Whenever control is being returned to perl code (either by falling
2119 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2120 use the flag bits in rxtainted to make all the appropriate types of
0ab462a6
DM
2121 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2122 et al will appear tainted.
ef07e810
DM
2123
2124pp_match is just a simpler version of the above.
2125
2126*/
2127
a0d0e21e
LW
2128PP(pp_subst)
2129{
97aff369 2130 dVAR; dSP; dTARG;
eb578fdb 2131 PMOP *pm = cPMOP;
a0d0e21e 2132 PMOP *rpm = pm;
eb578fdb 2133 char *s;
a0d0e21e 2134 char *strend;
eb578fdb 2135 char *m;
5c144d81 2136 const char *c;
eb578fdb 2137 char *d;
a0d0e21e
LW
2138 STRLEN clen;
2139 I32 iters = 0;
2140 I32 maxiters;
eb578fdb 2141 I32 i;
a0d0e21e 2142 bool once;
ef07e810
DM
2143 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2144 See "how taint works" above */
a0d0e21e 2145 char *orig;
1ed74d04 2146 U8 r_flags;
eb578fdb 2147 REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
2148 STRLEN len;
2149 int force_on_match = 0;
0bcc34c2 2150 const I32 oldsave = PL_savestack_ix;
792b2c16 2151 STRLEN slen;
26a74523 2152 bool doutf8 = FALSE; /* whether replacement is in utf8 */
db2c6cb3 2153#ifdef PERL_ANY_COW
ed252734
NC
2154 bool is_cow;
2155#endif
a0714e2c 2156 SV *nsv = NULL;
b770e143 2157 /* known replacement string? */
eb578fdb 2158 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
a0d0e21e 2159
f410a211
NC
2160 PERL_ASYNC_CHECK();
2161
533c011a 2162 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 2163 TARG = POPs;
59f00321
RGS
2164 else if (PL_op->op_private & OPpTARGET_MY)
2165 GETTARGET;
a0d0e21e 2166 else {
54b9620d 2167 TARG = DEFSV;
a0d0e21e 2168 EXTEND(SP,1);
1c846c1f 2169 }
d9f424b2 2170
64534138 2171 SvGETMAGIC(TARG); /* must come before cow check */
db2c6cb3 2172#ifdef PERL_ANY_COW
ed252734
NC
2173 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2174 because they make integers such as 256 "false". */
2175 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2176#else
765f542d
NC
2177 if (SvIsCOW(TARG))
2178 sv_force_normal_flags(TARG,0);
ed252734 2179#endif
8ca8a454 2180 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
db2c6cb3 2181#ifdef PERL_ANY_COW
8ca8a454 2182 && !is_cow
ed252734 2183#endif
8ca8a454
NC
2184 && (SvREADONLY(TARG)
2185 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2186 || SvTYPE(TARG) > SVt_PVLV)
2187 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
cb077ed2 2188 Perl_croak_no_modify();
8ec5e241
NIS
2189 PUTBACK;
2190
64534138 2191 s = SvPV_nomg(TARG, len);
4499db73 2192 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
a0d0e21e 2193 force_on_match = 1;
20be6587
DM
2194
2195 /* only replace once? */
2196 once = !(rpm->op_pmflags & PMf_GLOBAL);
2197
ef07e810 2198 /* See "how taint works" above */
284167a5 2199 if (TAINTING_get) {
20be6587
DM
2200 rxtainted = (
2201 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
284167a5 2202 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
20be6587
DM
2203 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2204 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2205 ? SUBST_TAINT_BOOLRET : 0));
2206 TAINT_NOT;
2207 }
a12c0f56 2208
a30b2f1f 2209 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 2210
a0d0e21e
LW
2211 force_it:
2212 if (!pm || !s)
5637ef5b 2213 DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
a0d0e21e
LW
2214
2215 strend = s + len;
a30b2f1f 2216 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH
2217 maxiters = 2 * slen + 10; /* We can match twice at each
2218 position, once with zero-length,
2219 second time with non-zero. */
a0d0e21e 2220
6a97c51d 2221 if (!RX_PRELEN(rx) && PL_curpm
8d919b0a 2222 && !ReANY(rx)->mother_re) {
3280af22 2223 pm = PL_curpm;
aaa362c4 2224 rx = PM_GETRE(pm);
a0d0e21e 2225 }
6502e081 2226
6e240d0b 2227#ifdef PERL_SAWAMPERSAND
6502e081
DM
2228 r_flags = ( RX_NPARENS(rx)
2229 || PL_sawampersand
6502e081
DM
2230 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2231 )
2232 ? REXEC_COPY_STR
2233 : 0;
6e240d0b
FC
2234#else
2235 r_flags = REXEC_COPY_STR;
2236#endif
7fba1cd6 2237
a0d0e21e 2238 orig = m = s;
07bc277f 2239 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
ee0b7718 2240 PL_bostr = orig;
f9f4320a 2241 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
f722798b
IZ
2242
2243 if (!s)
df34c13a 2244 goto ret_no;
f722798b 2245 /* How to do it in subst? */
07bc277f 2246/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1c846c1f 2247 && !PL_sawampersand
a91cc451 2248 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
f722798b
IZ
2249 goto yup;
2250*/
a0d0e21e 2251 }
71be2cbc 2252
8b64c330
DM
2253 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2254 r_flags | REXEC_CHECKED))
2255 {
5e79dfb9
DM
2256 ret_no:
2257 SPAGAIN;
2258 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2259 LEAVE_SCOPE(oldsave);
2260 RETURN;
2261 }
2262
1754320d
FC
2263 PL_curpm = pm;
2264
71be2cbc 2265 /* known replacement string? */
f272994b 2266 if (dstr) {
8514a05a
JH
2267 /* replacement needing upgrading? */
2268 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2269 nsv = sv_newmortal();
4a176938 2270 SvSetSV(nsv, dstr);
8514a05a
JH
2271 if (PL_encoding)
2272 sv_recode_to_utf8(nsv, PL_encoding);
2273 else
2274 sv_utf8_upgrade(nsv);
5c144d81 2275 c = SvPV_const(nsv, clen);
4a176938
JH
2276 doutf8 = TRUE;
2277 }
2278 else {
5c144d81 2279 c = SvPV_const(dstr, clen);
4a176938 2280 doutf8 = DO_UTF8(dstr);
8514a05a 2281 }
bb933b9b
FC
2282
2283 if (SvTAINTED(dstr))
2284 rxtainted |= SUBST_TAINT_REPL;
f272994b
A
2285 }
2286 else {
6136c704 2287 c = NULL;
f272994b
A
2288 doutf8 = FALSE;
2289 }
2290
71be2cbc 2291 /* can do inplace substitution? */
ed252734 2292 if (c
db2c6cb3 2293#ifdef PERL_ANY_COW
ed252734
NC
2294 && !is_cow
2295#endif
fbfb1899
DM
2296 && (I32)clen <= RX_MINLENRET(rx)
2297 && (once || !(r_flags & REXEC_COPY_STR))
1754320d 2298 && !(RX_EXTFLAGS(rx) & (RXf_LOOKBEHIND_SEEN|RXf_MODIFIES_VARS))
8ca8a454
NC
2299 && (!doutf8 || SvUTF8(TARG))
2300 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
8b030b38 2301 {
ec911639 2302
db2c6cb3 2303#ifdef PERL_ANY_COW
ed252734 2304 if (SvIsCOW(TARG)) {
f7a8268c 2305 if (!force_on_match)
ed252734 2306 goto have_a_cow;
f7a8268c 2307 assert(SvVOK(TARG));
ed252734
NC
2308 }
2309#endif
71be2cbc
PP
2310 if (force_on_match) {
2311 force_on_match = 0;
5c1648b0 2312 s = SvPV_force_nomg(TARG, len);
71be2cbc
PP
2313 goto force_it;
2314 }
71be2cbc 2315 d = s;
71be2cbc 2316 if (once) {
20be6587
DM
2317 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2318 rxtainted |= SUBST_TAINT_PAT;
07bc277f
NC
2319 m = orig + RX_OFFS(rx)[0].start;
2320 d = orig + RX_OFFS(rx)[0].end;
71be2cbc
PP
2321 s = orig;
2322 if (m - s > strend - d) { /* faster to shorten from end */
2323 if (clen) {
2324 Copy(c, m, clen, char);
2325 m += clen;
a0d0e21e 2326 }
71be2cbc
PP
2327 i = strend - d;
2328 if (i > 0) {
2329 Move(d, m, i, char);
2330 m += i;
a0d0e21e 2331 }
71be2cbc
PP
2332 *m = '\0';
2333 SvCUR_set(TARG, m - s);
2334 }
155aba94 2335 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
2336 d -= clen;
2337 m = d;
0d3c21b0 2338 Move(s, d - i, i, char);
71be2cbc 2339 sv_chop(TARG, d-i);
71be2cbc
PP
2340 if (clen)
2341 Copy(c, m, clen, char);
2342 }
2343 else if (clen) {
2344 d -= clen;
2345 sv_chop(TARG, d);
2346 Copy(c, d, clen, char);
2347 }
2348 else {
2349 sv_chop(TARG, d);
2350 }
8ec5e241 2351 SPAGAIN;
8ca8a454 2352 PUSHs(&PL_sv_yes);
71be2cbc
PP
2353 }
2354 else {
71be2cbc
PP
2355 do {
2356 if (iters++ > maxiters)
cea2e8a9 2357 DIE(aTHX_ "Substitution loop");
20be6587
DM
2358 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2359 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2360 m = RX_OFFS(rx)[0].start + orig;
155aba94 2361 if ((i = m - s)) {
71be2cbc
PP
2362 if (s != d)
2363 Move(s, d, i, char);
2364 d += i;
a0d0e21e 2365 }
71be2cbc
PP
2366 if (clen) {
2367 Copy(c, d, clen, char);
2368 d += clen;
2369 }
07bc277f 2370 s = RX_OFFS(rx)[0].end + orig;
f9f4320a 2371 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
f722798b
IZ
2372 TARG, NULL,
2373 /* don't match same null twice */
2374 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
2375 if (s != d) {
2376 i = strend - s;
aa07b2f6 2377 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 2378 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2379 }
8ec5e241 2380 SPAGAIN;
8ca8a454 2381 mPUSHi((I32)iters);
a0d0e21e
LW
2382 }
2383 }
ff6e92e8 2384 else {
1754320d
FC
2385 bool first;
2386 SV *repl;
a0d0e21e
LW
2387 if (force_on_match) {
2388 force_on_match = 0;
0c1438a1
NC
2389 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2390 /* I feel that it should be possible to avoid this mortal copy
2391 given that the code below copies into a new destination.
2392 However, I suspect it isn't worth the complexity of
2393 unravelling the C<goto force_it> for the small number of
2394 cases where it would be viable to drop into the copy code. */
2395 TARG = sv_2mortal(newSVsv(TARG));
2396 }
5c1648b0 2397 s = SvPV_force_nomg(TARG, len);
a0d0e21e
LW
2398 goto force_it;
2399 }
db2c6cb3 2400#ifdef PERL_ANY_COW
ed252734
NC
2401 have_a_cow:
2402#endif
20be6587
DM
2403 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2404 rxtainted |= SUBST_TAINT_PAT;
1754320d 2405 repl = dstr;
815dd406 2406 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
a0d0e21e 2407 if (!c) {
eb578fdb 2408 PERL_CONTEXT *cx;
8ec5e241 2409 SPAGAIN;
20be6587
DM
2410 /* note that a whole bunch of local vars are saved here for
2411 * use by pp_substcont: here's a list of them in case you're
2412 * searching for places in this sub that uses a particular var:
2413 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2414 * s m strend rx once */
a0d0e21e 2415 PUSHSUBST(cx);
20e98b0f 2416 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
a0d0e21e 2417 }
cf93c79d 2418 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1754320d 2419 first = TRUE;
a0d0e21e
LW
2420 do {
2421 if (iters++ > maxiters)
cea2e8a9 2422 DIE(aTHX_ "Substitution loop");
20be6587
DM
2423 if (RX_MATCH_TAINTED(rx))
2424 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2425 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
a0d0e21e
LW
2426 m = s;
2427 s = orig;
6502e081 2428 assert(RX_SUBOFFSET(rx) == 0);
07bc277f 2429 orig = RX_SUBBEG(rx);
a0d0e21e
LW
2430 s = orig + (m - s);
2431 strend = s + (strend - m);
2432 }
07bc277f 2433 m = RX_OFFS(rx)[0].start + orig;
64534138 2434 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
07bc277f 2435 s = RX_OFFS(rx)[0].end + orig;
1754320d
FC
2436 if (first) {
2437 /* replacement already stringified */
2438 if (clen)
64534138 2439 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
1754320d
FC
2440 first = FALSE;
2441 }
2442 else {
1754320d
FC
2443 if (PL_encoding) {
2444 if (!nsv) nsv = sv_newmortal();
2445 sv_copypv(nsv, repl);
2446 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2447 sv_catsv(dstr, nsv);
2448 }
2449 else sv_catsv(dstr, repl);
bb933b9b
FC
2450 if (SvTAINTED(repl))
2451 rxtainted |= SUBST_TAINT_REPL;
1754320d 2452 }
a0d0e21e
LW
2453 if (once)
2454 break;
f9f4320a 2455 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
ffc61ed2 2456 TARG, NULL, r_flags));
64534138 2457 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
748a9306 2458
8ca8a454
NC
2459 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2460 /* From here on down we're using the copy, and leaving the original
2461 untouched. */
2462 TARG = dstr;
2463 SPAGAIN;
2464 PUSHs(dstr);
2465 } else {
db2c6cb3 2466#ifdef PERL_ANY_COW
8ca8a454
NC
2467 /* The match may make the string COW. If so, brilliant, because
2468 that's just saved us one malloc, copy and free - the regexp has
2469 donated the old buffer, and we malloc an entirely new one, rather
2470 than the regexp malloc()ing a buffer and copying our original,
2471 only for us to throw it away here during the substitution. */
2472 if (SvIsCOW(TARG)) {
2473 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2474 } else
ed252734 2475#endif
8ca8a454
NC
2476 {
2477 SvPV_free(TARG);
2478 }
2479 SvPV_set(TARG, SvPVX(dstr));
2480 SvCUR_set(TARG, SvCUR(dstr));
2481 SvLEN_set(TARG, SvLEN(dstr));
64534138 2482 SvFLAGS(TARG) |= SvUTF8(dstr);
8ca8a454 2483 SvPV_set(dstr, NULL);
748a9306 2484
8ca8a454 2485 SPAGAIN;
4f4d7508 2486 mPUSHi((I32)iters);
8ca8a454
NC
2487 }
2488 }
2489
2490 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2491 (void)SvPOK_only_UTF8(TARG);
a0d0e21e 2492 }
20be6587 2493
ef07e810 2494 /* See "how taint works" above */
284167a5 2495 if (TAINTING_get) {
20be6587
DM
2496 if ((rxtainted & SUBST_TAINT_PAT) ||
2497 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2498 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2499 )
2500 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2501
2502 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2503 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2504 )
2505 SvTAINTED_on(TOPs); /* taint return value */
2506 else
2507 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2508
2509 /* needed for mg_set below */
284167a5
SM
2510 TAINT_set(
2511 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2512 );
20be6587
DM
2513 SvTAINT(TARG);
2514 }
2515 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2516 TAINT_NOT;
f1a76097
DM
2517 LEAVE_SCOPE(oldsave);
2518 RETURN;
a0d0e21e
LW
2519}
2520
2521PP(pp_grepwhile)
2522{
27da23d5 2523 dVAR; dSP;
a0d0e21e
LW
2524
2525 if (SvTRUEx(POPs))
3280af22
NIS
2526 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2527 ++*PL_markstack_ptr;
b2a2a901 2528 FREETMPS;
d343c3ef 2529 LEAVE_with_name("grep_item"); /* exit inner scope */
a0d0e21e
LW
2530
2531 /* All done yet? */
3280af22 2532 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2533 I32 items;
c4420975 2534 const I32 gimme = GIMME_V;
a0d0e21e 2535
d343c3ef 2536 LEAVE_with_name("grep"); /* exit outer scope */
a0d0e21e 2537 (void)POPMARK; /* pop src */
3280af22 2538 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2539 (void)POPMARK; /* pop dst */
3280af22 2540 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2541 if (gimme == G_SCALAR) {
7cc47870 2542 if (PL_op->op_private & OPpGREP_LEX) {
c4420975 2543 SV* const sv = sv_newmortal();
7cc47870
RGS
2544 sv_setiv(sv, items);
2545 PUSHs(sv);
2546 }
2547 else {
2548 dTARGET;
2549 XPUSHi(items);
2550 }
a0d0e21e 2551 }
54310121
PP
2552 else if (gimme == G_ARRAY)
2553 SP += items;
a0d0e21e
LW
2554 RETURN;
2555 }
2556 else {
2557 SV *src;
2558
d343c3ef 2559 ENTER_with_name("grep_item"); /* enter inner scope */
1d7c1841 2560 SAVEVPTR(PL_curpm);
a0d0e21e 2561
3280af22 2562 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2563 SvTEMP_off(src);
59f00321
RGS
2564 if (PL_op->op_private & OPpGREP_LEX)
2565 PAD_SVl(PL_op->op_targ) = src;
2566 else
414bf5ae 2567 DEFSV_set(src);
a0d0e21e
LW
2568
2569 RETURNOP(cLOGOP->op_other);
2570 }
2571}
2572
2573PP(pp_leavesub)
2574{
27da23d5 2575 dVAR; dSP;
a0d0e21e
LW
2576 SV **mark;
2577 SV **newsp;
2578 PMOP *newpm;
2579 I32 gimme;
eb578fdb 2580 PERL_CONTEXT *cx;
b0d9ce38 2581 SV *sv;
a0d0e21e 2582
9850bf21
RH
2583 if (CxMULTICALL(&cxstack[cxstack_ix]))
2584 return 0;
2585
a0d0e21e 2586 POPBLOCK(cx,newpm);
5dd42e15 2587 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2588
a1f49e72 2589 TAINT_NOT;
a0d0e21e
LW
2590 if (gimme == G_SCALAR) {
2591 MARK = newsp + 1;
a29cdaf0 2592 if (MARK <= SP) {
a8bba7fa 2593 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
6f48390a
FC
2594 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2595 && !SvMAGICAL(TOPs)) {
a29cdaf0
IZ
2596 *MARK = SvREFCNT_inc(TOPs);
2597 FREETMPS;
2598 sv_2mortal(*MARK);
cd06dffe
GS
2599 }
2600 else {
959e3673 2601 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2602 FREETMPS;
959e3673 2603 *MARK = sv_mortalcopy(sv);
fc2b2dca 2604 SvREFCNT_dec_NN(sv);
a29cdaf0 2605 }
cd06dffe 2606 }
6f48390a
FC
2607 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2608 && !SvMAGICAL(TOPs)) {
767eda44 2609 *MARK = TOPs;
767eda44 2610 }
cd06dffe 2611 else
767eda44 2612 *MARK = sv_mortalcopy(TOPs);
cd06dffe
GS
2613 }
2614 else {
f86702cc 2615 MEXTEND(MARK, 0);
3280af22 2616 *MARK = &PL_sv_undef;
a0d0e21e
LW
2617 }
2618 SP = MARK;
2619 }
54310121 2620 else if (gimme == G_ARRAY) {
f86702cc 2621 for (MARK = newsp + 1; MARK <= SP; MARK++) {
6f48390a
FC
2622 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2623 || SvMAGICAL(*MARK)) {
f86702cc 2624 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2625 TAINT_NOT; /* Each item is independent */
2626 }
f86702cc 2627 }
a0d0e21e 2628 }
f86702cc 2629 PUTBACK;
1c846c1f 2630
a57c6685 2631 LEAVE;
5dd42e15 2632 cxstack_ix--;
b0d9ce38 2633 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2634 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2635
b0d9ce38 2636 LEAVESUB(sv);
f39bc417 2637 return cx->blk_sub.retop;
a0d0e21e
LW
2638}
2639
2640PP(pp_entersub)
2641{
27da23d5 2642 dVAR; dSP; dPOPss;
a0d0e21e 2643 GV *gv;
eb578fdb
KW
2644 CV *cv;
2645 PERL_CONTEXT *cx;
5d94fbed 2646 I32 gimme;
a9c4fd4e 2647 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2648
2649 if (!sv)
cea2e8a9 2650 DIE(aTHX_ "Not a CODE reference");
a0d0e21e 2651 switch (SvTYPE(sv)) {
f1025168
NC
2652 /* This is overwhelming the most common case: */
2653 case SVt_PVGV:
13be902c 2654 we_have_a_glob:
159b6efe 2655 if (!(cv = GvCVu((const GV *)sv))) {
f730a42d 2656 HV *stash;
f2c0649b 2657 cv = sv_2cv(sv, &stash, &gv, 0);
f730a42d 2658 }
f1025168 2659 if (!cv) {
a57c6685 2660 ENTER;
f1025168
NC
2661 SAVETMPS;
2662 goto try_autoload;
2663 }
2664 break;
13be902c
FC
2665 case SVt_PVLV:
2666 if(isGV_with_GP(sv)) goto we_have_a_glob;
2667 /*FALLTHROUGH*/
a0d0e21e 2668 default:
7c75014e
DM
2669 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2670 if (hasargs)
2671 SP = PL_stack_base + POPMARK;
4d198de3
DM
2672 else
2673 (void)POPMARK;
7c75014e
DM
2674 RETURN;
2675 }
2676 SvGETMAGIC(sv);
2677 if (SvROK(sv)) {
93d7320b
DM
2678 if (SvAMAGIC(sv)) {
2679 sv = amagic_deref_call(sv, to_cv_amg);
2680 /* Don't SPAGAIN here. */
2681 }
7c75014e
DM
2682 }
2683 else {
a9c4fd4e 2684 const char *sym;
780a5241 2685 STRLEN len;
79a3e5ea 2686 if (!SvOK(sv))
cea2e8a9 2687 DIE(aTHX_ PL_no_usym, "a subroutine");
79a3e5ea 2688 sym = SvPV_nomg_const(sv, len);
533c011a 2689 if (PL_op->op_private & HINT_STRICT_REFS)
b375e37b 2690 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
780a5241 2691 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
a0d0e21e
LW
2692 break;
2693 }
ea726b52 2694 cv = MUTABLE_CV(SvRV(sv));
a0d0e21e
LW
2695 if (SvTYPE(cv) == SVt_PVCV)
2696 break;
2697 /* FALL THROUGH */
2698 case SVt_PVHV:
2699 case SVt_PVAV:
cea2e8a9 2700 DIE(aTHX_ "Not a CODE reference");
f1025168 2701 /* This is the second most common case: */
a0d0e21e 2702 case SVt_PVCV:
ea726b52 2703 cv = MUTABLE_CV(sv);
a0d0e21e 2704 break;
a0d0e21e
LW
2705 }
2706
a57c6685 2707 ENTER;
a0d0e21e
LW
2708 SAVETMPS;
2709
2710 retry:
541ed3a9
FC
2711 if (CvCLONE(cv) && ! CvCLONED(cv))
2712 DIE(aTHX_ "Closure prototype called");
a0d0e21e 2713 if (!CvROOT(cv) && !CvXSUB(cv)) {
2f349aa0
NC
2714 GV* autogv;
2715 SV* sub_name;
2716
2717 /* anonymous or undef'd function leaves us no recourse */
7d2057d8
FC
2718 if (CvANON(cv) || !(gv = CvGV(cv))) {
2719 if (CvNAMED(cv))
2720 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2721 HEKfARG(CvNAME_HEK(cv)));
2f349aa0 2722 DIE(aTHX_ "Undefined subroutine called");
7d2057d8 2723 }
2f349aa0
NC
2724
2725 /* autoloaded stub? */
2726 if (cv != GvCV(gv)) {
2727 cv = GvCV(gv);
2728 }
2729 /* should call AUTOLOAD now? */
2730 else {
7e623da3 2731try_autoload:
d1089224
BF
2732 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2733 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2f349aa0
NC
2734 {
2735 cv = GvCV(autogv);
2736 }
2f349aa0 2737 else {
c220e1a1 2738 sorry:
2f349aa0 2739 sub_name = sv_newmortal();
6136c704 2740 gv_efullname3(sub_name, gv, NULL);
be2597df 2741 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2f349aa0
NC
2742 }
2743 }
2744 if (!cv)
c220e1a1 2745 goto sorry;
2f349aa0 2746 goto retry;
a0d0e21e
LW
2747 }
2748
54310121 2749 gimme = GIMME_V;
67caa1fe 2750 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
005a8a35 2751 Perl_get_db_sub(aTHX_ &sv, cv);
a9ef256d
NC
2752 if (CvISXSUB(cv))
2753 PL_curcopdb = PL_curcop;
1ad62f64 2754 if (CvLVALUE(cv)) {
2755 /* check for lsub that handles lvalue subroutines */
ae5c1e95 2756 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
1ad62f64 2757 /* if lsub not found then fall back to DB::sub */
2758 if (!cv) cv = GvCV(PL_DBsub);
2759 } else {
2760 cv = GvCV(PL_DBsub);
2761 }
a9ef256d 2762
ccafdc96
RGS
2763 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2764 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2765 }
a0d0e21e 2766
aed2304a 2767 if (!(CvISXSUB(cv))) {
f1025168 2768 /* This path taken at least 75% of the time */
a0d0e21e 2769 dMARK;
eb578fdb 2770 I32 items = SP - MARK;
b70d5558 2771 PADLIST * const padlist = CvPADLIST(cv);
a0d0e21e
LW
2772 PUSHBLOCK(cx, CXt_SUB, MARK);
2773 PUSHSUB(cx);
f39bc417 2774 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 2775 CvDEPTH(cv)++;
3a76ca88
RGS
2776 if (CvDEPTH(cv) >= 2) {
2777 PERL_STACK_OVERFLOW_CHECK();
2778 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2779 }
3a76ca88
RGS
2780 SAVECOMPPAD();
2781 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2782 if (hasargs) {
10533ace 2783 AV *const av = MUTABLE_AV(PAD_SVl(0));
221373f0
GS
2784 if (AvREAL(av)) {
2785 /* @_ is normally not REAL--this should only ever
2786 * happen when DB::sub() calls things that modify @_ */
2787 av_clear(av);
2788 AvREAL_off(av);
2789 AvREIFY_on(av);
2790 }
3280af22 2791 cx->blk_sub.savearray = GvAV(PL_defgv);
502c6561 2792 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
dd2155a4 2793 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2794 cx->blk_sub.argarray = av;
a0d0e21e
LW
2795 ++MARK;
2796
2797 if (items > AvMAX(av) + 1) {
504618e9 2798 SV **ary = AvALLOC(av);
a0d0e21e
LW
2799 if (AvARRAY(av) != ary) {
2800 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 2801 AvARRAY(av) = ary;
a0d0e21e
LW
2802 }
2803 if (items > AvMAX(av) + 1) {
2804 AvMAX(av) = items - 1;
2805 Renew(ary,items,SV*);
2806 AvALLOC(av) = ary;
9c6bc640 2807 AvARRAY(av) = ary;
a0d0e21e
LW
2808 }
2809 }
2810 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2811 AvFILLp(av) = items - 1;
1c846c1f 2812
a0d0e21e
LW
2813 while (items--) {
2814 if (*MARK)
2815 SvTEMP_off(*MARK);
2816 MARK++;
2817 }
2818 }
da1dff94
FC
2819 if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2820 !CvLVALUE(cv))
2821 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
4a925ff6
GS
2822 /* warning must come *after* we fully set up the context
2823 * stuff so that __WARN__ handlers can safely dounwind()
2824 * if they want to
2825 */
2b9dff67 2826 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
4a925ff6
GS
2827 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2828 sub_crush_depth(cv);
a0d0e21e
LW
2829 RETURNOP(CvSTART(cv));
2830 }
f1025168 2831 else {
3a76ca88 2832 I32 markix = TOPMARK;
f1025168 2833
3a76ca88 2834 PUTBACK;
f1025168 2835
3a76ca88
RGS
2836 if (!hasargs) {
2837 /* Need to copy @_ to stack. Alternative may be to
2838 * switch stack to @_, and copy return values
2839 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2840 AV * const av = GvAV(PL_defgv);
2841 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2842
2843 if (items) {
2844 /* Mark is at the end of the stack. */
2845 EXTEND(SP, items);
2846 Copy(AvARRAY(av), SP + 1, items, SV*);
2847 SP += items;
2848 PUTBACK ;
2849 }
2850 }
2851 /* We assume first XSUB in &DB::sub is the called one. */
2852 if (PL_curcopdb) {
2853 SAVEVPTR(PL_curcop);
2854 PL_curcop = PL_curcopdb;
2855 PL_curcopdb = NULL;
2856 }
2857 /* Do we need to open block here? XXXX */
72df79cf 2858
2859 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2860 assert(CvXSUB(cv));
16c91539 2861 CvXSUB(cv)(aTHX_ cv);
3a76ca88
RGS
2862
2863 /* Enforce some sanity in scalar context. */
2864 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2865 if (markix > PL_stack_sp - PL_stack_base)
2866 *(PL_stack_base + markix) = &PL_sv_undef;
2867 else
2868 *(PL_stack_base + markix) = *PL_stack_sp;
2869 PL_stack_sp = PL_stack_base + markix;
2870 }
a57c6685 2871 LEAVE;
f1025168
NC
2872 return NORMAL;
2873 }
a0d0e21e
LW
2874}
2875
44a8e56a 2876void
864dbfa3 2877Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 2878{
7918f24d
NC
2879 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2880
44a8e56a 2881 if (CvANON(cv))
9014280d 2882 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 2883 else {
aec46f14 2884 SV* const tmpstr = sv_newmortal();
6136c704 2885 gv_efullname3(tmpstr, CvGV(cv), NULL);
35c1215d 2886 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
be2597df 2887 SVfARG(tmpstr));
44a8e56a
PP
2888 }
2889}
2890
a0d0e21e
LW
2891PP(pp_aelem)
2892{
97aff369 2893 dVAR; dSP;
a0d0e21e 2894 SV** svp;
a3b680e6 2895 SV* const elemsv = POPs;
d804643f 2896 IV elem = SvIV(elemsv);
502c6561 2897 AV *const av = MUTABLE_AV(POPs);
e1ec3a88
AL
2898 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2899 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
4ad10a0b
VP
2900 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2901 bool preeminent = TRUE;
be6c24e0 2902 SV *sv;
a0d0e21e 2903
e35c1634 2904 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
95b63a38
JH
2905 Perl_warner(aTHX_ packWARN(WARN_MISC),
2906 "Use of reference \"%"SVf"\" as array index",
be2597df 2907 SVfARG(elemsv));
a0d0e21e
LW
2908 if (SvTYPE(av) != SVt_PVAV)
2909 RETPUSHUNDEF;
4ad10a0b
VP
2910
2911 if (localizing) {
2912 MAGIC *mg;
2913 HV *stash;
2914
2915 /* If we can determine whether the element exist,
2916 * Try to preserve the existenceness of a tied array
2917 * element by using EXISTS and DELETE if possible.
2918 * Fallback to FETCH and STORE otherwise. */
2919 if (SvCANEXISTDELETE(av))
2920 preeminent = av_exists(av, elem);
2921 }
2922
68dc0745 2923 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2924 if (lval) {
2b573ace 2925#ifdef PERL_MALLOC_WRAP
2b573ace 2926 if (SvUOK(elemsv)) {
a9c4fd4e 2927 const UV uv = SvUV(elemsv);
2b573ace
JH
2928 elem = uv > IV_MAX ? IV_MAX : uv;
2929 }
2930 else if (SvNOK(elemsv))
2931 elem = (IV)SvNV(elemsv);
a3b680e6
AL
2932 if (elem > 0) {
2933 static const char oom_array_extend[] =
2934 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 2935 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 2936 }
2b573ace 2937#endif
3280af22 2938 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2939 SV* lv;
2940 if (!defer)
cea2e8a9 2941 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2942 lv = sv_newmortal();
2943 sv_upgrade(lv, SVt_PVLV);
2944 LvTYPE(lv) = 'y';
a0714e2c 2945 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
b37c2d43 2946 LvTARG(lv) = SvREFCNT_inc_simple(av);
68dc0745
PP
2947 LvTARGOFF(lv) = elem;
2948 LvTARGLEN(lv) = 1;
2949 PUSHs(lv);
2950 RETURN;
2951 }
4ad10a0b
VP
2952 if (localizing) {
2953 if (preeminent)
2954 save_aelem(av, elem, svp);
2955 else
2956 SAVEADELETE(av, elem);
2957 }
9026059d
GG
2958 else if (PL_op->op_private & OPpDEREF) {
2959 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2960 RETURN;
2961 }
a0d0e21e 2962 }
3280af22 2963 sv = (svp ? *svp : &PL_sv_undef);
39cf747a 2964 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 2965 mg_get(sv);
be6c24e0 2966 PUSHs(sv);
a0d0e21e
LW
2967 RETURN;
2968}
2969
9026059d 2970SV*
864dbfa3 2971Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 2972{
7918f24d
NC
2973 PERL_ARGS_ASSERT_VIVIFY_REF;
2974
5b295bef 2975 SvGETMAGIC(sv);
02a9e968
CS
2976 if (!SvOK(sv)) {
2977 if (SvREADONLY(sv))
cb077ed2 2978 Perl_croak_no_modify();
43230e26 2979 prepare_SV_for_RV(sv);
68dc0745 2980 switch (to_what) {
5f05dabc 2981 case OPpDEREF_SV:
561b68a9 2982 SvRV_set(sv, newSV(0));
5f05dabc
PP
2983 break;
2984 case OPpDEREF_AV:
ad64d0ec 2985 SvRV_set(sv, MUTABLE_SV(newAV()));
5f05dabc
PP
2986 break;
2987 case OPpDEREF_HV:
ad64d0ec 2988 SvRV_set(sv, MUTABLE_SV(newHV()));
5f05dabc
PP
2989 break;
2990 }
02a9e968
CS
2991 SvROK_on(sv);
2992 SvSETMAGIC(sv);
7e482323 2993 SvGETMAGIC(sv);
02a9e968 2994 }
9026059d
GG
2995 if (SvGMAGICAL(sv)) {
2996 /* copy the sv without magic to prevent magic from being
2997 executed twice */
2998 SV* msv = sv_newmortal();
2999 sv_setsv_nomg(msv, sv);
3000 return msv;
3001 }
3002 return sv;
02a9e968
CS
3003}
3004
a0d0e21e
LW
3005PP(pp_method)
3006{
97aff369 3007 dVAR; dSP;
890ce7af 3008 SV* const sv = TOPs;
f5d5a27c
CS
3009
3010 if (SvROK(sv)) {
890ce7af 3011 SV* const rsv = SvRV(sv);
f5d5a27c
CS
3012 if (SvTYPE(rsv) == SVt_PVCV) {
3013 SETs(rsv);
3014 RETURN;
3015 }
3016 }
3017
4608196e 3018 SETs(method_common(sv, NULL));
f5d5a27c
CS
3019 RETURN;
3020}
3021
3022PP(pp_method_named)
3023{
97aff369 3024 dVAR; dSP;
890ce7af 3025 SV* const sv = cSVOP_sv;
c158a4fd 3026 U32 hash = SvSHARED_HASH(sv);
f5d5a27c
CS
3027
3028 XPUSHs(method_common(sv, &hash));
3029 RETURN;
3030}
3031
3032STATIC SV *
3033S_method_common(pTHX_ SV* meth, U32* hashp)
3034{
97aff369 3035 dVAR;
a0d0e21e
LW
3036 SV* ob;
3037 GV* gv;
56304f61 3038 HV* stash;
a0714e2c 3039 SV *packsv = NULL;
f226e9be
FC
3040 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
3041 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3042 "package or object reference", SVfARG(meth)),
3043 (SV *)NULL)
3044 : *(PL_stack_base + TOPMARK + 1);
f5d5a27c 3045
7918f24d
NC
3046 PERL_ARGS_ASSERT_METHOD_COMMON;
3047
4f1b7578 3048 if (!sv)
7156e69a 3049 undefined:
a214957f
VP
3050 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3051 SVfARG(meth));
4f1b7578 3052
5b295bef 3053 SvGETMAGIC(sv);
a0d0e21e 3054 if (SvROK(sv))
ad64d0ec 3055 ob = MUTABLE_SV(SvRV(sv));
7156e69a 3056 else if (!SvOK(sv)) goto undefined;
a0d0e21e 3057 else {
89269094 3058 /* this isn't a reference */
a0d0e21e 3059 GV* iogv;
f937af42 3060 STRLEN packlen;
89269094 3061 const char * const packname = SvPV_nomg_const(sv, packlen);
b3ebc221 3062 const bool packname_is_utf8 = !!SvUTF8(sv);
89269094 3063 const HE* const he =
b3ebc221
NC
3064 (const HE *)hv_common(
3065 PL_stashcache, NULL, packname, packlen,
3066 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
da6b625f
FC
3067 );
3068
89269094 3069 if (he) {
5e6396ae 3070 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
103f5a36
NC
3071 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
3072 stash, sv));
081fc587 3073 goto fetch;
081fc587
AB
3074 }
3075
89269094 3076 if (!(iogv = gv_fetchpvn_flags(
da6b625f
FC
3077 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
3078 )) ||
ad64d0ec 3079 !(ob=MUTABLE_SV(GvIO(iogv))))
a0d0e21e 3080 {
af09ea45 3081 /* this isn't the name of a filehandle either */
89269094 3082 if (!packlen)
834a4ddd 3083 {
7156e69a
FC
3084 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3085 "without a package or object reference",
3086 SVfARG(meth));
834a4ddd 3087 }
af09ea45 3088 /* assume it's a package name */
f937af42 3089 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
0dae17bd
GS
3090 if (!stash)
3091 packsv = sv;
081fc587 3092 else {
d4c19fe8 3093 SV* const ref = newSViv(PTR2IV(stash));
f937af42 3094 (void)hv_store(PL_stashcache, packname,
c60dbbc3 3095 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
103f5a36
NC
3096 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3097 stash, sv));
7e8961ec 3098 }
ac91690f 3099 goto fetch;
a0d0e21e 3100 }
af09ea45 3101 /* it _is_ a filehandle name -- replace with a reference */
ad64d0ec 3102 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
a0d0e21e
LW
3103 }
3104
af09ea45 3105 /* if we got here, ob should be a reference or a glob */
f0d43078 3106 if (!ob || !(SvOBJECT(ob)
6e592b3a
BM
3107 || (SvTYPE(ob) == SVt_PVGV
3108 && isGV_with_GP(ob)
159b6efe 3109 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
f0d43078
GS
3110 && SvOBJECT(ob))))
3111 {
b375e37b
BF
3112 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3113 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3114 ? newSVpvs_flags("DOES", SVs_TEMP)
3115 : meth));
f0d43078 3116 }
a0d0e21e 3117
56304f61 3118 stash = SvSTASH(ob);
a0d0e21e 3119
ac91690f 3120 fetch:
af09ea45
IK
3121 /* NOTE: stash may be null, hope hv_fetch_ent and
3122 gv_fetchmethod can cope (it seems they can) */
3123
f5d5a27c
CS
3124 /* shortcut for simple names */
3125 if (hashp) {
b464bac0 3126 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
f5d5a27c 3127 if (he) {
159b6efe 3128 gv = MUTABLE_GV(HeVAL(he));
f5d5a27c 3129 if (isGV(gv) && GvCV(gv) &&
e1a479c5 3130 (!GvCVGEN(gv) || GvCVGEN(gv)
dd69841b 3131 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
ad64d0ec 3132 return MUTABLE_SV(GvCV(gv));
f5d5a27c
CS
3133 }
3134 }
3135
f937af42
BF
3136 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3137 meth, GV_AUTOLOAD | GV_CROAK);
9b9d0b15 3138
256d1bb2 3139 assert(gv);
9b9d0b15 3140
ad64d0ec 3141 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
a0d0e21e 3142}
241d1a3b
NC
3143
3144/*
3145 * Local variables:
3146 * c-indentation-style: bsd
3147 * c-basic-offset: 4
14d04a33 3148 * indent-tabs-mode: nil
241d1a3b
NC
3149 * End:
3150 *
14d04a33 3151 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3152 */