This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove gete?[ug]id caching
[perl5.git] / pp_hot.c
CommitLineData
a0d0e21e
LW
1/* pp_hot.c
2 *
1129b882
NC
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
a0d0e21e
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
13 * shaking the air.
14 *
4ac71550
TC
15 * Awake! Awake! Fear, Fire, Foes! Awake!
16 * Fire, Foes! Awake!
17 *
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
a0d0e21e
LW
19 */
20
166f8a29
DM
21/* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
26 *
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
31 * performance.
32 */
33
a0d0e21e 34#include "EXTERN.h"
864dbfa3 35#define PERL_IN_PP_HOT_C
a0d0e21e
LW
36#include "perl.h"
37
38/* Hot code. */
39
40PP(pp_const)
41{
97aff369 42 dVAR;
39644a26 43 dSP;
996c9baa 44 XPUSHs(cSVOP_sv);
a0d0e21e
LW
45 RETURN;
46}
47
48PP(pp_nextstate)
49{
97aff369 50 dVAR;
533c011a 51 PL_curcop = (COP*)PL_op;
a0d0e21e 52 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 53 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 54 FREETMPS;
f410a211 55 PERL_ASYNC_CHECK();
a0d0e21e
LW
56 return NORMAL;
57}
58
59PP(pp_gvsv)
60{
97aff369 61 dVAR;
39644a26 62 dSP;
924508f0 63 EXTEND(SP,1);
533c011a 64 if (PL_op->op_private & OPpLVAL_INTRO)
1d7c1841 65 PUSHs(save_scalar(cGVOP_gv));
a0d0e21e 66 else
c69033f2 67 PUSHs(GvSVn(cGVOP_gv));
a0d0e21e
LW
68 RETURN;
69}
70
71PP(pp_null)
72{
97aff369 73 dVAR;
a0d0e21e
LW
74 return NORMAL;
75}
76
bf0571fd 77/* This is sometimes called directly by pp_coreargs. */
a0d0e21e
LW
78PP(pp_pushmark)
79{
97aff369 80 dVAR;
3280af22 81 PUSHMARK(PL_stack_sp);
a0d0e21e
LW
82 return NORMAL;
83}
84
85PP(pp_stringify)
86{
97aff369 87 dVAR; dSP; dTARGET;
6050d10e 88 sv_copypv(TARG,TOPs);
a0d0e21e
LW
89 SETTARG;
90 RETURN;
91}
92
93PP(pp_gv)
94{
97aff369 95 dVAR; dSP;
ad64d0ec 96 XPUSHs(MUTABLE_SV(cGVOP_gv));
a0d0e21e
LW
97 RETURN;
98}
99
100PP(pp_and)
101{
97aff369 102 dVAR; dSP;
f410a211 103 PERL_ASYNC_CHECK();
a0d0e21e
LW
104 if (!SvTRUE(TOPs))
105 RETURN;
106 else {
c960fc3b
SP
107 if (PL_op->op_type == OP_AND)
108 --SP;
a0d0e21e
LW
109 RETURNOP(cLOGOP->op_other);
110 }
111}
112
113PP(pp_sassign)
114{
97aff369 115 dVAR; dSP; dPOPTOPssrl;
748a9306 116
533c011a 117 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
0bd48802
AL
118 SV * const temp = left;
119 left = right; right = temp;
a0d0e21e 120 }
3280af22 121 if (PL_tainting && PL_tainted && !SvTAINTED(left))
a0d0e21e 122 TAINT_NOT;
e26df76a 123 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
6136c704 124 SV * const cv = SvRV(left);
e26df76a 125 const U32 cv_type = SvTYPE(cv);
13be902c 126 const bool is_gv = isGV_with_GP(right);
6136c704 127 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
e26df76a
NC
128
129 if (!got_coderef) {
130 assert(SvROK(cv));
131 }
132
ae6d515f 133 /* Can do the optimisation if right (LVALUE) is not a typeglob,
e26df76a
NC
134 left (RVALUE) is a reference to something, and we're in void
135 context. */
13be902c 136 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
e26df76a 137 /* Is the target symbol table currently empty? */
77cb3b01 138 GV * const gv = gv_fetchsv_nomg(right, GV_NOINIT, SVt_PVGV);
bb112e5a 139 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
e26df76a
NC
140 /* Good. Create a new proxy constant subroutine in the target.
141 The gv becomes a(nother) reference to the constant. */
142 SV *const value = SvRV(cv);
143
ad64d0ec 144 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
1ccdb730 145 SvPCS_IMPORTED_on(gv);
e26df76a 146 SvRV_set(gv, value);
b37c2d43 147 SvREFCNT_inc_simple_void(value);
e26df76a
NC
148 SETs(right);
149 RETURN;
150 }
151 }
152
153 /* Need to fix things up. */
13be902c 154 if (!is_gv) {
e26df76a 155 /* Need to fix GV. */
77cb3b01 156 right = MUTABLE_SV(gv_fetchsv_nomg(right,GV_ADD, SVt_PVGV));
e26df76a
NC
157 }
158
159 if (!got_coderef) {
160 /* We've been returned a constant rather than a full subroutine,
161 but they expect a subroutine reference to apply. */
53a42478 162 if (SvROK(cv)) {
d343c3ef 163 ENTER_with_name("sassign_coderef");
53a42478
NC
164 SvREFCNT_inc_void(SvRV(cv));
165 /* newCONSTSUB takes a reference count on the passed in SV
166 from us. We set the name to NULL, otherwise we get into
167 all sorts of fun as the reference to our new sub is
168 donated to the GV that we're about to assign to.
169 */
ad64d0ec
NC
170 SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
171 SvRV(cv))));
53a42478 172 SvREFCNT_dec(cv);
d343c3ef 173 LEAVE_with_name("sassign_coderef");
53a42478
NC
174 } else {
175 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
176 is that
177 First: ops for \&{"BONK"}; return us the constant in the
178 symbol table
179 Second: ops for *{"BONK"} cause that symbol table entry
180 (and our reference to it) to be upgraded from RV
181 to typeblob)
182 Thirdly: We get here. cv is actually PVGV now, and its
183 GvCV() is actually the subroutine we're looking for
184
185 So change the reference so that it points to the subroutine
186 of that typeglob, as that's what they were after all along.
187 */
159b6efe 188 GV *const upgraded = MUTABLE_GV(cv);
53a42478
NC
189 CV *const source = GvCV(upgraded);
190
191 assert(source);
192 assert(CvFLAGS(source) & CVf_CONST);
193
194 SvREFCNT_inc_void(source);
195 SvREFCNT_dec(upgraded);
ad64d0ec 196 SvRV_set(left, MUTABLE_SV(source));
53a42478 197 }
e26df76a 198 }
53a42478 199
e26df76a 200 }
8fe85e3f
FC
201 if (
202 SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 &&
203 (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC)
204 )
205 Perl_warner(aTHX_
206 packWARN(WARN_MISC), "Useless assignment to a temporary"
207 );
54310121 208 SvSetMagicSV(right, left);
a0d0e21e
LW
209 SETs(right);
210 RETURN;
211}
212
213PP(pp_cond_expr)
214{
97aff369 215 dVAR; dSP;
f410a211 216 PERL_ASYNC_CHECK();
a0d0e21e 217 if (SvTRUEx(POPs))
1a67a97c 218 RETURNOP(cLOGOP->op_other);
a0d0e21e 219 else
1a67a97c 220 RETURNOP(cLOGOP->op_next);
a0d0e21e
LW
221}
222
223PP(pp_unstack)
224{
97aff369 225 dVAR;
8f3964af 226 PERL_ASYNC_CHECK();
a0d0e21e 227 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 228 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 229 FREETMPS;
eae48c89
Z
230 if (!(PL_op->op_flags & OPf_SPECIAL)) {
231 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
232 LEAVE_SCOPE(oldsave);
233 }
a0d0e21e
LW
234 return NORMAL;
235}
236
a0d0e21e
LW
237PP(pp_concat)
238{
6f1401dc 239 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
748a9306
LW
240 {
241 dPOPTOPssrl;
8d6d96c1
HS
242 bool lbyte;
243 STRLEN rlen;
d4c19fe8 244 const char *rpv = NULL;
a6b599c7 245 bool rbyte = FALSE;
a9c4fd4e 246 bool rcopied = FALSE;
8d6d96c1 247
6f1401dc
DM
248 if (TARG == right && right != left) { /* $r = $l.$r */
249 rpv = SvPV_nomg_const(right, rlen);
c75ab21a 250 rbyte = !DO_UTF8(right);
59cd0e26 251 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
349d4f2f 252 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
db79b45b 253 rcopied = TRUE;
8d6d96c1 254 }
7889fe52 255
89734059 256 if (TARG != left) { /* not $l .= $r */
a9c4fd4e 257 STRLEN llen;
6f1401dc 258 const char* const lpv = SvPV_nomg_const(left, llen);
90f5826e 259 lbyte = !DO_UTF8(left);
8d6d96c1
HS
260 sv_setpvn(TARG, lpv, llen);
261 if (!lbyte)
262 SvUTF8_on(TARG);
263 else
264 SvUTF8_off(TARG);
265 }
89734059 266 else { /* $l .= $r */
c75ab21a 267 if (!SvOK(TARG)) {
89734059 268 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
c75ab21a 269 report_uninit(right);
76f68e9b 270 sv_setpvs(left, "");
c75ab21a 271 }
c5aa2872
DM
272 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
273 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
90f5826e
ST
274 if (IN_BYTES)
275 SvUTF8_off(TARG);
8d6d96c1 276 }
a12c0f56 277
c75ab21a 278 if (!rcopied) {
6f1401dc 279 if (left == right)
89734059 280 /* $r.$r: do magic twice: tied might return different 2nd time */
6f1401dc
DM
281 SvGETMAGIC(right);
282 rpv = SvPV_nomg_const(right, rlen);
c75ab21a
RH
283 rbyte = !DO_UTF8(right);
284 }
8d6d96c1 285 if (lbyte != rbyte) {
e3393f51
NT
286 /* sv_utf8_upgrade_nomg() may reallocate the stack */
287 PUTBACK;
8d6d96c1
HS
288 if (lbyte)
289 sv_utf8_upgrade_nomg(TARG);
290 else {
db79b45b 291 if (!rcopied)
59cd0e26 292 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
8d6d96c1 293 sv_utf8_upgrade_nomg(right);
6f1401dc 294 rpv = SvPV_nomg_const(right, rlen);
69b47968 295 }
e3393f51 296 SPAGAIN;
a0d0e21e 297 }
8d6d96c1 298 sv_catpvn_nomg(TARG, rpv, rlen);
43ebc500 299
a0d0e21e
LW
300 SETTARG;
301 RETURN;
748a9306 302 }
a0d0e21e
LW
303}
304
305PP(pp_padsv)
306{
97aff369 307 dVAR; dSP; dTARGET;
a0d0e21e 308 XPUSHs(TARG);
533c011a
NIS
309 if (PL_op->op_flags & OPf_MOD) {
310 if (PL_op->op_private & OPpLVAL_INTRO)
952306ac
RGS
311 if (!(PL_op->op_private & OPpPAD_STATE))
312 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
a62b51b8 313 if (PL_op->op_private & OPpDEREF) {
8ec5e241 314 PUTBACK;
9026059d 315 TOPs = vivify_ref(TOPs, PL_op->op_private & OPpDEREF);
8ec5e241
NIS
316 SPAGAIN;
317 }
4633a7c4 318 }
a0d0e21e
LW
319 RETURN;
320}
321
322PP(pp_readline)
323{
97aff369 324 dVAR;
30901a8a
FC
325 dSP;
326 if (TOPs) {
327 SvGETMAGIC(TOPs);
328 tryAMAGICunTARGET(iter_amg, 0, 0);
329 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
330 }
331 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
6e592b3a
BM
332 if (!isGV_with_GP(PL_last_in_gv)) {
333 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
159b6efe 334 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
8efb3254 335 else {
f5284f61 336 dSP;
ad64d0ec 337 XPUSHs(MUTABLE_SV(PL_last_in_gv));
f5284f61 338 PUTBACK;
897d3989 339 Perl_pp_rv2gv(aTHX);
159b6efe 340 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
f5284f61
IZ
341 }
342 }
a0d0e21e
LW
343 return do_readline();
344}
345
346PP(pp_eq)
347{
6f1401dc 348 dVAR; dSP;
33efebe6
DM
349 SV *left, *right;
350
a42d0242 351 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
352 right = POPs;
353 left = TOPs;
354 SETs(boolSV(
355 (SvIOK_notUV(left) && SvIOK_notUV(right))
356 ? (SvIVX(left) == SvIVX(right))
357 : ( do_ncmp(left, right) == 0)
358 ));
359 RETURN;
a0d0e21e
LW
360}
361
362PP(pp_preinc)
363{
97aff369 364 dVAR; dSP;
17058fe0
FC
365 const bool inc =
366 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
60092ce4 367 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
6ad8f254 368 Perl_croak_no_modify(aTHX);
3510b4a1 369 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
17058fe0 370 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
55497cff 371 {
17058fe0 372 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
55497cff 373 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 374 }
28e5dec8 375 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
17058fe0
FC
376 if (inc) sv_inc(TOPs);
377 else sv_dec(TOPs);
a0d0e21e
LW
378 SvSETMAGIC(TOPs);
379 return NORMAL;
380}
381
382PP(pp_or)
383{
97aff369 384 dVAR; dSP;
f410a211 385 PERL_ASYNC_CHECK();
a0d0e21e
LW
386 if (SvTRUE(TOPs))
387 RETURN;
388 else {
c960fc3b
SP
389 if (PL_op->op_type == OP_OR)
390 --SP;
a0d0e21e
LW
391 RETURNOP(cLOGOP->op_other);
392 }
393}
394
25a55bd7 395PP(pp_defined)
c963b151 396{
97aff369 397 dVAR; dSP;
6136c704
AL
398 register SV* sv;
399 bool defined;
25a55bd7 400 const int op_type = PL_op->op_type;
ea5195b7 401 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
c963b151 402
6136c704 403 if (is_dor) {
f410a211 404 PERL_ASYNC_CHECK();
25a55bd7
SP
405 sv = TOPs;
406 if (!sv || !SvANY(sv)) {
2bd49cfc
NC
407 if (op_type == OP_DOR)
408 --SP;
25a55bd7
SP
409 RETURNOP(cLOGOP->op_other);
410 }
b7c44293
RGS
411 }
412 else {
413 /* OP_DEFINED */
25a55bd7
SP
414 sv = POPs;
415 if (!sv || !SvANY(sv))
416 RETPUSHNO;
b7c44293 417 }
25a55bd7 418
6136c704 419 defined = FALSE;
c963b151
BD
420 switch (SvTYPE(sv)) {
421 case SVt_PVAV:
422 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 423 defined = TRUE;
c963b151
BD
424 break;
425 case SVt_PVHV:
426 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 427 defined = TRUE;
c963b151
BD
428 break;
429 case SVt_PVCV:
430 if (CvROOT(sv) || CvXSUB(sv))
25a55bd7 431 defined = TRUE;
c963b151
BD
432 break;
433 default:
5b295bef 434 SvGETMAGIC(sv);
c963b151 435 if (SvOK(sv))
25a55bd7 436 defined = TRUE;
6136c704 437 break;
c963b151 438 }
6136c704
AL
439
440 if (is_dor) {
c960fc3b
SP
441 if(defined)
442 RETURN;
443 if(op_type == OP_DOR)
444 --SP;
25a55bd7 445 RETURNOP(cLOGOP->op_other);
25a55bd7 446 }
d9aa96a4
SP
447 /* assuming OP_DEFINED */
448 if(defined)
449 RETPUSHYES;
450 RETPUSHNO;
c963b151
BD
451}
452
a0d0e21e
LW
453PP(pp_add)
454{
800401ee 455 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
456 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
457 svr = TOPs;
458 svl = TOPm1s;
459
800401ee 460 useleft = USE_LEFT(svl);
28e5dec8
JH
461#ifdef PERL_PRESERVE_IVUV
462 /* We must see if we can perform the addition with integers if possible,
463 as the integer code detects overflow while the NV code doesn't.
464 If either argument hasn't had a numeric conversion yet attempt to get
465 the IV. It's important to do this now, rather than just assuming that
466 it's not IOK as a PV of "9223372036854775806" may not take well to NV
467 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
468 integer in case the second argument is IV=9223372036854775806
469 We can (now) rely on sv_2iv to do the right thing, only setting the
470 public IOK flag if the value in the NV (or PV) slot is truly integer.
471
472 A side effect is that this also aggressively prefers integer maths over
7dca457a
NC
473 fp maths for integer values.
474
a00b5bd3 475 How to detect overflow?
7dca457a
NC
476
477 C 99 section 6.2.6.1 says
478
479 The range of nonnegative values of a signed integer type is a subrange
480 of the corresponding unsigned integer type, and the representation of
481 the same value in each type is the same. A computation involving
482 unsigned operands can never overflow, because a result that cannot be
483 represented by the resulting unsigned integer type is reduced modulo
484 the number that is one greater than the largest value that can be
485 represented by the resulting type.
486
487 (the 9th paragraph)
488
489 which I read as "unsigned ints wrap."
490
491 signed integer overflow seems to be classed as "exception condition"
492
493 If an exceptional condition occurs during the evaluation of an
494 expression (that is, if the result is not mathematically defined or not
495 in the range of representable values for its type), the behavior is
496 undefined.
497
498 (6.5, the 5th paragraph)
499
500 I had assumed that on 2s complement machines signed arithmetic would
501 wrap, hence coded pp_add and pp_subtract on the assumption that
502 everything perl builds on would be happy. After much wailing and
503 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
504 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
505 unsigned code below is actually shorter than the old code. :-)
506 */
507
6f1401dc
DM
508 SvIV_please_nomg(svr);
509
800401ee 510 if (SvIOK(svr)) {
28e5dec8
JH
511 /* Unless the left argument is integer in range we are going to have to
512 use NV maths. Hence only attempt to coerce the right argument if
513 we know the left is integer. */
9c5ffd7c
JH
514 register UV auv = 0;
515 bool auvok = FALSE;
7dca457a
NC
516 bool a_valid = 0;
517
28e5dec8 518 if (!useleft) {
7dca457a
NC
519 auv = 0;
520 a_valid = auvok = 1;
521 /* left operand is undef, treat as zero. + 0 is identity,
522 Could SETi or SETu right now, but space optimise by not adding
523 lots of code to speed up what is probably a rarish case. */
524 } else {
525 /* Left operand is defined, so is it IV? */
6f1401dc 526 SvIV_please_nomg(svl);
800401ee
JH
527 if (SvIOK(svl)) {
528 if ((auvok = SvUOK(svl)))
529 auv = SvUVX(svl);
7dca457a 530 else {
800401ee 531 register const IV aiv = SvIVX(svl);
7dca457a
NC
532 if (aiv >= 0) {
533 auv = aiv;
534 auvok = 1; /* Now acting as a sign flag. */
535 } else { /* 2s complement assumption for IV_MIN */
536 auv = (UV)-aiv;
537 }
538 }
539 a_valid = 1;
28e5dec8
JH
540 }
541 }
7dca457a
NC
542 if (a_valid) {
543 bool result_good = 0;
544 UV result;
545 register UV buv;
800401ee 546 bool buvok = SvUOK(svr);
a00b5bd3 547
7dca457a 548 if (buvok)
800401ee 549 buv = SvUVX(svr);
7dca457a 550 else {
800401ee 551 register const IV biv = SvIVX(svr);
7dca457a
NC
552 if (biv >= 0) {
553 buv = biv;
554 buvok = 1;
555 } else
556 buv = (UV)-biv;
557 }
558 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 559 else "IV" now, independent of how it came in.
7dca457a
NC
560 if a, b represents positive, A, B negative, a maps to -A etc
561 a + b => (a + b)
562 A + b => -(a - b)
563 a + B => (a - b)
564 A + B => -(a + b)
565 all UV maths. negate result if A negative.
566 add if signs same, subtract if signs differ. */
567
568 if (auvok ^ buvok) {
569 /* Signs differ. */
570 if (auv >= buv) {
571 result = auv - buv;
572 /* Must get smaller */
573 if (result <= auv)
574 result_good = 1;
575 } else {
576 result = buv - auv;
577 if (result <= buv) {
578 /* result really should be -(auv-buv). as its negation
579 of true value, need to swap our result flag */
580 auvok = !auvok;
581 result_good = 1;
28e5dec8
JH
582 }
583 }
7dca457a
NC
584 } else {
585 /* Signs same */
586 result = auv + buv;
587 if (result >= auv)
588 result_good = 1;
589 }
590 if (result_good) {
591 SP--;
592 if (auvok)
28e5dec8 593 SETu( result );
7dca457a
NC
594 else {
595 /* Negate result */
596 if (result <= (UV)IV_MIN)
597 SETi( -(IV)result );
598 else {
599 /* result valid, but out of range for IV. */
600 SETn( -(NV)result );
28e5dec8
JH
601 }
602 }
7dca457a
NC
603 RETURN;
604 } /* Overflow, drop through to NVs. */
28e5dec8
JH
605 }
606 }
607#endif
a0d0e21e 608 {
6f1401dc 609 NV value = SvNV_nomg(svr);
4efa5a16 610 (void)POPs;
28e5dec8
JH
611 if (!useleft) {
612 /* left operand is undef, treat as zero. + 0.0 is identity. */
613 SETn(value);
614 RETURN;
615 }
6f1401dc 616 SETn( value + SvNV_nomg(svl) );
28e5dec8 617 RETURN;
a0d0e21e
LW
618 }
619}
620
621PP(pp_aelemfast)
622{
97aff369 623 dVAR; dSP;
93bad3fd 624 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
8f878375 625 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
a3b680e6 626 const U32 lval = PL_op->op_flags & OPf_MOD;
0bd48802 627 SV** const svp = av_fetch(av, PL_op->op_private, lval);
3280af22 628 SV *sv = (svp ? *svp : &PL_sv_undef);
6ff81951 629 EXTEND(SP, 1);
39cf747a 630 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 631 mg_get(sv);
be6c24e0 632 PUSHs(sv);
a0d0e21e
LW
633 RETURN;
634}
635
636PP(pp_join)
637{
97aff369 638 dVAR; dSP; dMARK; dTARGET;
a0d0e21e
LW
639 MARK++;
640 do_join(TARG, *MARK, MARK, SP);
641 SP = MARK;
642 SETs(TARG);
643 RETURN;
644}
645
646PP(pp_pushre)
647{
97aff369 648 dVAR; dSP;
44a8e56a
PP
649#ifdef DEBUGGING
650 /*
651 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
652 * will be enough to hold an OP*.
653 */
c4420975 654 SV* const sv = sv_newmortal();
44a8e56a
PP
655 sv_upgrade(sv, SVt_PVLV);
656 LvTYPE(sv) = '/';
533c011a 657 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
44a8e56a
PP
658 XPUSHs(sv);
659#else
ad64d0ec 660 XPUSHs(MUTABLE_SV(PL_op));
44a8e56a 661#endif
a0d0e21e
LW
662 RETURN;
663}
664
665/* Oversized hot code. */
666
667PP(pp_print)
668{
27da23d5 669 dVAR; dSP; dMARK; dORIGMARK;
760ac839 670 register PerlIO *fp;
236988e4 671 MAGIC *mg;
159b6efe
NC
672 GV * const gv
673 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 674 IO *io = GvIO(gv);
5b468f54 675
9c9f25b8 676 if (io
ad64d0ec 677 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 678 {
01bb7c6d 679 had_magic:
68dc0745 680 if (MARK == ORIGMARK) {
1c846c1f 681 /* If using default handle then we need to make space to
a60c0954
NIS
682 * pass object as 1st arg, so move other args up ...
683 */
4352c267 684 MEXTEND(SP, 1);
68dc0745
PP
685 ++MARK;
686 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
687 ++SP;
688 }
94bc412f
NC
689 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
690 mg,
691 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
692 | (PL_op->op_type == OP_SAY
693 ? TIED_METHOD_SAY : 0)), sp - mark);
236988e4 694 }
9c9f25b8 695 if (!io) {
68b590d9 696 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
ad64d0ec 697 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 698 goto had_magic;
51087808 699 report_evil_fh(gv);
93189314 700 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
701 goto just_say_no;
702 }
703 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
704 if (IoIFP(io))
705 report_wrongway_fh(gv, '<');
51087808 706 else
7716c5c5 707 report_evil_fh(gv);
93189314 708 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
709 goto just_say_no;
710 }
711 else {
e23d9e2f 712 SV * const ofs = GvSV(PL_ofsgv); /* $, */
a0d0e21e 713 MARK++;
e23d9e2f 714 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
a0d0e21e
LW
715 while (MARK <= SP) {
716 if (!do_print(*MARK, fp))
717 break;
718 MARK++;
719 if (MARK <= SP) {
e23d9e2f
CS
720 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
721 if (!do_print(GvSV(PL_ofsgv), fp)) {
a0d0e21e
LW
722 MARK--;
723 break;
724 }
725 }
726 }
727 }
728 else {
729 while (MARK <= SP) {
730 if (!do_print(*MARK, fp))
731 break;
732 MARK++;
733 }
734 }
735 if (MARK <= SP)
736 goto just_say_no;
737 else {
cfc4a7da
GA
738 if (PL_op->op_type == OP_SAY) {
739 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
740 goto just_say_no;
741 }
742 else if (PL_ors_sv && SvOK(PL_ors_sv))
7889fe52 743 if (!do_print(PL_ors_sv, fp)) /* $\ */
a0d0e21e
LW
744 goto just_say_no;
745
746 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 747 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
748 goto just_say_no;
749 }
750 }
751 SP = ORIGMARK;
e52fd6f4 752 XPUSHs(&PL_sv_yes);
a0d0e21e
LW
753 RETURN;
754
755 just_say_no:
756 SP = ORIGMARK;
e52fd6f4 757 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
758 RETURN;
759}
760
761PP(pp_rv2av)
762{
97aff369 763 dVAR; dSP; dTOPss;
cde874ca 764 const I32 gimme = GIMME_V;
17ab7946
NC
765 static const char an_array[] = "an ARRAY";
766 static const char a_hash[] = "a HASH";
767 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
d83b45b8 768 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 769
9026059d 770 SvGETMAGIC(sv);
a0d0e21e 771 if (SvROK(sv)) {
93d7320b
DM
772 if (SvAMAGIC(sv)) {
773 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
93d7320b 774 }
17ab7946
NC
775 sv = SvRV(sv);
776 if (SvTYPE(sv) != type)
dcbac5bb 777 /* diag_listed_as: Not an ARRAY reference */
17ab7946 778 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
533c011a 779 if (PL_op->op_flags & OPf_REF) {
17ab7946 780 SETs(sv);
a0d0e21e
LW
781 RETURN;
782 }
40c94d11
FC
783 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
784 const I32 flags = is_lvalue_sub();
785 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 786 if (gimme != G_ARRAY)
042560a6 787 goto croak_cant_return;
17ab7946 788 SETs(sv);
78f9721b 789 RETURN;
40c94d11 790 }
78f9721b 791 }
82d03984
RGS
792 else if (PL_op->op_flags & OPf_MOD
793 && PL_op->op_private & OPpLVAL_INTRO)
f1f66076 794 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e
LW
795 }
796 else {
17ab7946 797 if (SvTYPE(sv) == type) {
533c011a 798 if (PL_op->op_flags & OPf_REF) {
17ab7946 799 SETs(sv);
a0d0e21e
LW
800 RETURN;
801 }
78f9721b 802 else if (LVRET) {
cde874ca 803 if (gimme != G_ARRAY)
042560a6 804 goto croak_cant_return;
17ab7946 805 SETs(sv);
78f9721b
SM
806 RETURN;
807 }
a0d0e21e
LW
808 }
809 else {
67955e0c 810 GV *gv;
1c846c1f 811
6e592b3a 812 if (!isGV_with_GP(sv)) {
dc3c76f8
NC
813 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
814 type, &sp);
815 if (!gv)
816 RETURN;
35cd451c
GS
817 }
818 else {
159b6efe 819 gv = MUTABLE_GV(sv);
a0d0e21e 820 }
ad64d0ec 821 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 822 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 823 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
533c011a 824 if (PL_op->op_flags & OPf_REF) {
17ab7946 825 SETs(sv);
a0d0e21e
LW
826 RETURN;
827 }
40c94d11
FC
828 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
829 const I32 flags = is_lvalue_sub();
830 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 831 if (gimme != G_ARRAY)
042560a6 832 goto croak_cant_return;
17ab7946 833 SETs(sv);
78f9721b 834 RETURN;
40c94d11 835 }
78f9721b 836 }
a0d0e21e
LW
837 }
838 }
839
17ab7946 840 if (is_pp_rv2av) {
502c6561 841 AV *const av = MUTABLE_AV(sv);
486ec47a 842 /* The guts of pp_rv2av, with no intending change to preserve history
17ab7946
NC
843 (until such time as we get tools that can do blame annotation across
844 whitespace changes. */
96913b52
VP
845 if (gimme == G_ARRAY) {
846 const I32 maxarg = AvFILL(av) + 1;
847 (void)POPs; /* XXXX May be optimized away? */
848 EXTEND(SP, maxarg);
849 if (SvRMAGICAL(av)) {
850 U32 i;
851 for (i=0; i < (U32)maxarg; i++) {
852 SV ** const svp = av_fetch(av, i, FALSE);
853 /* See note in pp_helem, and bug id #27839 */
854 SP[i+1] = svp
855 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
856 : &PL_sv_undef;
857 }
858 }
859 else {
860 Copy(AvARRAY(av), SP+1, maxarg, SV*);
93965878 861 }
96913b52 862 SP += maxarg;
1c846c1f 863 }
96913b52
VP
864 else if (gimme == G_SCALAR) {
865 dTARGET;
866 const I32 maxarg = AvFILL(av) + 1;
867 SETi(maxarg);
93965878 868 }
17ab7946
NC
869 } else {
870 /* The guts of pp_rv2hv */
96913b52
VP
871 if (gimme == G_ARRAY) { /* array wanted */
872 *PL_stack_sp = sv;
981b7185 873 return Perl_do_kv(aTHX);
96913b52
VP
874 }
875 else if (gimme == G_SCALAR) {
876 dTARGET;
877 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
878 SPAGAIN;
879 SETTARG;
880 }
17ab7946 881 }
be85d344 882 RETURN;
042560a6
NC
883
884 croak_cant_return:
885 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
886 is_pp_rv2av ? "array" : "hash");
77e217c6 887 RETURN;
a0d0e21e
LW
888}
889
10c8fecd
GS
890STATIC void
891S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
892{
97aff369 893 dVAR;
7918f24d
NC
894
895 PERL_ARGS_ASSERT_DO_ODDBALL;
896
10c8fecd
GS
897 if (*relem) {
898 SV *tmpstr;
b464bac0 899 const HE *didstore;
6d822dc4
MS
900
901 if (ckWARN(WARN_MISC)) {
a3b680e6 902 const char *err;
10c8fecd
GS
903 if (relem == firstrelem &&
904 SvROK(*relem) &&
905 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
906 SvTYPE(SvRV(*relem)) == SVt_PVHV))
907 {
a3b680e6 908 err = "Reference found where even-sized list expected";
10c8fecd
GS
909 }
910 else
a3b680e6 911 err = "Odd number of elements in hash assignment";
f1f66076 912 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
10c8fecd 913 }
6d822dc4 914
561b68a9 915 tmpstr = newSV(0);
6d822dc4
MS
916 didstore = hv_store_ent(hash,*relem,tmpstr,0);
917 if (SvMAGICAL(hash)) {
918 if (SvSMAGICAL(tmpstr))
919 mg_set(tmpstr);
920 if (!didstore)
921 sv_2mortal(tmpstr);
922 }
923 TAINT_NOT;
10c8fecd
GS
924 }
925}
926
a0d0e21e
LW
927PP(pp_aassign)
928{
27da23d5 929 dVAR; dSP;
3280af22
NIS
930 SV **lastlelem = PL_stack_sp;
931 SV **lastrelem = PL_stack_base + POPMARK;
932 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
933 SV **firstlelem = lastrelem + 1;
934
935 register SV **relem;
936 register SV **lelem;
937
938 register SV *sv;
939 register AV *ary;
940
54310121 941 I32 gimme;
a0d0e21e
LW
942 HV *hash;
943 I32 i;
944 int magic;
ca65944e 945 int duplicates = 0;
cbbf8932 946 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
5637b936 947
3280af22 948 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
ca65944e 949 gimme = GIMME_V;
a0d0e21e
LW
950
951 /* If there's a common identifier on both sides we have to take
952 * special care that assigning the identifier on the left doesn't
953 * clobber a value on the right that's used later in the list.
acdea6f0 954 * Don't bother if LHS is just an empty hash or array.
a0d0e21e 955 */
acdea6f0
DM
956
957 if ( (PL_op->op_private & OPpASSIGN_COMMON)
958 && (
959 firstlelem != lastlelem
960 || ! ((sv = *firstlelem))
961 || SvMAGICAL(sv)
962 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
963 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1b95d04f 964 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
acdea6f0
DM
965 )
966 ) {
cc5e57d2 967 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd 968 for (relem = firstrelem; relem <= lastrelem; relem++) {
155aba94 969 if ((sv = *relem)) {
a1f49e72 970 TAINT_NOT; /* Each item is independent */
61e5f455
NC
971
972 /* Dear TODO test in t/op/sort.t, I love you.
973 (It's relying on a panic, not a "semi-panic" from newSVsv()
974 and then an assertion failure below.) */
975 if (SvIS_FREED(sv)) {
976 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
977 (void*)sv);
978 }
979 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
980 and we need a second copy of a temp here. */
981 *relem = sv_2mortal(newSVsv(sv));
a1f49e72 982 }
10c8fecd 983 }
a0d0e21e
LW
984 }
985
986 relem = firstrelem;
987 lelem = firstlelem;
4608196e
RGS
988 ary = NULL;
989 hash = NULL;
10c8fecd 990
a0d0e21e 991 while (lelem <= lastlelem) {
bbce6d69 992 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e
LW
993 sv = *lelem++;
994 switch (SvTYPE(sv)) {
995 case SVt_PVAV:
60edcf09 996 ary = MUTABLE_AV(sv);
748a9306 997 magic = SvMAGICAL(ary) != 0;
60edcf09
FC
998 ENTER;
999 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1000 av_clear(ary);
7e42bd57 1001 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
1002 i = 0;
1003 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 1004 SV **didstore;
a0d0e21e 1005 assert(*relem);
4f0556e9
NC
1006 sv = newSV(0);
1007 sv_setsv(sv, *relem);
a0d0e21e 1008 *(relem++) = sv;
5117ca91
GS
1009 didstore = av_store(ary,i++,sv);
1010 if (magic) {
8ef24240 1011 if (SvSMAGICAL(sv))
fb73857a 1012 mg_set(sv);
5117ca91 1013 if (!didstore)
8127e0e3 1014 sv_2mortal(sv);
5117ca91 1015 }
bbce6d69 1016 TAINT_NOT;
a0d0e21e 1017 }
354b0578 1018 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 1019 SvSETMAGIC(MUTABLE_SV(ary));
60edcf09 1020 LEAVE;
a0d0e21e 1021 break;
10c8fecd 1022 case SVt_PVHV: { /* normal hash */
a0d0e21e 1023 SV *tmpstr;
45960564 1024 SV** topelem = relem;
a0d0e21e 1025
60edcf09 1026 hash = MUTABLE_HV(sv);
748a9306 1027 magic = SvMAGICAL(hash) != 0;
60edcf09
FC
1028 ENTER;
1029 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1030 hv_clear(hash);
ca65944e 1031 firsthashrelem = relem;
a0d0e21e
LW
1032
1033 while (relem < lastrelem) { /* gobble up all the rest */
5117ca91 1034 HE *didstore;
6136c704
AL
1035 sv = *relem ? *relem : &PL_sv_no;
1036 relem++;
561b68a9 1037 tmpstr = newSV(0);
a0d0e21e
LW
1038 if (*relem)
1039 sv_setsv(tmpstr,*relem); /* value */
45960564
DM
1040 relem++;
1041 if (gimme != G_VOID) {
1042 if (hv_exists_ent(hash, sv, 0))
1043 /* key overwrites an existing entry */
1044 duplicates += 2;
1045 else
1046 if (gimme == G_ARRAY) {
1047 /* copy element back: possibly to an earlier
1048 * stack location if we encountered dups earlier */
1049 *topelem++ = sv;
1050 *topelem++ = tmpstr;
1051 }
1052 }
5117ca91
GS
1053 didstore = hv_store_ent(hash,sv,tmpstr,0);
1054 if (magic) {
8ef24240 1055 if (SvSMAGICAL(tmpstr))
fb73857a 1056 mg_set(tmpstr);
5117ca91 1057 if (!didstore)
8127e0e3 1058 sv_2mortal(tmpstr);
5117ca91 1059 }
bbce6d69 1060 TAINT_NOT;
8e07c86e 1061 }
6a0deba8 1062 if (relem == lastrelem) {
10c8fecd 1063 do_oddball(hash, relem, firstrelem);
6a0deba8 1064 relem++;
1930e939 1065 }
60edcf09 1066 LEAVE;
a0d0e21e
LW
1067 }
1068 break;
1069 default:
6fc92669
GS
1070 if (SvIMMORTAL(sv)) {
1071 if (relem <= lastrelem)
1072 relem++;
1073 break;
a0d0e21e
LW
1074 }
1075 if (relem <= lastrelem) {
1c70fb82
FC
1076 if (
1077 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1078 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1079 )
1080 Perl_warner(aTHX_
1081 packWARN(WARN_MISC),
1082 "Useless assignment to a temporary"
1083 );
a0d0e21e
LW
1084 sv_setsv(sv, *relem);
1085 *(relem++) = sv;
1086 }
1087 else
3280af22 1088 sv_setsv(sv, &PL_sv_undef);
8ef24240 1089 SvSETMAGIC(sv);
a0d0e21e
LW
1090 break;
1091 }
1092 }
3280af22 1093 if (PL_delaymagic & ~DM_DELAY) {
985213f2
AB
1094 /* Will be used to set PL_tainting below */
1095 UV tmp_uid = PerlProc_getuid();
1096 UV tmp_euid = PerlProc_geteuid();
1097 UV tmp_gid = PerlProc_getgid();
1098 UV tmp_egid = PerlProc_getegid();
1099
3280af22 1100 if (PL_delaymagic & DM_UID) {
a0d0e21e 1101#ifdef HAS_SETRESUID
985213f2
AB
1102 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1103 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
fb934a90 1104 (Uid_t)-1);
56febc5e
AD
1105#else
1106# ifdef HAS_SETREUID
985213f2
AB
1107 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1108 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
56febc5e
AD
1109# else
1110# ifdef HAS_SETRUID
b28d0864 1111 if ((PL_delaymagic & DM_UID) == DM_RUID) {
985213f2 1112 (void)setruid(PL_delaymagic_uid);
b28d0864 1113 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1114 }
56febc5e
AD
1115# endif /* HAS_SETRUID */
1116# ifdef HAS_SETEUID
b28d0864 1117 if ((PL_delaymagic & DM_UID) == DM_EUID) {
985213f2 1118 (void)seteuid(PL_delaymagic_euid);
b28d0864 1119 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1120 }
56febc5e 1121# endif /* HAS_SETEUID */
b28d0864 1122 if (PL_delaymagic & DM_UID) {
985213f2 1123 if (PL_delaymagic_uid != PL_delaymagic_euid)
cea2e8a9 1124 DIE(aTHX_ "No setreuid available");
985213f2 1125 (void)PerlProc_setuid(PL_delaymagic_uid);
a0d0e21e 1126 }
56febc5e
AD
1127# endif /* HAS_SETREUID */
1128#endif /* HAS_SETRESUID */
985213f2
AB
1129 tmp_uid = PerlProc_getuid();
1130 tmp_euid = PerlProc_geteuid();
a0d0e21e 1131 }
3280af22 1132 if (PL_delaymagic & DM_GID) {
a0d0e21e 1133#ifdef HAS_SETRESGID
985213f2
AB
1134 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1135 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
fb934a90 1136 (Gid_t)-1);
56febc5e
AD
1137#else
1138# ifdef HAS_SETREGID
985213f2
AB
1139 (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1140 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
56febc5e
AD
1141# else
1142# ifdef HAS_SETRGID
b28d0864 1143 if ((PL_delaymagic & DM_GID) == DM_RGID) {
985213f2 1144 (void)setrgid(PL_delaymagic_gid);
b28d0864 1145 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1146 }
56febc5e
AD
1147# endif /* HAS_SETRGID */
1148# ifdef HAS_SETEGID
b28d0864 1149 if ((PL_delaymagic & DM_GID) == DM_EGID) {
985213f2 1150 (void)setegid(PL_delaymagic_egid);
b28d0864 1151 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1152 }
56febc5e 1153# endif /* HAS_SETEGID */
b28d0864 1154 if (PL_delaymagic & DM_GID) {
985213f2 1155 if (PL_delaymagic_gid != PL_delaymagic_egid)
cea2e8a9 1156 DIE(aTHX_ "No setregid available");
985213f2 1157 (void)PerlProc_setgid(PL_delaymagic_gid);
a0d0e21e 1158 }
56febc5e
AD
1159# endif /* HAS_SETREGID */
1160#endif /* HAS_SETRESGID */
985213f2
AB
1161 tmp_gid = PerlProc_getgid();
1162 tmp_egid = PerlProc_getegid();
a0d0e21e 1163 }
985213f2 1164 PL_tainting |= (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid));
a0d0e21e 1165 }
3280af22 1166 PL_delaymagic = 0;
54310121 1167
54310121
PP
1168 if (gimme == G_VOID)
1169 SP = firstrelem - 1;
1170 else if (gimme == G_SCALAR) {
1171 dTARGET;
1172 SP = firstrelem;
ca65944e 1173 SETi(lastrelem - firstrelem + 1 - duplicates);
54310121
PP
1174 }
1175 else {
ca65944e 1176 if (ary)
a0d0e21e 1177 SP = lastrelem;
ca65944e
RGS
1178 else if (hash) {
1179 if (duplicates) {
45960564
DM
1180 /* at this point we have removed the duplicate key/value
1181 * pairs from the stack, but the remaining values may be
1182 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1183 * the (a 2), but the stack now probably contains
1184 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1185 * obliterates the earlier key. So refresh all values. */
ca65944e 1186 lastrelem -= duplicates;
45960564
DM
1187 relem = firsthashrelem;
1188 while (relem < lastrelem) {
1189 HE *he;
1190 sv = *relem++;
1191 he = hv_fetch_ent(hash, sv, 0, 0);
1192 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1193 }
ca65944e
RGS
1194 }
1195 SP = lastrelem;
1196 }
a0d0e21e
LW
1197 else
1198 SP = firstrelem + (lastlelem - firstlelem);
0c8c7a05 1199 lelem = firstlelem + (relem - firstrelem);
5f05dabc 1200 while (relem <= SP)
3280af22 1201 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
a0d0e21e 1202 }
08aeb9f7 1203
54310121 1204 RETURN;
a0d0e21e
LW
1205}
1206
8782bef2
GB
1207PP(pp_qr)
1208{
97aff369 1209 dVAR; dSP;
c4420975 1210 register PMOP * const pm = cPMOP;
fe578d7f 1211 REGEXP * rx = PM_GETRE(pm);
10599a69 1212 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
c4420975 1213 SV * const rv = sv_newmortal();
288b8c02
NC
1214
1215 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
1216 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1217 loathe to use it here, but it seems to be the right fix. Or close.
1218 The key part appears to be that it's essential for pp_qr to return a new
1219 object (SV), which implies that there needs to be an effective way to
1220 generate a new SV from the existing SV that is pre-compiled in the
1221 optree. */
1222 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
1223 SvROK_on(rv);
1224
1225 if (pkg) {
f815daf2 1226 HV *const stash = gv_stashsv(pkg, GV_ADD);
a954f6ee 1227 SvREFCNT_dec(pkg);
288b8c02
NC
1228 (void)sv_bless(rv, stash);
1229 }
1230
9274aefd 1231 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
e08e52cf 1232 SvTAINTED_on(rv);
9274aefd
DM
1233 SvTAINTED_on(SvRV(rv));
1234 }
c8c13c22 1235 XPUSHs(rv);
1236 RETURN;
8782bef2
GB
1237}
1238
a0d0e21e
LW
1239PP(pp_match)
1240{
97aff369 1241 dVAR; dSP; dTARG;
a0d0e21e 1242 register PMOP *pm = cPMOP;
d65afb4b 1243 PMOP *dynpm = pm;
0d46e09a
SP
1244 register const char *t;
1245 register const char *s;
5c144d81 1246 const char *strend;
a0d0e21e 1247 I32 global;
1ed74d04 1248 U8 r_flags = REXEC_CHECKED;
5c144d81 1249 const char *truebase; /* Start of string */
aaa362c4 1250 register REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1251 bool rxtainted;
a3b680e6 1252 const I32 gimme = GIMME;
a0d0e21e 1253 STRLEN len;
748a9306 1254 I32 minmatch = 0;
a3b680e6 1255 const I32 oldsave = PL_savestack_ix;
f86702cc 1256 I32 update_minmatch = 1;
e60df1fa 1257 I32 had_zerolen = 0;
58e23c8d 1258 U32 gpos = 0;
a0d0e21e 1259
533c011a 1260 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1261 TARG = POPs;
59f00321
RGS
1262 else if (PL_op->op_private & OPpTARGET_MY)
1263 GETTARGET;
a0d0e21e 1264 else {
54b9620d 1265 TARG = DEFSV;
a0d0e21e
LW
1266 EXTEND(SP,1);
1267 }
d9f424b2 1268
c277df42 1269 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
1270 /* Skip get-magic if this is a qr// clone, because regcomp has
1271 already done it. */
1272 s = ((struct regexp *)SvANY(rx))->mother_re
1273 ? SvPV_nomg_const(TARG, len)
1274 : SvPV_const(TARG, len);
a0d0e21e 1275 if (!s)
2269b42e 1276 DIE(aTHX_ "panic: pp_match");
890ce7af 1277 strend = s + len;
07bc277f 1278 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
3280af22 1279 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1280 TAINT_NOT;
a0d0e21e 1281
a30b2f1f 1282 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 1283
d65afb4b 1284 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
1285 if (
1286#ifdef USE_ITHREADS
1287 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1288#else
1289 pm->op_pmflags & PMf_USED
1290#endif
1291 ) {
c277df42 1292 failure:
a0d0e21e
LW
1293 if (gimme == G_ARRAY)
1294 RETURN;
1295 RETPUSHNO;
1296 }
1297
c737faaf
YO
1298
1299
d65afb4b 1300 /* empty pattern special-cased to use last successful pattern if possible */
220fc49f 1301 if (!RX_PRELEN(rx) && PL_curpm) {
3280af22 1302 pm = PL_curpm;
aaa362c4 1303 rx = PM_GETRE(pm);
a0d0e21e 1304 }
d65afb4b 1305
07bc277f 1306 if (RX_MINLEN(rx) > (I32)len)
d65afb4b 1307 goto failure;
c277df42 1308
a0d0e21e 1309 truebase = t = s;
ad94a511
IZ
1310
1311 /* XXXX What part of this is needed with true \G-support? */
d65afb4b 1312 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
07bc277f 1313 RX_OFFS(rx)[0].start = -1;
a0d0e21e 1314 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
c445ea15 1315 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
565764a8 1316 if (mg && mg->mg_len >= 0) {
07bc277f
NC
1317 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1318 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1319 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
0ef3e39e 1320 r_flags |= REXEC_IGNOREPOS;
07bc277f
NC
1321 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1322 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
58e23c8d
YO
1323 gpos = mg->mg_len;
1324 else
07bc277f
NC
1325 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1326 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
f86702cc 1327 update_minmatch = 0;
748a9306 1328 }
a0d0e21e
LW
1329 }
1330 }
a229a030 1331 /* XXX: comment out !global get safe $1 vars after a
62e7980d 1332 match, BUT be aware that this leads to dramatic slowdowns on
a229a030
YO
1333 /g matches against large strings. So far a solution to this problem
1334 appears to be quite tricky.
1335 Test for the unsafe vars are TODO for now. */
0d8a731b
DM
1336 if ( (!global && RX_NPARENS(rx))
1337 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1338 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
14977893 1339 r_flags |= REXEC_COPY_STR;
1c846c1f 1340 if (SvSCREAM(TARG))
22e551b9
IZ
1341 r_flags |= REXEC_SCREAM;
1342
d7be1480 1343 play_it_again:
07bc277f
NC
1344 if (global && RX_OFFS(rx)[0].start != -1) {
1345 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1346 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
a0d0e21e 1347 goto nope;
f86702cc 1348 if (update_minmatch++)
e60df1fa 1349 minmatch = had_zerolen;
a0d0e21e 1350 }
07bc277f 1351 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
3c8556c3 1352 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
5c144d81
NC
1353 /* FIXME - can PL_bostr be made const char *? */
1354 PL_bostr = (char *)truebase;
f9f4320a 1355 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
f722798b
IZ
1356
1357 if (!s)
1358 goto nope;
07bc277f 1359 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
14977893 1360 && !PL_sawampersand
07bc277f
NC
1361 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1362 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1363 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
05b4157f
GS
1364 && (r_flags & REXEC_SCREAM)))
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 }
07bc277f 1530 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
cde0cee5 1531 -dmq */
07bc277f 1532 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
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)
9014280d 1610 Perl_warner(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;
f722798b 2146 if (SvSCREAM(TARG))
22e551b9 2147 r_flags |= REXEC_SCREAM;
7fba1cd6 2148
a0d0e21e 2149 orig = m = s;
07bc277f 2150 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
ee0b7718 2151 PL_bostr = orig;
f9f4320a 2152 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
f722798b
IZ
2153
2154 if (!s)
df34c13a 2155 goto ret_no;
f722798b 2156 /* How to do it in subst? */
07bc277f 2157/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1c846c1f 2158 && !PL_sawampersand
07bc277f
NC
2159 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2160 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2161 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
f722798b
IZ
2162 && (r_flags & REXEC_SCREAM))))
2163 goto yup;
2164*/
a0d0e21e 2165 }
71be2cbc 2166
8b64c330
DM
2167 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2168 r_flags | REXEC_CHECKED))
2169 {
5e79dfb9
DM
2170 ret_no:
2171 SPAGAIN;
2172 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2173 LEAVE_SCOPE(oldsave);
2174 RETURN;
2175 }
2176
71be2cbc 2177 /* known replacement string? */
f272994b 2178 if (dstr) {
20be6587
DM
2179 if (SvTAINTED(dstr))
2180 rxtainted |= SUBST_TAINT_REPL;
3e462cdc
KW
2181
2182 /* Upgrade the source if the replacement is utf8 but the source is not,
2183 * but only if it matched; see
2184 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2185 */
5e79dfb9 2186 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
c95ca9b8
DM
2187 char * const orig_pvx = SvPVX(TARG);
2188 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
3e462cdc
KW
2189
2190 /* If the lengths are the same, the pattern contains only
2191 * invariants, can keep going; otherwise, various internal markers
2192 * could be off, so redo */
c95ca9b8 2193 if (new_len != len || orig_pvx != SvPVX(TARG)) {
3e462cdc
KW
2194 goto setup_match;
2195 }
2196 }
2197
8514a05a
JH
2198 /* replacement needing upgrading? */
2199 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2200 nsv = sv_newmortal();
4a176938 2201 SvSetSV(nsv, dstr);
8514a05a
JH
2202 if (PL_encoding)
2203 sv_recode_to_utf8(nsv, PL_encoding);
2204 else
2205 sv_utf8_upgrade(nsv);
5c144d81 2206 c = SvPV_const(nsv, clen);
4a176938
JH
2207 doutf8 = TRUE;
2208 }
2209 else {
5c144d81 2210 c = SvPV_const(dstr, clen);
4a176938 2211 doutf8 = DO_UTF8(dstr);
8514a05a 2212 }
f272994b
A
2213 }
2214 else {
6136c704 2215 c = NULL;
f272994b
A
2216 doutf8 = FALSE;
2217 }
2218
71be2cbc 2219 /* can do inplace substitution? */
ed252734 2220 if (c
f8c7b90f 2221#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2222 && !is_cow
2223#endif
07bc277f
NC
2224 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2225 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
8ca8a454
NC
2226 && (!doutf8 || SvUTF8(TARG))
2227 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
8b030b38 2228 {
ec911639 2229
f8c7b90f 2230#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2231 if (SvIsCOW(TARG)) {
2232 assert (!force_on_match);
2233 goto have_a_cow;
2234 }
2235#endif
71be2cbc
PP
2236 if (force_on_match) {
2237 force_on_match = 0;
2238 s = SvPV_force(TARG, len);
2239 goto force_it;
2240 }
71be2cbc 2241 d = s;
3280af22 2242 PL_curpm = pm;
71be2cbc
PP
2243 SvSCREAM_off(TARG); /* disable possible screamer */
2244 if (once) {
20be6587
DM
2245 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2246 rxtainted |= SUBST_TAINT_PAT;
07bc277f
NC
2247 m = orig + RX_OFFS(rx)[0].start;
2248 d = orig + RX_OFFS(rx)[0].end;
71be2cbc
PP
2249 s = orig;
2250 if (m - s > strend - d) { /* faster to shorten from end */
2251 if (clen) {
2252 Copy(c, m, clen, char);
2253 m += clen;
a0d0e21e 2254 }
71be2cbc
PP
2255 i = strend - d;
2256 if (i > 0) {
2257 Move(d, m, i, char);
2258 m += i;
a0d0e21e 2259 }
71be2cbc
PP
2260 *m = '\0';
2261 SvCUR_set(TARG, m - s);
2262 }
155aba94 2263 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
2264 d -= clen;
2265 m = d;
0d3c21b0 2266 Move(s, d - i, i, char);
71be2cbc 2267 sv_chop(TARG, d-i);
71be2cbc
PP
2268 if (clen)
2269 Copy(c, m, clen, char);
2270 }
2271 else if (clen) {
2272 d -= clen;
2273 sv_chop(TARG, d);
2274 Copy(c, d, clen, char);
2275 }
2276 else {
2277 sv_chop(TARG, d);
2278 }
8ec5e241 2279 SPAGAIN;
8ca8a454 2280 PUSHs(&PL_sv_yes);
71be2cbc
PP
2281 }
2282 else {
71be2cbc
PP
2283 do {
2284 if (iters++ > maxiters)
cea2e8a9 2285 DIE(aTHX_ "Substitution loop");
20be6587
DM
2286 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2287 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2288 m = RX_OFFS(rx)[0].start + orig;
155aba94 2289 if ((i = m - s)) {
71be2cbc
PP
2290 if (s != d)
2291 Move(s, d, i, char);
2292 d += i;
a0d0e21e 2293 }
71be2cbc
PP
2294 if (clen) {
2295 Copy(c, d, clen, char);
2296 d += clen;
2297 }
07bc277f 2298 s = RX_OFFS(rx)[0].end + orig;
f9f4320a 2299 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
f722798b
IZ
2300 TARG, NULL,
2301 /* don't match same null twice */
2302 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
2303 if (s != d) {
2304 i = strend - s;
aa07b2f6 2305 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 2306 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2307 }
8ec5e241 2308 SPAGAIN;
8ca8a454 2309 mPUSHi((I32)iters);
a0d0e21e
LW
2310 }
2311 }
ff6e92e8 2312 else {
a0d0e21e
LW
2313 if (force_on_match) {
2314 force_on_match = 0;
0c1438a1
NC
2315 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2316 /* I feel that it should be possible to avoid this mortal copy
2317 given that the code below copies into a new destination.
2318 However, I suspect it isn't worth the complexity of
2319 unravelling the C<goto force_it> for the small number of
2320 cases where it would be viable to drop into the copy code. */
2321 TARG = sv_2mortal(newSVsv(TARG));
2322 }
a0d0e21e
LW
2323 s = SvPV_force(TARG, len);
2324 goto force_it;
2325 }
f8c7b90f 2326#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2327 have_a_cow:
2328#endif
20be6587
DM
2329 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2330 rxtainted |= SUBST_TAINT_PAT;
815dd406 2331 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3280af22 2332 PL_curpm = pm;
a0d0e21e 2333 if (!c) {
c09156bb 2334 register PERL_CONTEXT *cx;
8ec5e241 2335 SPAGAIN;
20be6587
DM
2336 /* note that a whole bunch of local vars are saved here for
2337 * use by pp_substcont: here's a list of them in case you're
2338 * searching for places in this sub that uses a particular var:
2339 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2340 * s m strend rx once */
a0d0e21e 2341 PUSHSUBST(cx);
20e98b0f 2342 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
a0d0e21e 2343 }
cf93c79d 2344 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2345 do {
2346 if (iters++ > maxiters)
cea2e8a9 2347 DIE(aTHX_ "Substitution loop");
20be6587
DM
2348 if (RX_MATCH_TAINTED(rx))
2349 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2350 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
a0d0e21e
LW
2351 m = s;
2352 s = orig;
07bc277f 2353 orig = RX_SUBBEG(rx);
a0d0e21e
LW
2354 s = orig + (m - s);
2355 strend = s + (strend - m);
2356 }
07bc277f 2357 m = RX_OFFS(rx)[0].start + orig;
db79b45b
JH
2358 if (doutf8 && !SvUTF8(dstr))
2359 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2360 else
2361 sv_catpvn(dstr, s, m-s);
07bc277f 2362 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e
LW
2363 if (clen)
2364 sv_catpvn(dstr, c, clen);
2365 if (once)
2366 break;
f9f4320a 2367 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
ffc61ed2 2368 TARG, NULL, r_flags));
db79b45b
JH
2369 if (doutf8 && !DO_UTF8(TARG))
2370 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
89afcb60
A
2371 else
2372 sv_catpvn(dstr, s, strend - s);
748a9306 2373
8ca8a454
NC
2374 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2375 /* From here on down we're using the copy, and leaving the original
2376 untouched. */
2377 TARG = dstr;
2378 SPAGAIN;
2379 PUSHs(dstr);
2380 } else {
f8c7b90f 2381#ifdef PERL_OLD_COPY_ON_WRITE
8ca8a454
NC
2382 /* The match may make the string COW. If so, brilliant, because
2383 that's just saved us one malloc, copy and free - the regexp has
2384 donated the old buffer, and we malloc an entirely new one, rather
2385 than the regexp malloc()ing a buffer and copying our original,
2386 only for us to throw it away here during the substitution. */
2387 if (SvIsCOW(TARG)) {
2388 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2389 } else
ed252734 2390#endif
8ca8a454
NC
2391 {
2392 SvPV_free(TARG);
2393 }
2394 SvPV_set(TARG, SvPVX(dstr));
2395 SvCUR_set(TARG, SvCUR(dstr));
2396 SvLEN_set(TARG, SvLEN(dstr));
2397 doutf8 |= DO_UTF8(dstr);
2398 SvPV_set(dstr, NULL);
748a9306 2399
8ca8a454 2400 SPAGAIN;
4f4d7508 2401 mPUSHi((I32)iters);
8ca8a454
NC
2402 }
2403 }
2404
2405 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2406 (void)SvPOK_only_UTF8(TARG);
2407 if (doutf8)
2408 SvUTF8_on(TARG);
a0d0e21e 2409 }
20be6587 2410
ef07e810 2411 /* See "how taint works" above */
20be6587
DM
2412 if (PL_tainting) {
2413 if ((rxtainted & SUBST_TAINT_PAT) ||
2414 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2415 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2416 )
2417 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2418
2419 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2420 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2421 )
2422 SvTAINTED_on(TOPs); /* taint return value */
2423 else
2424 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2425
2426 /* needed for mg_set below */
2427 PL_tainted =
2428 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2429 SvTAINT(TARG);
2430 }
2431 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2432 TAINT_NOT;
f1a76097
DM
2433 LEAVE_SCOPE(oldsave);
2434 RETURN;
a0d0e21e
LW
2435}
2436
2437PP(pp_grepwhile)
2438{
27da23d5 2439 dVAR; dSP;
a0d0e21e
LW
2440
2441 if (SvTRUEx(POPs))
3280af22
NIS
2442 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2443 ++*PL_markstack_ptr;
b2a2a901 2444 FREETMPS;
d343c3ef 2445 LEAVE_with_name("grep_item"); /* exit inner scope */
a0d0e21e
LW
2446
2447 /* All done yet? */
3280af22 2448 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2449 I32 items;
c4420975 2450 const I32 gimme = GIMME_V;
a0d0e21e 2451
d343c3ef 2452 LEAVE_with_name("grep"); /* exit outer scope */
a0d0e21e 2453 (void)POPMARK; /* pop src */
3280af22 2454 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2455 (void)POPMARK; /* pop dst */
3280af22 2456 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2457 if (gimme == G_SCALAR) {
7cc47870 2458 if (PL_op->op_private & OPpGREP_LEX) {
c4420975 2459 SV* const sv = sv_newmortal();
7cc47870
RGS
2460 sv_setiv(sv, items);
2461 PUSHs(sv);
2462 }
2463 else {
2464 dTARGET;
2465 XPUSHi(items);
2466 }
a0d0e21e 2467 }
54310121
PP
2468 else if (gimme == G_ARRAY)
2469 SP += items;
a0d0e21e
LW
2470 RETURN;
2471 }
2472 else {
2473 SV *src;
2474
d343c3ef 2475 ENTER_with_name("grep_item"); /* enter inner scope */
1d7c1841 2476 SAVEVPTR(PL_curpm);
a0d0e21e 2477
3280af22 2478 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2479 SvTEMP_off(src);
59f00321
RGS
2480 if (PL_op->op_private & OPpGREP_LEX)
2481 PAD_SVl(PL_op->op_targ) = src;
2482 else
414bf5ae 2483 DEFSV_set(src);
a0d0e21e
LW
2484
2485 RETURNOP(cLOGOP->op_other);
2486 }
2487}
2488
2489PP(pp_leavesub)
2490{
27da23d5 2491 dVAR; dSP;
a0d0e21e
LW
2492 SV **mark;
2493 SV **newsp;
2494 PMOP *newpm;
2495 I32 gimme;
c09156bb 2496 register PERL_CONTEXT *cx;
b0d9ce38 2497 SV *sv;
a0d0e21e 2498
9850bf21
RH
2499 if (CxMULTICALL(&cxstack[cxstack_ix]))
2500 return 0;
2501
a0d0e21e 2502 POPBLOCK(cx,newpm);
5dd42e15 2503 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2504
a1f49e72 2505 TAINT_NOT;
a0d0e21e
LW
2506 if (gimme == G_SCALAR) {
2507 MARK = newsp + 1;
a29cdaf0 2508 if (MARK <= SP) {
a8bba7fa 2509 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
6f48390a
FC
2510 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2511 && !SvMAGICAL(TOPs)) {
a29cdaf0
IZ
2512 *MARK = SvREFCNT_inc(TOPs);
2513 FREETMPS;
2514 sv_2mortal(*MARK);
cd06dffe
GS
2515 }
2516 else {
959e3673 2517 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2518 FREETMPS;
959e3673
GS
2519 *MARK = sv_mortalcopy(sv);
2520 SvREFCNT_dec(sv);
a29cdaf0 2521 }
cd06dffe 2522 }
6f48390a
FC
2523 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2524 && !SvMAGICAL(TOPs)) {
767eda44 2525 *MARK = TOPs;
767eda44 2526 }
cd06dffe 2527 else
767eda44 2528 *MARK = sv_mortalcopy(TOPs);
cd06dffe
GS
2529 }
2530 else {
f86702cc 2531 MEXTEND(MARK, 0);
3280af22 2532 *MARK = &PL_sv_undef;
a0d0e21e
LW
2533 }
2534 SP = MARK;
2535 }
54310121 2536 else if (gimme == G_ARRAY) {
f86702cc 2537 for (MARK = newsp + 1; MARK <= SP; MARK++) {
6f48390a
FC
2538 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2539 || SvMAGICAL(*MARK)) {
f86702cc 2540 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2541 TAINT_NOT; /* Each item is independent */
2542 }
f86702cc 2543 }
a0d0e21e 2544 }
f86702cc 2545 PUTBACK;
1c846c1f 2546
a57c6685 2547 LEAVE;
5dd42e15 2548 cxstack_ix--;
b0d9ce38 2549 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2550 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2551
b0d9ce38 2552 LEAVESUB(sv);
f39bc417 2553 return cx->blk_sub.retop;
a0d0e21e
LW
2554}
2555
2556PP(pp_entersub)
2557{
27da23d5 2558 dVAR; dSP; dPOPss;
a0d0e21e 2559 GV *gv;
a0d0e21e 2560 register CV *cv;
c09156bb 2561 register PERL_CONTEXT *cx;
5d94fbed 2562 I32 gimme;
a9c4fd4e 2563 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2564
2565 if (!sv)
cea2e8a9 2566 DIE(aTHX_ "Not a CODE reference");
a0d0e21e 2567 switch (SvTYPE(sv)) {
f1025168
NC
2568 /* This is overwhelming the most common case: */
2569 case SVt_PVGV:
13be902c 2570 we_have_a_glob:
159b6efe 2571 if (!(cv = GvCVu((const GV *)sv))) {
f730a42d 2572 HV *stash;
f2c0649b 2573 cv = sv_2cv(sv, &stash, &gv, 0);
f730a42d 2574 }
f1025168 2575 if (!cv) {
a57c6685 2576 ENTER;
f1025168
NC
2577 SAVETMPS;
2578 goto try_autoload;
2579 }
2580 break;
13be902c
FC
2581 case SVt_PVLV:
2582 if(isGV_with_GP(sv)) goto we_have_a_glob;
2583 /*FALLTHROUGH*/
a0d0e21e 2584 default:
7c75014e
DM
2585 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2586 if (hasargs)
2587 SP = PL_stack_base + POPMARK;
4d198de3
DM
2588 else
2589 (void)POPMARK;
7c75014e
DM
2590 RETURN;
2591 }
2592 SvGETMAGIC(sv);
2593 if (SvROK(sv)) {
93d7320b
DM
2594 if (SvAMAGIC(sv)) {
2595 sv = amagic_deref_call(sv, to_cv_amg);
2596 /* Don't SPAGAIN here. */
2597 }
7c75014e
DM
2598 }
2599 else {
a9c4fd4e 2600 const char *sym;
780a5241 2601 STRLEN len;
7c75014e 2602 sym = SvPV_nomg_const(sv, len);
15ff848f 2603 if (!sym)
cea2e8a9 2604 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2605 if (PL_op->op_private & HINT_STRICT_REFS)
b375e37b 2606 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
780a5241 2607 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
a0d0e21e
LW
2608 break;
2609 }
ea726b52 2610 cv = MUTABLE_CV(SvRV(sv));
a0d0e21e
LW
2611 if (SvTYPE(cv) == SVt_PVCV)
2612 break;
2613 /* FALL THROUGH */
2614 case SVt_PVHV:
2615 case SVt_PVAV:
cea2e8a9 2616 DIE(aTHX_ "Not a CODE reference");
f1025168 2617 /* This is the second most common case: */
a0d0e21e 2618 case SVt_PVCV:
ea726b52 2619 cv = MUTABLE_CV(sv);
a0d0e21e 2620 break;
a0d0e21e
LW
2621 }
2622
a57c6685 2623 ENTER;
a0d0e21e
LW
2624 SAVETMPS;
2625
2626 retry:
541ed3a9
FC
2627 if (CvCLONE(cv) && ! CvCLONED(cv))
2628 DIE(aTHX_ "Closure prototype called");
a0d0e21e 2629 if (!CvROOT(cv) && !CvXSUB(cv)) {
2f349aa0
NC
2630 GV* autogv;
2631 SV* sub_name;
2632
2633 /* anonymous or undef'd function leaves us no recourse */
2634 if (CvANON(cv) || !(gv = CvGV(cv)))
2635 DIE(aTHX_ "Undefined subroutine called");
2636
2637 /* autoloaded stub? */
2638 if (cv != GvCV(gv)) {
2639 cv = GvCV(gv);
2640 }
2641 /* should call AUTOLOAD now? */
2642 else {
7e623da3 2643try_autoload:
d1089224
BF
2644 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2645 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2f349aa0
NC
2646 {
2647 cv = GvCV(autogv);
2648 }
2649 /* sorry */
2650 else {
2651 sub_name = sv_newmortal();
6136c704 2652 gv_efullname3(sub_name, gv, NULL);
be2597df 2653 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2f349aa0
NC
2654 }
2655 }
2656 if (!cv)
2657 DIE(aTHX_ "Not a CODE reference");
2658 goto retry;
a0d0e21e
LW
2659 }
2660
54310121 2661 gimme = GIMME_V;
67caa1fe 2662 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
005a8a35 2663 Perl_get_db_sub(aTHX_ &sv, cv);
a9ef256d
NC
2664 if (CvISXSUB(cv))
2665 PL_curcopdb = PL_curcop;
1ad62f64 2666 if (CvLVALUE(cv)) {
2667 /* check for lsub that handles lvalue subroutines */
ae5c1e95 2668 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
1ad62f64 2669 /* if lsub not found then fall back to DB::sub */
2670 if (!cv) cv = GvCV(PL_DBsub);
2671 } else {
2672 cv = GvCV(PL_DBsub);
2673 }
a9ef256d 2674
ccafdc96
RGS
2675 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2676 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2677 }
a0d0e21e 2678
aed2304a 2679 if (!(CvISXSUB(cv))) {
f1025168 2680 /* This path taken at least 75% of the time */
a0d0e21e
LW
2681 dMARK;
2682 register I32 items = SP - MARK;
0bcc34c2 2683 AV* const padlist = CvPADLIST(cv);
a0d0e21e
LW
2684 PUSHBLOCK(cx, CXt_SUB, MARK);
2685 PUSHSUB(cx);
f39bc417 2686 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 2687 CvDEPTH(cv)++;
6b35e009
GS
2688 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2689 * that eval'' ops within this sub know the correct lexical space.
a3985cdc
DM
2690 * Owing the speed considerations, we choose instead to search for
2691 * the cv using find_runcv() when calling doeval().
6b35e009 2692 */
3a76ca88
RGS
2693 if (CvDEPTH(cv) >= 2) {
2694 PERL_STACK_OVERFLOW_CHECK();
2695 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2696 }
3a76ca88
RGS
2697 SAVECOMPPAD();
2698 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2699 if (hasargs) {
10533ace 2700 AV *const av = MUTABLE_AV(PAD_SVl(0));
221373f0
GS
2701 if (AvREAL(av)) {
2702 /* @_ is normally not REAL--this should only ever
2703 * happen when DB::sub() calls things that modify @_ */
2704 av_clear(av);
2705 AvREAL_off(av);
2706 AvREIFY_on(av);
2707 }
3280af22 2708 cx->blk_sub.savearray = GvAV(PL_defgv);
502c6561 2709 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
dd2155a4 2710 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2711 cx->blk_sub.argarray = av;
a0d0e21e
LW
2712 ++MARK;
2713
2714 if (items > AvMAX(av) + 1) {
504618e9 2715 SV **ary = AvALLOC(av);
a0d0e21e
LW
2716 if (AvARRAY(av) != ary) {
2717 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 2718 AvARRAY(av) = ary;
a0d0e21e
LW
2719 }
2720 if (items > AvMAX(av) + 1) {
2721 AvMAX(av) = items - 1;
2722 Renew(ary,items,SV*);
2723 AvALLOC(av) = ary;
9c6bc640 2724 AvARRAY(av) = ary;
a0d0e21e
LW
2725 }
2726 }
2727 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2728 AvFILLp(av) = items - 1;
1c846c1f 2729
a0d0e21e
LW
2730 while (items--) {
2731 if (*MARK)
2732 SvTEMP_off(*MARK);
2733 MARK++;
2734 }
2735 }
da1dff94
FC
2736 if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2737 !CvLVALUE(cv))
2738 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
4a925ff6
GS
2739 /* warning must come *after* we fully set up the context
2740 * stuff so that __WARN__ handlers can safely dounwind()
2741 * if they want to
2742 */
2b9dff67 2743 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
4a925ff6
GS
2744 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2745 sub_crush_depth(cv);
a0d0e21e
LW
2746 RETURNOP(CvSTART(cv));
2747 }
f1025168 2748 else {
3a76ca88 2749 I32 markix = TOPMARK;
f1025168 2750
3a76ca88 2751 PUTBACK;
f1025168 2752
3a76ca88
RGS
2753 if (!hasargs) {
2754 /* Need to copy @_ to stack. Alternative may be to
2755 * switch stack to @_, and copy return values
2756 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2757 AV * const av = GvAV(PL_defgv);
2758 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2759
2760 if (items) {
2761 /* Mark is at the end of the stack. */
2762 EXTEND(SP, items);
2763 Copy(AvARRAY(av), SP + 1, items, SV*);
2764 SP += items;
2765 PUTBACK ;
2766 }
2767 }
2768 /* We assume first XSUB in &DB::sub is the called one. */
2769 if (PL_curcopdb) {
2770 SAVEVPTR(PL_curcop);
2771 PL_curcop = PL_curcopdb;
2772 PL_curcopdb = NULL;
2773 }
2774 /* Do we need to open block here? XXXX */
72df79cf 2775
2776 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2777 assert(CvXSUB(cv));
16c91539 2778 CvXSUB(cv)(aTHX_ cv);
3a76ca88
RGS
2779
2780 /* Enforce some sanity in scalar context. */
2781 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2782 if (markix > PL_stack_sp - PL_stack_base)
2783 *(PL_stack_base + markix) = &PL_sv_undef;
2784 else
2785 *(PL_stack_base + markix) = *PL_stack_sp;
2786 PL_stack_sp = PL_stack_base + markix;
2787 }
a57c6685 2788 LEAVE;
f1025168
NC
2789 return NORMAL;
2790 }
a0d0e21e
LW
2791}
2792
44a8e56a 2793void
864dbfa3 2794Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 2795{
7918f24d
NC
2796 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2797
44a8e56a 2798 if (CvANON(cv))
9014280d 2799 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 2800 else {
aec46f14 2801 SV* const tmpstr = sv_newmortal();
6136c704 2802 gv_efullname3(tmpstr, CvGV(cv), NULL);
35c1215d 2803 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
be2597df 2804 SVfARG(tmpstr));
44a8e56a
PP
2805 }
2806}
2807
a0d0e21e
LW
2808PP(pp_aelem)
2809{
97aff369 2810 dVAR; dSP;
a0d0e21e 2811 SV** svp;
a3b680e6 2812 SV* const elemsv = POPs;
d804643f 2813 IV elem = SvIV(elemsv);
502c6561 2814 AV *const av = MUTABLE_AV(POPs);
e1ec3a88
AL
2815 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2816 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
4ad10a0b
VP
2817 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2818 bool preeminent = TRUE;
be6c24e0 2819 SV *sv;
a0d0e21e 2820
e35c1634 2821 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
95b63a38
JH
2822 Perl_warner(aTHX_ packWARN(WARN_MISC),
2823 "Use of reference \"%"SVf"\" as array index",
be2597df 2824 SVfARG(elemsv));
a0d0e21e
LW
2825 if (SvTYPE(av) != SVt_PVAV)
2826 RETPUSHUNDEF;
4ad10a0b
VP
2827
2828 if (localizing) {
2829 MAGIC *mg;
2830 HV *stash;
2831
2832 /* If we can determine whether the element exist,
2833 * Try to preserve the existenceness of a tied array
2834 * element by using EXISTS and DELETE if possible.
2835 * Fallback to FETCH and STORE otherwise. */
2836 if (SvCANEXISTDELETE(av))
2837 preeminent = av_exists(av, elem);
2838 }
2839
68dc0745 2840 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2841 if (lval) {
2b573ace 2842#ifdef PERL_MALLOC_WRAP
2b573ace 2843 if (SvUOK(elemsv)) {
a9c4fd4e 2844 const UV uv = SvUV(elemsv);
2b573ace
JH
2845 elem = uv > IV_MAX ? IV_MAX : uv;
2846 }
2847 else if (SvNOK(elemsv))
2848 elem = (IV)SvNV(elemsv);
a3b680e6
AL
2849 if (elem > 0) {
2850 static const char oom_array_extend[] =
2851 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 2852 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 2853 }
2b573ace 2854#endif
3280af22 2855 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2856 SV* lv;
2857 if (!defer)
cea2e8a9 2858 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2859 lv = sv_newmortal();
2860 sv_upgrade(lv, SVt_PVLV);
2861 LvTYPE(lv) = 'y';
a0714e2c 2862 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
b37c2d43 2863 LvTARG(lv) = SvREFCNT_inc_simple(av);
68dc0745
PP
2864 LvTARGOFF(lv) = elem;
2865 LvTARGLEN(lv) = 1;
2866 PUSHs(lv);
2867 RETURN;
2868 }
4ad10a0b
VP
2869 if (localizing) {
2870 if (preeminent)
2871 save_aelem(av, elem, svp);
2872 else
2873 SAVEADELETE(av, elem);
2874 }
9026059d
GG
2875 else if (PL_op->op_private & OPpDEREF) {
2876 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2877 RETURN;
2878 }
a0d0e21e 2879 }
3280af22 2880 sv = (svp ? *svp : &PL_sv_undef);
39cf747a 2881 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 2882 mg_get(sv);
be6c24e0 2883 PUSHs(sv);
a0d0e21e
LW
2884 RETURN;
2885}
2886
9026059d 2887SV*
864dbfa3 2888Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 2889{
7918f24d
NC
2890 PERL_ARGS_ASSERT_VIVIFY_REF;
2891
5b295bef 2892 SvGETMAGIC(sv);
02a9e968
CS
2893 if (!SvOK(sv)) {
2894 if (SvREADONLY(sv))
6ad8f254 2895 Perl_croak_no_modify(aTHX);
43230e26 2896 prepare_SV_for_RV(sv);
68dc0745 2897 switch (to_what) {
5f05dabc 2898 case OPpDEREF_SV:
561b68a9 2899 SvRV_set(sv, newSV(0));
5f05dabc
PP
2900 break;
2901 case OPpDEREF_AV:
ad64d0ec 2902 SvRV_set(sv, MUTABLE_SV(newAV()));
5f05dabc
PP
2903 break;
2904 case OPpDEREF_HV:
ad64d0ec 2905 SvRV_set(sv, MUTABLE_SV(newHV()));
5f05dabc
PP
2906 break;
2907 }
02a9e968
CS
2908 SvROK_on(sv);
2909 SvSETMAGIC(sv);
7e482323 2910 SvGETMAGIC(sv);
02a9e968 2911 }
9026059d
GG
2912 if (SvGMAGICAL(sv)) {
2913 /* copy the sv without magic to prevent magic from being
2914 executed twice */
2915 SV* msv = sv_newmortal();
2916 sv_setsv_nomg(msv, sv);
2917 return msv;
2918 }
2919 return sv;
02a9e968
CS
2920}
2921
a0d0e21e
LW
2922PP(pp_method)
2923{
97aff369 2924 dVAR; dSP;
890ce7af 2925 SV* const sv = TOPs;
f5d5a27c
CS
2926
2927 if (SvROK(sv)) {
890ce7af 2928 SV* const rsv = SvRV(sv);
f5d5a27c
CS
2929 if (SvTYPE(rsv) == SVt_PVCV) {
2930 SETs(rsv);
2931 RETURN;
2932 }
2933 }
2934
4608196e 2935 SETs(method_common(sv, NULL));
f5d5a27c
CS
2936 RETURN;
2937}
2938
2939PP(pp_method_named)
2940{
97aff369 2941 dVAR; dSP;
890ce7af 2942 SV* const sv = cSVOP_sv;
c158a4fd 2943 U32 hash = SvSHARED_HASH(sv);
f5d5a27c
CS
2944
2945 XPUSHs(method_common(sv, &hash));
2946 RETURN;
2947}
2948
2949STATIC SV *
2950S_method_common(pTHX_ SV* meth, U32* hashp)
2951{
97aff369 2952 dVAR;
a0d0e21e
LW
2953 SV* ob;
2954 GV* gv;
56304f61 2955 HV* stash;
a0714e2c 2956 SV *packsv = NULL;
46c461b5 2957 SV * const sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 2958
7918f24d
NC
2959 PERL_ARGS_ASSERT_METHOD_COMMON;
2960
4f1b7578 2961 if (!sv)
a214957f
VP
2962 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2963 SVfARG(meth));
4f1b7578 2964
5b295bef 2965 SvGETMAGIC(sv);
a0d0e21e 2966 if (SvROK(sv))
ad64d0ec 2967 ob = MUTABLE_SV(SvRV(sv));
a0d0e21e
LW
2968 else {
2969 GV* iogv;
f937af42
BF
2970 STRLEN packlen;
2971 const char * packname = NULL;
da6b625f 2972 bool packname_is_utf8 = FALSE;
a0d0e21e 2973
af09ea45 2974 /* this isn't a reference */
da6b625f
FC
2975 if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2976 const HE* const he =
2977 (const HE *)hv_common_key_len(
2978 PL_stashcache, packname,
2979 packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2980 );
2981
081fc587 2982 if (he) {
5e6396ae 2983 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
081fc587
AB
2984 goto fetch;
2985 }
2986 }
2987
a0d0e21e 2988 if (!SvOK(sv) ||
05f5af9a 2989 !(packname) ||
da6b625f
FC
2990 !(iogv = gv_fetchpvn_flags(
2991 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2992 )) ||
ad64d0ec 2993 !(ob=MUTABLE_SV(GvIO(iogv))))
a0d0e21e 2994 {
af09ea45 2995 /* this isn't the name of a filehandle either */
1c846c1f 2996 if (!packname ||
fd400ab9 2997 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 2998 ? !isIDFIRST_utf8((U8*)packname)
d47f310d 2999 : !isIDFIRST_L1((U8)*packname)
834a4ddd
LW
3000 ))
3001 {
d5e45555 3002 /* diag_listed_as: Can't call method "%s" without a package or object reference */
a214957f
VP
3003 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3004 SVfARG(meth),
f5d5a27c
CS
3005 SvOK(sv) ? "without a package or object reference"
3006 : "on an undefined value");
834a4ddd 3007 }
af09ea45 3008 /* assume it's a package name */
f937af42 3009 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
0dae17bd
GS
3010 if (!stash)
3011 packsv = sv;
081fc587 3012 else {
d4c19fe8 3013 SV* const ref = newSViv(PTR2IV(stash));
f937af42 3014 (void)hv_store(PL_stashcache, packname,
c60dbbc3 3015 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
7e8961ec 3016 }
ac91690f 3017 goto fetch;
a0d0e21e 3018 }
af09ea45 3019 /* it _is_ a filehandle name -- replace with a reference */
ad64d0ec 3020 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
a0d0e21e
LW
3021 }
3022
af09ea45 3023 /* if we got here, ob should be a reference or a glob */
f0d43078 3024 if (!ob || !(SvOBJECT(ob)
6e592b3a
BM
3025 || (SvTYPE(ob) == SVt_PVGV
3026 && isGV_with_GP(ob)
159b6efe 3027 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
f0d43078
GS
3028 && SvOBJECT(ob))))
3029 {
b375e37b
BF
3030 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3031 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3032 ? newSVpvs_flags("DOES", SVs_TEMP)
3033 : meth));
f0d43078 3034 }
a0d0e21e 3035
56304f61 3036 stash = SvSTASH(ob);
a0d0e21e 3037
ac91690f 3038 fetch:
af09ea45
IK
3039 /* NOTE: stash may be null, hope hv_fetch_ent and
3040 gv_fetchmethod can cope (it seems they can) */
3041
f5d5a27c
CS
3042 /* shortcut for simple names */
3043 if (hashp) {
b464bac0 3044 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
f5d5a27c 3045 if (he) {
159b6efe 3046 gv = MUTABLE_GV(HeVAL(he));
f5d5a27c 3047 if (isGV(gv) && GvCV(gv) &&
e1a479c5 3048 (!GvCVGEN(gv) || GvCVGEN(gv)
dd69841b 3049 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
ad64d0ec 3050 return MUTABLE_SV(GvCV(gv));
f5d5a27c
CS
3051 }
3052 }
3053
f937af42
BF
3054 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3055 meth, GV_AUTOLOAD | GV_CROAK);
9b9d0b15 3056
256d1bb2 3057 assert(gv);
9b9d0b15 3058
ad64d0ec 3059 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
a0d0e21e 3060}
241d1a3b
NC
3061
3062/*
3063 * Local variables:
3064 * c-indentation-style: bsd
3065 * c-basic-offset: 4
3066 * indent-tabs-mode: t
3067 * End:
3068 *
37442d52
RGS
3069 * ex: set ts=8 sts=4 sw=4 noet:
3070 */