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