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