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