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