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