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