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