This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In t/op/arith.t, tryeq_sloppy() wasn't correctly handling negative values.
[perl5.git] / pp_hot.c
CommitLineData
a0d0e21e
LW
1/* pp_hot.c
2 *
1129b882
NC
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
a0d0e21e
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
13 * shaking the air.
14 *
4ac71550
TC
15 * Awake! Awake! Fear, Fire, Foes! Awake!
16 * Fire, Foes! Awake!
17 *
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
a0d0e21e
LW
19 */
20
166f8a29
DM
21/* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
26 *
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
31 * performance.
32 */
33
a0d0e21e 34#include "EXTERN.h"
864dbfa3 35#define PERL_IN_PP_HOT_C
a0d0e21e
LW
36#include "perl.h"
37
38/* Hot code. */
39
40PP(pp_const)
41{
97aff369 42 dVAR;
39644a26 43 dSP;
996c9baa 44 XPUSHs(cSVOP_sv);
a0d0e21e
LW
45 RETURN;
46}
47
48PP(pp_nextstate)
49{
97aff369 50 dVAR;
533c011a 51 PL_curcop = (COP*)PL_op;
a0d0e21e 52 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 53 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 54 FREETMPS;
f410a211 55 PERL_ASYNC_CHECK();
a0d0e21e
LW
56 return NORMAL;
57}
58
59PP(pp_gvsv)
60{
97aff369 61 dVAR;
39644a26 62 dSP;
924508f0 63 EXTEND(SP,1);
533c011a 64 if (PL_op->op_private & OPpLVAL_INTRO)
1d7c1841 65 PUSHs(save_scalar(cGVOP_gv));
a0d0e21e 66 else
c69033f2 67 PUSHs(GvSVn(cGVOP_gv));
a0d0e21e
LW
68 RETURN;
69}
70
71PP(pp_null)
72{
97aff369 73 dVAR;
a0d0e21e
LW
74 return NORMAL;
75}
76
bf0571fd 77/* This is sometimes called directly by pp_coreargs. */
a0d0e21e
LW
78PP(pp_pushmark)
79{
97aff369 80 dVAR;
3280af22 81 PUSHMARK(PL_stack_sp);
a0d0e21e
LW
82 return NORMAL;
83}
84
85PP(pp_stringify)
86{
97aff369 87 dVAR; dSP; dTARGET;
6050d10e 88 sv_copypv(TARG,TOPs);
a0d0e21e
LW
89 SETTARG;
90 RETURN;
91}
92
93PP(pp_gv)
94{
97aff369 95 dVAR; dSP;
ad64d0ec 96 XPUSHs(MUTABLE_SV(cGVOP_gv));
a0d0e21e
LW
97 RETURN;
98}
99
100PP(pp_and)
101{
97aff369 102 dVAR; dSP;
f410a211 103 PERL_ASYNC_CHECK();
a0d0e21e
LW
104 if (!SvTRUE(TOPs))
105 RETURN;
106 else {
c960fc3b
SP
107 if (PL_op->op_type == OP_AND)
108 --SP;
a0d0e21e
LW
109 RETURNOP(cLOGOP->op_other);
110 }
111}
112
113PP(pp_sassign)
114{
97aff369 115 dVAR; dSP; dPOPTOPssrl;
748a9306 116
533c011a 117 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
0bd48802
AL
118 SV * const temp = left;
119 left = right; right = temp;
a0d0e21e 120 }
3280af22 121 if (PL_tainting && PL_tainted && !SvTAINTED(left))
a0d0e21e 122 TAINT_NOT;
e26df76a 123 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
6136c704 124 SV * const cv = SvRV(left);
e26df76a 125 const U32 cv_type = SvTYPE(cv);
13be902c 126 const bool is_gv = isGV_with_GP(right);
6136c704 127 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
e26df76a
NC
128
129 if (!got_coderef) {
130 assert(SvROK(cv));
131 }
132
ae6d515f 133 /* Can do the optimisation if right (LVALUE) is not a typeglob,
e26df76a
NC
134 left (RVALUE) is a reference to something, and we're in void
135 context. */
13be902c 136 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
e26df76a 137 /* Is the target symbol table currently empty? */
77cb3b01 138 GV * const gv = gv_fetchsv_nomg(right, GV_NOINIT, SVt_PVGV);
bb112e5a 139 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
e26df76a
NC
140 /* Good. Create a new proxy constant subroutine in the target.
141 The gv becomes a(nother) reference to the constant. */
142 SV *const value = SvRV(cv);
143
ad64d0ec 144 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
1ccdb730 145 SvPCS_IMPORTED_on(gv);
e26df76a 146 SvRV_set(gv, value);
b37c2d43 147 SvREFCNT_inc_simple_void(value);
e26df76a
NC
148 SETs(right);
149 RETURN;
150 }
151 }
152
153 /* Need to fix things up. */
13be902c 154 if (!is_gv) {
e26df76a 155 /* Need to fix GV. */
77cb3b01 156 right = MUTABLE_SV(gv_fetchsv_nomg(right,GV_ADD, SVt_PVGV));
e26df76a
NC
157 }
158
159 if (!got_coderef) {
160 /* We've been returned a constant rather than a full subroutine,
161 but they expect a subroutine reference to apply. */
53a42478 162 if (SvROK(cv)) {
d343c3ef 163 ENTER_with_name("sassign_coderef");
53a42478
NC
164 SvREFCNT_inc_void(SvRV(cv));
165 /* newCONSTSUB takes a reference count on the passed in SV
166 from us. We set the name to NULL, otherwise we get into
167 all sorts of fun as the reference to our new sub is
168 donated to the GV that we're about to assign to.
169 */
ad64d0ec
NC
170 SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
171 SvRV(cv))));
53a42478 172 SvREFCNT_dec(cv);
d343c3ef 173 LEAVE_with_name("sassign_coderef");
53a42478
NC
174 } else {
175 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
176 is that
177 First: ops for \&{"BONK"}; return us the constant in the
178 symbol table
179 Second: ops for *{"BONK"} cause that symbol table entry
180 (and our reference to it) to be upgraded from RV
181 to typeblob)
182 Thirdly: We get here. cv is actually PVGV now, and its
183 GvCV() is actually the subroutine we're looking for
184
185 So change the reference so that it points to the subroutine
186 of that typeglob, as that's what they were after all along.
187 */
159b6efe 188 GV *const upgraded = MUTABLE_GV(cv);
53a42478
NC
189 CV *const source = GvCV(upgraded);
190
191 assert(source);
192 assert(CvFLAGS(source) & CVf_CONST);
193
194 SvREFCNT_inc_void(source);
195 SvREFCNT_dec(upgraded);
ad64d0ec 196 SvRV_set(left, MUTABLE_SV(source));
53a42478 197 }
e26df76a 198 }
53a42478 199
e26df76a 200 }
8fe85e3f
FC
201 if (
202 SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 &&
203 (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC)
204 )
205 Perl_warner(aTHX_
206 packWARN(WARN_MISC), "Useless assignment to a temporary"
207 );
54310121 208 SvSetMagicSV(right, left);
a0d0e21e
LW
209 SETs(right);
210 RETURN;
211}
212
213PP(pp_cond_expr)
214{
97aff369 215 dVAR; dSP;
f410a211 216 PERL_ASYNC_CHECK();
a0d0e21e 217 if (SvTRUEx(POPs))
1a67a97c 218 RETURNOP(cLOGOP->op_other);
a0d0e21e 219 else
1a67a97c 220 RETURNOP(cLOGOP->op_next);
a0d0e21e
LW
221}
222
223PP(pp_unstack)
224{
97aff369 225 dVAR;
8f3964af 226 PERL_ASYNC_CHECK();
a0d0e21e 227 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 228 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 229 FREETMPS;
eae48c89
Z
230 if (!(PL_op->op_flags & OPf_SPECIAL)) {
231 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
232 LEAVE_SCOPE(oldsave);
233 }
a0d0e21e
LW
234 return NORMAL;
235}
236
a0d0e21e
LW
237PP(pp_concat)
238{
6f1401dc 239 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
748a9306
LW
240 {
241 dPOPTOPssrl;
8d6d96c1
HS
242 bool lbyte;
243 STRLEN rlen;
d4c19fe8 244 const char *rpv = NULL;
a6b599c7 245 bool rbyte = FALSE;
a9c4fd4e 246 bool rcopied = FALSE;
8d6d96c1 247
6f1401dc
DM
248 if (TARG == right && right != left) { /* $r = $l.$r */
249 rpv = SvPV_nomg_const(right, rlen);
c75ab21a 250 rbyte = !DO_UTF8(right);
59cd0e26 251 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
349d4f2f 252 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
db79b45b 253 rcopied = TRUE;
8d6d96c1 254 }
7889fe52 255
89734059 256 if (TARG != left) { /* not $l .= $r */
a9c4fd4e 257 STRLEN llen;
6f1401dc 258 const char* const lpv = SvPV_nomg_const(left, llen);
90f5826e 259 lbyte = !DO_UTF8(left);
8d6d96c1
HS
260 sv_setpvn(TARG, lpv, llen);
261 if (!lbyte)
262 SvUTF8_on(TARG);
263 else
264 SvUTF8_off(TARG);
265 }
89734059 266 else { /* $l .= $r */
c75ab21a 267 if (!SvOK(TARG)) {
89734059 268 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
c75ab21a 269 report_uninit(right);
76f68e9b 270 sv_setpvs(left, "");
c75ab21a 271 }
c5aa2872
DM
272 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
273 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
90f5826e
ST
274 if (IN_BYTES)
275 SvUTF8_off(TARG);
8d6d96c1 276 }
a12c0f56 277
c75ab21a 278 if (!rcopied) {
6f1401dc 279 if (left == right)
89734059 280 /* $r.$r: do magic twice: tied might return different 2nd time */
6f1401dc
DM
281 SvGETMAGIC(right);
282 rpv = SvPV_nomg_const(right, rlen);
c75ab21a
RH
283 rbyte = !DO_UTF8(right);
284 }
8d6d96c1 285 if (lbyte != rbyte) {
e3393f51
NT
286 /* sv_utf8_upgrade_nomg() may reallocate the stack */
287 PUTBACK;
8d6d96c1
HS
288 if (lbyte)
289 sv_utf8_upgrade_nomg(TARG);
290 else {
db79b45b 291 if (!rcopied)
59cd0e26 292 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
8d6d96c1 293 sv_utf8_upgrade_nomg(right);
6f1401dc 294 rpv = SvPV_nomg_const(right, rlen);
69b47968 295 }
e3393f51 296 SPAGAIN;
a0d0e21e 297 }
8d6d96c1 298 sv_catpvn_nomg(TARG, rpv, rlen);
43ebc500 299
a0d0e21e
LW
300 SETTARG;
301 RETURN;
748a9306 302 }
a0d0e21e
LW
303}
304
305PP(pp_padsv)
306{
97aff369 307 dVAR; dSP; dTARGET;
a0d0e21e 308 XPUSHs(TARG);
533c011a
NIS
309 if (PL_op->op_flags & OPf_MOD) {
310 if (PL_op->op_private & OPpLVAL_INTRO)
952306ac
RGS
311 if (!(PL_op->op_private & OPpPAD_STATE))
312 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
a62b51b8 313 if (PL_op->op_private & OPpDEREF) {
8ec5e241 314 PUTBACK;
9026059d 315 TOPs = vivify_ref(TOPs, PL_op->op_private & OPpDEREF);
8ec5e241
NIS
316 SPAGAIN;
317 }
4633a7c4 318 }
a0d0e21e
LW
319 RETURN;
320}
321
322PP(pp_readline)
323{
97aff369 324 dVAR;
30901a8a
FC
325 dSP;
326 if (TOPs) {
327 SvGETMAGIC(TOPs);
328 tryAMAGICunTARGET(iter_amg, 0, 0);
329 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
330 }
331 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
6e592b3a
BM
332 if (!isGV_with_GP(PL_last_in_gv)) {
333 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
159b6efe 334 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
8efb3254 335 else {
f5284f61 336 dSP;
ad64d0ec 337 XPUSHs(MUTABLE_SV(PL_last_in_gv));
f5284f61 338 PUTBACK;
897d3989 339 Perl_pp_rv2gv(aTHX);
159b6efe 340 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
f5284f61
IZ
341 }
342 }
a0d0e21e
LW
343 return do_readline();
344}
345
346PP(pp_eq)
347{
6f1401dc 348 dVAR; dSP;
33efebe6
DM
349 SV *left, *right;
350
a42d0242 351 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
352 right = POPs;
353 left = TOPs;
354 SETs(boolSV(
355 (SvIOK_notUV(left) && SvIOK_notUV(right))
356 ? (SvIVX(left) == SvIVX(right))
357 : ( do_ncmp(left, right) == 0)
358 ));
359 RETURN;
a0d0e21e
LW
360}
361
362PP(pp_preinc)
363{
97aff369 364 dVAR; dSP;
17058fe0
FC
365 const bool inc =
366 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
60092ce4 367 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
6ad8f254 368 Perl_croak_no_modify(aTHX);
3510b4a1 369 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
17058fe0 370 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
55497cff 371 {
17058fe0 372 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
55497cff 373 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 374 }
28e5dec8 375 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
17058fe0
FC
376 if (inc) sv_inc(TOPs);
377 else sv_dec(TOPs);
a0d0e21e
LW
378 SvSETMAGIC(TOPs);
379 return NORMAL;
380}
381
382PP(pp_or)
383{
97aff369 384 dVAR; dSP;
f410a211 385 PERL_ASYNC_CHECK();
a0d0e21e
LW
386 if (SvTRUE(TOPs))
387 RETURN;
388 else {
c960fc3b
SP
389 if (PL_op->op_type == OP_OR)
390 --SP;
a0d0e21e
LW
391 RETURNOP(cLOGOP->op_other);
392 }
393}
394
25a55bd7 395PP(pp_defined)
c963b151 396{
97aff369 397 dVAR; dSP;
6136c704
AL
398 register SV* sv;
399 bool defined;
25a55bd7 400 const int op_type = PL_op->op_type;
ea5195b7 401 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
c963b151 402
6136c704 403 if (is_dor) {
f410a211 404 PERL_ASYNC_CHECK();
25a55bd7
SP
405 sv = TOPs;
406 if (!sv || !SvANY(sv)) {
2bd49cfc
NC
407 if (op_type == OP_DOR)
408 --SP;
25a55bd7
SP
409 RETURNOP(cLOGOP->op_other);
410 }
b7c44293
RGS
411 }
412 else {
413 /* OP_DEFINED */
25a55bd7
SP
414 sv = POPs;
415 if (!sv || !SvANY(sv))
416 RETPUSHNO;
b7c44293 417 }
25a55bd7 418
6136c704 419 defined = FALSE;
c963b151
BD
420 switch (SvTYPE(sv)) {
421 case SVt_PVAV:
422 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 423 defined = TRUE;
c963b151
BD
424 break;
425 case SVt_PVHV:
426 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 427 defined = TRUE;
c963b151
BD
428 break;
429 case SVt_PVCV:
430 if (CvROOT(sv) || CvXSUB(sv))
25a55bd7 431 defined = TRUE;
c963b151
BD
432 break;
433 default:
5b295bef 434 SvGETMAGIC(sv);
c963b151 435 if (SvOK(sv))
25a55bd7 436 defined = TRUE;
6136c704 437 break;
c963b151 438 }
6136c704
AL
439
440 if (is_dor) {
c960fc3b
SP
441 if(defined)
442 RETURN;
443 if(op_type == OP_DOR)
444 --SP;
25a55bd7 445 RETURNOP(cLOGOP->op_other);
25a55bd7 446 }
d9aa96a4
SP
447 /* assuming OP_DEFINED */
448 if(defined)
449 RETPUSHYES;
450 RETPUSHNO;
c963b151
BD
451}
452
a0d0e21e
LW
453PP(pp_add)
454{
800401ee 455 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
456 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
457 svr = TOPs;
458 svl = TOPm1s;
459
800401ee 460 useleft = USE_LEFT(svl);
28e5dec8
JH
461#ifdef PERL_PRESERVE_IVUV
462 /* We must see if we can perform the addition with integers if possible,
463 as the integer code detects overflow while the NV code doesn't.
464 If either argument hasn't had a numeric conversion yet attempt to get
465 the IV. It's important to do this now, rather than just assuming that
466 it's not IOK as a PV of "9223372036854775806" may not take well to NV
467 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
468 integer in case the second argument is IV=9223372036854775806
469 We can (now) rely on sv_2iv to do the right thing, only setting the
470 public IOK flag if the value in the NV (or PV) slot is truly integer.
471
472 A side effect is that this also aggressively prefers integer maths over
7dca457a
NC
473 fp maths for integer values.
474
a00b5bd3 475 How to detect overflow?
7dca457a
NC
476
477 C 99 section 6.2.6.1 says
478
479 The range of nonnegative values of a signed integer type is a subrange
480 of the corresponding unsigned integer type, and the representation of
481 the same value in each type is the same. A computation involving
482 unsigned operands can never overflow, because a result that cannot be
483 represented by the resulting unsigned integer type is reduced modulo
484 the number that is one greater than the largest value that can be
485 represented by the resulting type.
486
487 (the 9th paragraph)
488
489 which I read as "unsigned ints wrap."
490
491 signed integer overflow seems to be classed as "exception condition"
492
493 If an exceptional condition occurs during the evaluation of an
494 expression (that is, if the result is not mathematically defined or not
495 in the range of representable values for its type), the behavior is
496 undefined.
497
498 (6.5, the 5th paragraph)
499
500 I had assumed that on 2s complement machines signed arithmetic would
501 wrap, hence coded pp_add and pp_subtract on the assumption that
502 everything perl builds on would be happy. After much wailing and
503 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
504 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
505 unsigned code below is actually shorter than the old code. :-)
506 */
507
01f91bf2 508 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
509 /* Unless the left argument is integer in range we are going to have to
510 use NV maths. Hence only attempt to coerce the right argument if
511 we know the left is integer. */
9c5ffd7c
JH
512 register UV auv = 0;
513 bool auvok = FALSE;
7dca457a
NC
514 bool a_valid = 0;
515
28e5dec8 516 if (!useleft) {
7dca457a
NC
517 auv = 0;
518 a_valid = auvok = 1;
519 /* left operand is undef, treat as zero. + 0 is identity,
520 Could SETi or SETu right now, but space optimise by not adding
521 lots of code to speed up what is probably a rarish case. */
522 } else {
523 /* Left operand is defined, so is it IV? */
01f91bf2 524 if (SvIV_please_nomg(svl)) {
800401ee
JH
525 if ((auvok = SvUOK(svl)))
526 auv = SvUVX(svl);
7dca457a 527 else {
800401ee 528 register const IV aiv = SvIVX(svl);
7dca457a
NC
529 if (aiv >= 0) {
530 auv = aiv;
531 auvok = 1; /* Now acting as a sign flag. */
532 } else { /* 2s complement assumption for IV_MIN */
533 auv = (UV)-aiv;
534 }
535 }
536 a_valid = 1;
28e5dec8
JH
537 }
538 }
7dca457a
NC
539 if (a_valid) {
540 bool result_good = 0;
541 UV result;
542 register UV buv;
800401ee 543 bool buvok = SvUOK(svr);
a00b5bd3 544
7dca457a 545 if (buvok)
800401ee 546 buv = SvUVX(svr);
7dca457a 547 else {
800401ee 548 register const IV biv = SvIVX(svr);
7dca457a
NC
549 if (biv >= 0) {
550 buv = biv;
551 buvok = 1;
552 } else
553 buv = (UV)-biv;
554 }
555 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 556 else "IV" now, independent of how it came in.
7dca457a
NC
557 if a, b represents positive, A, B negative, a maps to -A etc
558 a + b => (a + b)
559 A + b => -(a - b)
560 a + B => (a - b)
561 A + B => -(a + b)
562 all UV maths. negate result if A negative.
563 add if signs same, subtract if signs differ. */
564
565 if (auvok ^ buvok) {
566 /* Signs differ. */
567 if (auv >= buv) {
568 result = auv - buv;
569 /* Must get smaller */
570 if (result <= auv)
571 result_good = 1;
572 } else {
573 result = buv - auv;
574 if (result <= buv) {
575 /* result really should be -(auv-buv). as its negation
576 of true value, need to swap our result flag */
577 auvok = !auvok;
578 result_good = 1;
28e5dec8
JH
579 }
580 }
7dca457a
NC
581 } else {
582 /* Signs same */
583 result = auv + buv;
584 if (result >= auv)
585 result_good = 1;
586 }
587 if (result_good) {
588 SP--;
589 if (auvok)
28e5dec8 590 SETu( result );
7dca457a
NC
591 else {
592 /* Negate result */
593 if (result <= (UV)IV_MIN)
594 SETi( -(IV)result );
595 else {
596 /* result valid, but out of range for IV. */
597 SETn( -(NV)result );
28e5dec8
JH
598 }
599 }
7dca457a
NC
600 RETURN;
601 } /* Overflow, drop through to NVs. */
28e5dec8
JH
602 }
603 }
604#endif
a0d0e21e 605 {
6f1401dc 606 NV value = SvNV_nomg(svr);
4efa5a16 607 (void)POPs;
28e5dec8
JH
608 if (!useleft) {
609 /* left operand is undef, treat as zero. + 0.0 is identity. */
610 SETn(value);
611 RETURN;
612 }
6f1401dc 613 SETn( value + SvNV_nomg(svl) );
28e5dec8 614 RETURN;
a0d0e21e
LW
615 }
616}
617
618PP(pp_aelemfast)
619{
97aff369 620 dVAR; dSP;
93bad3fd 621 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
8f878375 622 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
a3b680e6 623 const U32 lval = PL_op->op_flags & OPf_MOD;
0bd48802 624 SV** const svp = av_fetch(av, PL_op->op_private, lval);
3280af22 625 SV *sv = (svp ? *svp : &PL_sv_undef);
6ff81951 626 EXTEND(SP, 1);
39cf747a 627 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 628 mg_get(sv);
be6c24e0 629 PUSHs(sv);
a0d0e21e
LW
630 RETURN;
631}
632
633PP(pp_join)
634{
97aff369 635 dVAR; dSP; dMARK; dTARGET;
a0d0e21e
LW
636 MARK++;
637 do_join(TARG, *MARK, MARK, SP);
638 SP = MARK;
639 SETs(TARG);
640 RETURN;
641}
642
643PP(pp_pushre)
644{
97aff369 645 dVAR; dSP;
44a8e56a
PP
646#ifdef DEBUGGING
647 /*
648 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
649 * will be enough to hold an OP*.
650 */
c4420975 651 SV* const sv = sv_newmortal();
44a8e56a
PP
652 sv_upgrade(sv, SVt_PVLV);
653 LvTYPE(sv) = '/';
533c011a 654 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
44a8e56a
PP
655 XPUSHs(sv);
656#else
ad64d0ec 657 XPUSHs(MUTABLE_SV(PL_op));
44a8e56a 658#endif
a0d0e21e
LW
659 RETURN;
660}
661
662/* Oversized hot code. */
663
664PP(pp_print)
665{
27da23d5 666 dVAR; dSP; dMARK; dORIGMARK;
760ac839 667 register PerlIO *fp;
236988e4 668 MAGIC *mg;
159b6efe
NC
669 GV * const gv
670 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 671 IO *io = GvIO(gv);
5b468f54 672
9c9f25b8 673 if (io
ad64d0ec 674 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 675 {
01bb7c6d 676 had_magic:
68dc0745 677 if (MARK == ORIGMARK) {
1c846c1f 678 /* If using default handle then we need to make space to
a60c0954
NIS
679 * pass object as 1st arg, so move other args up ...
680 */
4352c267 681 MEXTEND(SP, 1);
68dc0745
PP
682 ++MARK;
683 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
684 ++SP;
685 }
94bc412f
NC
686 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
687 mg,
688 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
689 | (PL_op->op_type == OP_SAY
690 ? TIED_METHOD_SAY : 0)), sp - mark);
236988e4 691 }
9c9f25b8 692 if (!io) {
68b590d9 693 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
ad64d0ec 694 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 695 goto had_magic;
51087808 696 report_evil_fh(gv);
93189314 697 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
698 goto just_say_no;
699 }
700 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
701 if (IoIFP(io))
702 report_wrongway_fh(gv, '<');
51087808 703 else
7716c5c5 704 report_evil_fh(gv);
93189314 705 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
706 goto just_say_no;
707 }
708 else {
e23d9e2f 709 SV * const ofs = GvSV(PL_ofsgv); /* $, */
a0d0e21e 710 MARK++;
e23d9e2f 711 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
a0d0e21e
LW
712 while (MARK <= SP) {
713 if (!do_print(*MARK, fp))
714 break;
715 MARK++;
716 if (MARK <= SP) {
e23d9e2f
CS
717 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
718 if (!do_print(GvSV(PL_ofsgv), fp)) {
a0d0e21e
LW
719 MARK--;
720 break;
721 }
722 }
723 }
724 }
725 else {
726 while (MARK <= SP) {
727 if (!do_print(*MARK, fp))
728 break;
729 MARK++;
730 }
731 }
732 if (MARK <= SP)
733 goto just_say_no;
734 else {
cfc4a7da
GA
735 if (PL_op->op_type == OP_SAY) {
736 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
737 goto just_say_no;
738 }
739 else if (PL_ors_sv && SvOK(PL_ors_sv))
7889fe52 740 if (!do_print(PL_ors_sv, fp)) /* $\ */
a0d0e21e
LW
741 goto just_say_no;
742
743 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 744 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
745 goto just_say_no;
746 }
747 }
748 SP = ORIGMARK;
e52fd6f4 749 XPUSHs(&PL_sv_yes);
a0d0e21e
LW
750 RETURN;
751
752 just_say_no:
753 SP = ORIGMARK;
e52fd6f4 754 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
755 RETURN;
756}
757
758PP(pp_rv2av)
759{
97aff369 760 dVAR; dSP; dTOPss;
cde874ca 761 const I32 gimme = GIMME_V;
17ab7946
NC
762 static const char an_array[] = "an ARRAY";
763 static const char a_hash[] = "a HASH";
764 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
d83b45b8 765 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 766
9026059d 767 SvGETMAGIC(sv);
a0d0e21e 768 if (SvROK(sv)) {
93d7320b
DM
769 if (SvAMAGIC(sv)) {
770 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
93d7320b 771 }
17ab7946
NC
772 sv = SvRV(sv);
773 if (SvTYPE(sv) != type)
dcbac5bb 774 /* diag_listed_as: Not an ARRAY reference */
17ab7946 775 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
533c011a 776 if (PL_op->op_flags & OPf_REF) {
17ab7946 777 SETs(sv);
a0d0e21e
LW
778 RETURN;
779 }
40c94d11
FC
780 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
781 const I32 flags = is_lvalue_sub();
782 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 783 if (gimme != G_ARRAY)
042560a6 784 goto croak_cant_return;
17ab7946 785 SETs(sv);
78f9721b 786 RETURN;
40c94d11 787 }
78f9721b 788 }
82d03984
RGS
789 else if (PL_op->op_flags & OPf_MOD
790 && PL_op->op_private & OPpLVAL_INTRO)
f1f66076 791 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e
LW
792 }
793 else {
17ab7946 794 if (SvTYPE(sv) == type) {
533c011a 795 if (PL_op->op_flags & OPf_REF) {
17ab7946 796 SETs(sv);
a0d0e21e
LW
797 RETURN;
798 }
78f9721b 799 else if (LVRET) {
cde874ca 800 if (gimme != G_ARRAY)
042560a6 801 goto croak_cant_return;
17ab7946 802 SETs(sv);
78f9721b
SM
803 RETURN;
804 }
a0d0e21e
LW
805 }
806 else {
67955e0c 807 GV *gv;
1c846c1f 808
6e592b3a 809 if (!isGV_with_GP(sv)) {
dc3c76f8
NC
810 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
811 type, &sp);
812 if (!gv)
813 RETURN;
35cd451c
GS
814 }
815 else {
159b6efe 816 gv = MUTABLE_GV(sv);
a0d0e21e 817 }
ad64d0ec 818 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 819 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 820 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
533c011a 821 if (PL_op->op_flags & OPf_REF) {
17ab7946 822 SETs(sv);
a0d0e21e
LW
823 RETURN;
824 }
40c94d11
FC
825 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
826 const I32 flags = is_lvalue_sub();
827 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 828 if (gimme != G_ARRAY)
042560a6 829 goto croak_cant_return;
17ab7946 830 SETs(sv);
78f9721b 831 RETURN;
40c94d11 832 }
78f9721b 833 }
a0d0e21e
LW
834 }
835 }
836
17ab7946 837 if (is_pp_rv2av) {
502c6561 838 AV *const av = MUTABLE_AV(sv);
486ec47a 839 /* The guts of pp_rv2av, with no intending change to preserve history
17ab7946
NC
840 (until such time as we get tools that can do blame annotation across
841 whitespace changes. */
96913b52
VP
842 if (gimme == G_ARRAY) {
843 const I32 maxarg = AvFILL(av) + 1;
844 (void)POPs; /* XXXX May be optimized away? */
845 EXTEND(SP, maxarg);
846 if (SvRMAGICAL(av)) {
847 U32 i;
848 for (i=0; i < (U32)maxarg; i++) {
849 SV ** const svp = av_fetch(av, i, FALSE);
850 /* See note in pp_helem, and bug id #27839 */
851 SP[i+1] = svp
852 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
853 : &PL_sv_undef;
854 }
855 }
856 else {
857 Copy(AvARRAY(av), SP+1, maxarg, SV*);
93965878 858 }
96913b52 859 SP += maxarg;
1c846c1f 860 }
96913b52
VP
861 else if (gimme == G_SCALAR) {
862 dTARGET;
863 const I32 maxarg = AvFILL(av) + 1;
864 SETi(maxarg);
93965878 865 }
17ab7946
NC
866 } else {
867 /* The guts of pp_rv2hv */
96913b52
VP
868 if (gimme == G_ARRAY) { /* array wanted */
869 *PL_stack_sp = sv;
981b7185 870 return Perl_do_kv(aTHX);
96913b52
VP
871 }
872 else if (gimme == G_SCALAR) {
873 dTARGET;
874 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
875 SPAGAIN;
876 SETTARG;
877 }
17ab7946 878 }
be85d344 879 RETURN;
042560a6
NC
880
881 croak_cant_return:
882 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
883 is_pp_rv2av ? "array" : "hash");
77e217c6 884 RETURN;
a0d0e21e
LW
885}
886
10c8fecd
GS
887STATIC void
888S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
889{
97aff369 890 dVAR;
7918f24d
NC
891
892 PERL_ARGS_ASSERT_DO_ODDBALL;
893
10c8fecd
GS
894 if (*relem) {
895 SV *tmpstr;
b464bac0 896 const HE *didstore;
6d822dc4
MS
897
898 if (ckWARN(WARN_MISC)) {
a3b680e6 899 const char *err;
10c8fecd
GS
900 if (relem == firstrelem &&
901 SvROK(*relem) &&
902 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
903 SvTYPE(SvRV(*relem)) == SVt_PVHV))
904 {
a3b680e6 905 err = "Reference found where even-sized list expected";
10c8fecd
GS
906 }
907 else
a3b680e6 908 err = "Odd number of elements in hash assignment";
f1f66076 909 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
10c8fecd 910 }
6d822dc4 911
561b68a9 912 tmpstr = newSV(0);
6d822dc4
MS
913 didstore = hv_store_ent(hash,*relem,tmpstr,0);
914 if (SvMAGICAL(hash)) {
915 if (SvSMAGICAL(tmpstr))
916 mg_set(tmpstr);
917 if (!didstore)
918 sv_2mortal(tmpstr);
919 }
920 TAINT_NOT;
10c8fecd
GS
921 }
922}
923
a0d0e21e
LW
924PP(pp_aassign)
925{
27da23d5 926 dVAR; dSP;
3280af22
NIS
927 SV **lastlelem = PL_stack_sp;
928 SV **lastrelem = PL_stack_base + POPMARK;
929 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
930 SV **firstlelem = lastrelem + 1;
931
932 register SV **relem;
933 register SV **lelem;
934
935 register SV *sv;
936 register AV *ary;
937
54310121 938 I32 gimme;
a0d0e21e
LW
939 HV *hash;
940 I32 i;
941 int magic;
ca65944e 942 int duplicates = 0;
cbbf8932 943 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
5637b936 944
3280af22 945 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
ca65944e 946 gimme = GIMME_V;
a0d0e21e
LW
947
948 /* If there's a common identifier on both sides we have to take
949 * special care that assigning the identifier on the left doesn't
950 * clobber a value on the right that's used later in the list.
acdea6f0 951 * Don't bother if LHS is just an empty hash or array.
a0d0e21e 952 */
acdea6f0
DM
953
954 if ( (PL_op->op_private & OPpASSIGN_COMMON)
955 && (
956 firstlelem != lastlelem
957 || ! ((sv = *firstlelem))
958 || SvMAGICAL(sv)
959 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
960 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1b95d04f 961 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
acdea6f0
DM
962 )
963 ) {
cc5e57d2 964 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd 965 for (relem = firstrelem; relem <= lastrelem; relem++) {
155aba94 966 if ((sv = *relem)) {
a1f49e72 967 TAINT_NOT; /* Each item is independent */
61e5f455
NC
968
969 /* Dear TODO test in t/op/sort.t, I love you.
970 (It's relying on a panic, not a "semi-panic" from newSVsv()
971 and then an assertion failure below.) */
972 if (SvIS_FREED(sv)) {
973 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
974 (void*)sv);
975 }
976 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
977 and we need a second copy of a temp here. */
978 *relem = sv_2mortal(newSVsv(sv));
a1f49e72 979 }
10c8fecd 980 }
a0d0e21e
LW
981 }
982
983 relem = firstrelem;
984 lelem = firstlelem;
4608196e
RGS
985 ary = NULL;
986 hash = NULL;
10c8fecd 987
a0d0e21e 988 while (lelem <= lastlelem) {
bbce6d69 989 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e
LW
990 sv = *lelem++;
991 switch (SvTYPE(sv)) {
992 case SVt_PVAV:
60edcf09 993 ary = MUTABLE_AV(sv);
748a9306 994 magic = SvMAGICAL(ary) != 0;
60edcf09
FC
995 ENTER;
996 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 997 av_clear(ary);
7e42bd57 998 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
999 i = 0;
1000 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 1001 SV **didstore;
a0d0e21e 1002 assert(*relem);
4f0556e9
NC
1003 sv = newSV(0);
1004 sv_setsv(sv, *relem);
a0d0e21e 1005 *(relem++) = sv;
5117ca91
GS
1006 didstore = av_store(ary,i++,sv);
1007 if (magic) {
8ef24240 1008 if (SvSMAGICAL(sv))
fb73857a 1009 mg_set(sv);
5117ca91 1010 if (!didstore)
8127e0e3 1011 sv_2mortal(sv);
5117ca91 1012 }
bbce6d69 1013 TAINT_NOT;
a0d0e21e 1014 }
354b0578 1015 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 1016 SvSETMAGIC(MUTABLE_SV(ary));
60edcf09 1017 LEAVE;
a0d0e21e 1018 break;
10c8fecd 1019 case SVt_PVHV: { /* normal hash */
a0d0e21e 1020 SV *tmpstr;
45960564 1021 SV** topelem = relem;
a0d0e21e 1022
60edcf09 1023 hash = MUTABLE_HV(sv);
748a9306 1024 magic = SvMAGICAL(hash) != 0;
60edcf09
FC
1025 ENTER;
1026 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1027 hv_clear(hash);
ca65944e 1028 firsthashrelem = relem;
a0d0e21e
LW
1029
1030 while (relem < lastrelem) { /* gobble up all the rest */
5117ca91 1031 HE *didstore;
6136c704
AL
1032 sv = *relem ? *relem : &PL_sv_no;
1033 relem++;
561b68a9 1034 tmpstr = newSV(0);
a0d0e21e
LW
1035 if (*relem)
1036 sv_setsv(tmpstr,*relem); /* value */
45960564
DM
1037 relem++;
1038 if (gimme != G_VOID) {
1039 if (hv_exists_ent(hash, sv, 0))
1040 /* key overwrites an existing entry */
1041 duplicates += 2;
1042 else
1043 if (gimme == G_ARRAY) {
1044 /* copy element back: possibly to an earlier
1045 * stack location if we encountered dups earlier */
1046 *topelem++ = sv;
1047 *topelem++ = tmpstr;
1048 }
1049 }
5117ca91
GS
1050 didstore = hv_store_ent(hash,sv,tmpstr,0);
1051 if (magic) {
8ef24240 1052 if (SvSMAGICAL(tmpstr))
fb73857a 1053 mg_set(tmpstr);
5117ca91 1054 if (!didstore)
8127e0e3 1055 sv_2mortal(tmpstr);
5117ca91 1056 }
bbce6d69 1057 TAINT_NOT;
8e07c86e 1058 }
6a0deba8 1059 if (relem == lastrelem) {
10c8fecd 1060 do_oddball(hash, relem, firstrelem);
6a0deba8 1061 relem++;
1930e939 1062 }
60edcf09 1063 LEAVE;
a0d0e21e
LW
1064 }
1065 break;
1066 default:
6fc92669
GS
1067 if (SvIMMORTAL(sv)) {
1068 if (relem <= lastrelem)
1069 relem++;
1070 break;
a0d0e21e
LW
1071 }
1072 if (relem <= lastrelem) {
1c70fb82
FC
1073 if (
1074 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1075 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1076 )
1077 Perl_warner(aTHX_
1078 packWARN(WARN_MISC),
1079 "Useless assignment to a temporary"
1080 );
a0d0e21e
LW
1081 sv_setsv(sv, *relem);
1082 *(relem++) = sv;
1083 }
1084 else
3280af22 1085 sv_setsv(sv, &PL_sv_undef);
8ef24240 1086 SvSETMAGIC(sv);
a0d0e21e
LW
1087 break;
1088 }
1089 }
3280af22 1090 if (PL_delaymagic & ~DM_DELAY) {
985213f2
AB
1091 /* Will be used to set PL_tainting below */
1092 UV tmp_uid = PerlProc_getuid();
1093 UV tmp_euid = PerlProc_geteuid();
1094 UV tmp_gid = PerlProc_getgid();
1095 UV tmp_egid = PerlProc_getegid();
1096
3280af22 1097 if (PL_delaymagic & DM_UID) {
a0d0e21e 1098#ifdef HAS_SETRESUID
985213f2
AB
1099 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1100 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
fb934a90 1101 (Uid_t)-1);
56febc5e
AD
1102#else
1103# ifdef HAS_SETREUID
985213f2
AB
1104 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1105 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
56febc5e
AD
1106# else
1107# ifdef HAS_SETRUID
b28d0864 1108 if ((PL_delaymagic & DM_UID) == DM_RUID) {
985213f2 1109 (void)setruid(PL_delaymagic_uid);
b28d0864 1110 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1111 }
56febc5e
AD
1112# endif /* HAS_SETRUID */
1113# ifdef HAS_SETEUID
b28d0864 1114 if ((PL_delaymagic & DM_UID) == DM_EUID) {
985213f2 1115 (void)seteuid(PL_delaymagic_euid);
b28d0864 1116 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1117 }
56febc5e 1118# endif /* HAS_SETEUID */
b28d0864 1119 if (PL_delaymagic & DM_UID) {
985213f2 1120 if (PL_delaymagic_uid != PL_delaymagic_euid)
cea2e8a9 1121 DIE(aTHX_ "No setreuid available");
985213f2 1122 (void)PerlProc_setuid(PL_delaymagic_uid);
a0d0e21e 1123 }
56febc5e
AD
1124# endif /* HAS_SETREUID */
1125#endif /* HAS_SETRESUID */
985213f2
AB
1126 tmp_uid = PerlProc_getuid();
1127 tmp_euid = PerlProc_geteuid();
a0d0e21e 1128 }
3280af22 1129 if (PL_delaymagic & DM_GID) {
a0d0e21e 1130#ifdef HAS_SETRESGID
985213f2
AB
1131 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1132 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
fb934a90 1133 (Gid_t)-1);
56febc5e
AD
1134#else
1135# ifdef HAS_SETREGID
985213f2
AB
1136 (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1137 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
56febc5e
AD
1138# else
1139# ifdef HAS_SETRGID
b28d0864 1140 if ((PL_delaymagic & DM_GID) == DM_RGID) {
985213f2 1141 (void)setrgid(PL_delaymagic_gid);
b28d0864 1142 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1143 }
56febc5e
AD
1144# endif /* HAS_SETRGID */
1145# ifdef HAS_SETEGID
b28d0864 1146 if ((PL_delaymagic & DM_GID) == DM_EGID) {
985213f2 1147 (void)setegid(PL_delaymagic_egid);
b28d0864 1148 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1149 }
56febc5e 1150# endif /* HAS_SETEGID */
b28d0864 1151 if (PL_delaymagic & DM_GID) {
985213f2 1152 if (PL_delaymagic_gid != PL_delaymagic_egid)
cea2e8a9 1153 DIE(aTHX_ "No setregid available");
985213f2 1154 (void)PerlProc_setgid(PL_delaymagic_gid);
a0d0e21e 1155 }
56febc5e
AD
1156# endif /* HAS_SETREGID */
1157#endif /* HAS_SETRESGID */
985213f2
AB
1158 tmp_gid = PerlProc_getgid();
1159 tmp_egid = PerlProc_getegid();
a0d0e21e 1160 }
985213f2 1161 PL_tainting |= (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid));
a0d0e21e 1162 }
3280af22 1163 PL_delaymagic = 0;
54310121 1164
54310121
PP
1165 if (gimme == G_VOID)
1166 SP = firstrelem - 1;
1167 else if (gimme == G_SCALAR) {
1168 dTARGET;
1169 SP = firstrelem;
ca65944e 1170 SETi(lastrelem - firstrelem + 1 - duplicates);
54310121
PP
1171 }
1172 else {
ca65944e 1173 if (ary)
a0d0e21e 1174 SP = lastrelem;
ca65944e
RGS
1175 else if (hash) {
1176 if (duplicates) {
45960564
DM
1177 /* at this point we have removed the duplicate key/value
1178 * pairs from the stack, but the remaining values may be
1179 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1180 * the (a 2), but the stack now probably contains
1181 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1182 * obliterates the earlier key. So refresh all values. */
ca65944e 1183 lastrelem -= duplicates;
45960564
DM
1184 relem = firsthashrelem;
1185 while (relem < lastrelem) {
1186 HE *he;
1187 sv = *relem++;
1188 he = hv_fetch_ent(hash, sv, 0, 0);
1189 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1190 }
ca65944e
RGS
1191 }
1192 SP = lastrelem;
1193 }
a0d0e21e
LW
1194 else
1195 SP = firstrelem + (lastlelem - firstlelem);
0c8c7a05 1196 lelem = firstlelem + (relem - firstrelem);
5f05dabc 1197 while (relem <= SP)
3280af22 1198 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
a0d0e21e 1199 }
08aeb9f7 1200
54310121 1201 RETURN;
a0d0e21e
LW
1202}
1203
8782bef2
GB
1204PP(pp_qr)
1205{
97aff369 1206 dVAR; dSP;
c4420975 1207 register PMOP * const pm = cPMOP;
fe578d7f 1208 REGEXP * rx = PM_GETRE(pm);
10599a69 1209 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
c4420975 1210 SV * const rv = sv_newmortal();
d63c20f2
DM
1211 CV **cvp;
1212 CV *cv;
288b8c02
NC
1213
1214 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
1215 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1216 loathe to use it here, but it seems to be the right fix. Or close.
1217 The key part appears to be that it's essential for pp_qr to return a new
1218 object (SV), which implies that there needs to be an effective way to
1219 generate a new SV from the existing SV that is pre-compiled in the
1220 optree. */
1221 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
1222 SvROK_on(rv);
1223
d63c20f2
DM
1224 cvp = &( ((struct regexp*)SvANY(SvRV(rv)))->qr_anoncv);
1225 if ((cv = *cvp) && CvCLONE(*cvp)) {
1226 *cvp = cv_clone(cv);
1227 SvREFCNT_dec(cv);
1228 }
1229
288b8c02 1230 if (pkg) {
f815daf2 1231 HV *const stash = gv_stashsv(pkg, GV_ADD);
a954f6ee 1232 SvREFCNT_dec(pkg);
288b8c02
NC
1233 (void)sv_bless(rv, stash);
1234 }
1235
9274aefd 1236 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
e08e52cf 1237 SvTAINTED_on(rv);
9274aefd
DM
1238 SvTAINTED_on(SvRV(rv));
1239 }
c8c13c22 1240 XPUSHs(rv);
1241 RETURN;
8782bef2
GB
1242}
1243
a0d0e21e
LW
1244PP(pp_match)
1245{
97aff369 1246 dVAR; dSP; dTARG;
a0d0e21e 1247 register PMOP *pm = cPMOP;
d65afb4b 1248 PMOP *dynpm = pm;
0d46e09a
SP
1249 register const char *t;
1250 register const char *s;
5c144d81 1251 const char *strend;
a0d0e21e 1252 I32 global;
1ed74d04 1253 U8 r_flags = REXEC_CHECKED;
5c144d81 1254 const char *truebase; /* Start of string */
aaa362c4 1255 register REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1256 bool rxtainted;
a3b680e6 1257 const I32 gimme = GIMME;
a0d0e21e 1258 STRLEN len;
748a9306 1259 I32 minmatch = 0;
a3b680e6 1260 const I32 oldsave = PL_savestack_ix;
f86702cc 1261 I32 update_minmatch = 1;
e60df1fa 1262 I32 had_zerolen = 0;
58e23c8d 1263 U32 gpos = 0;
a0d0e21e 1264
533c011a 1265 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1266 TARG = POPs;
59f00321
RGS
1267 else if (PL_op->op_private & OPpTARGET_MY)
1268 GETTARGET;
a0d0e21e 1269 else {
54b9620d 1270 TARG = DEFSV;
a0d0e21e
LW
1271 EXTEND(SP,1);
1272 }
d9f424b2 1273
c277df42 1274 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
1275 /* Skip get-magic if this is a qr// clone, because regcomp has
1276 already done it. */
1277 s = ((struct regexp *)SvANY(rx))->mother_re
1278 ? SvPV_nomg_const(TARG, len)
1279 : SvPV_const(TARG, len);
a0d0e21e 1280 if (!s)
2269b42e 1281 DIE(aTHX_ "panic: pp_match");
890ce7af 1282 strend = s + len;
07bc277f 1283 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
3280af22 1284 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1285 TAINT_NOT;
a0d0e21e 1286
a30b2f1f 1287 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 1288
d65afb4b 1289 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
1290 if (
1291#ifdef USE_ITHREADS
1292 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1293#else
1294 pm->op_pmflags & PMf_USED
1295#endif
1296 ) {
e5dc5375 1297 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
c277df42 1298 failure:
e5dc5375 1299
a0d0e21e
LW
1300 if (gimme == G_ARRAY)
1301 RETURN;
1302 RETPUSHNO;
1303 }
1304
c737faaf
YO
1305
1306
d65afb4b 1307 /* empty pattern special-cased to use last successful pattern if possible */
220fc49f 1308 if (!RX_PRELEN(rx) && PL_curpm) {
3280af22 1309 pm = PL_curpm;
aaa362c4 1310 rx = PM_GETRE(pm);
a0d0e21e 1311 }
d65afb4b 1312
e5dc5375
KW
1313 if (RX_MINLEN(rx) > (I32)len) {
1314 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
d65afb4b 1315 goto failure;
e5dc5375 1316 }
c277df42 1317
a0d0e21e 1318 truebase = t = s;
ad94a511
IZ
1319
1320 /* XXXX What part of this is needed with true \G-support? */
d65afb4b 1321 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
07bc277f 1322 RX_OFFS(rx)[0].start = -1;
a0d0e21e 1323 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
c445ea15 1324 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
565764a8 1325 if (mg && mg->mg_len >= 0) {
07bc277f
NC
1326 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1327 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1328 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
0ef3e39e 1329 r_flags |= REXEC_IGNOREPOS;
07bc277f
NC
1330 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1331 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
58e23c8d
YO
1332 gpos = mg->mg_len;
1333 else
07bc277f
NC
1334 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1335 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
f86702cc 1336 update_minmatch = 0;
748a9306 1337 }
a0d0e21e
LW
1338 }
1339 }
a229a030 1340 /* XXX: comment out !global get safe $1 vars after a
62e7980d 1341 match, BUT be aware that this leads to dramatic slowdowns on
a229a030
YO
1342 /g matches against large strings. So far a solution to this problem
1343 appears to be quite tricky.
1344 Test for the unsafe vars are TODO for now. */
0d8a731b
DM
1345 if ( (!global && RX_NPARENS(rx))
1346 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1347 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
14977893 1348 r_flags |= REXEC_COPY_STR;
22e551b9 1349
d7be1480 1350 play_it_again:
07bc277f
NC
1351 if (global && RX_OFFS(rx)[0].start != -1) {
1352 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
e5dc5375
KW
1353 if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
1354 DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
a0d0e21e 1355 goto nope;
e5dc5375 1356 }
f86702cc 1357 if (update_minmatch++)
e60df1fa 1358 minmatch = had_zerolen;
a0d0e21e 1359 }
07bc277f 1360 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
3c8556c3 1361 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
5c144d81
NC
1362 /* FIXME - can PL_bostr be made const char *? */
1363 PL_bostr = (char *)truebase;
f9f4320a 1364 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
f722798b
IZ
1365
1366 if (!s)
1367 goto nope;
07bc277f 1368 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
14977893 1369 && !PL_sawampersand
07bc277f 1370 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
05b4157f 1371 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
f722798b 1372 goto yup;
a0d0e21e 1373 }
77da2310
NC
1374 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1375 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1376 goto ret_no;
1377
1378 PL_curpm = pm;
1379 if (dynpm->op_pmflags & PMf_ONCE) {
c737faaf 1380#ifdef USE_ITHREADS
77da2310 1381 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 1382#else
77da2310 1383 dynpm->op_pmflags |= PMf_USED;
c737faaf 1384#endif
a0d0e21e 1385 }
a0d0e21e
LW
1386
1387 gotcha:
72311751
GS
1388 if (rxtainted)
1389 RX_MATCH_TAINTED_on(rx);
1390 TAINT_IF(RX_MATCH_TAINTED(rx));
a0d0e21e 1391 if (gimme == G_ARRAY) {
07bc277f 1392 const I32 nparens = RX_NPARENS(rx);
a3b680e6 1393 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 1394
c277df42 1395 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1396 EXTEND(SP, nparens + i);
1397 EXTEND_MORTAL(nparens + i);
1398 for (i = !i; i <= nparens; i++) {
a0d0e21e 1399 PUSHs(sv_newmortal());
07bc277f
NC
1400 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1401 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1402 s = RX_OFFS(rx)[i].start + truebase;
1403 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
290deeac 1404 len < 0 || len > strend - s)
5637ef5b
NC
1405 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1406 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1407 (long) i, (long) RX_OFFS(rx)[i].start,
1408 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
a0d0e21e 1409 sv_setpvn(*SP, s, len);
cce850e4 1410 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1411 SvUTF8_on(*SP);
a0d0e21e
LW
1412 }
1413 }
1414 if (global) {
d65afb4b 1415 if (dynpm->op_pmflags & PMf_CONTINUE) {
6136c704 1416 MAGIC* mg = NULL;
0af80b60
HS
1417 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1418 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1419 if (!mg) {
d83f0a82
NC
1420#ifdef PERL_OLD_COPY_ON_WRITE
1421 if (SvIsCOW(TARG))
1422 sv_force_normal_flags(TARG, 0);
1423#endif
1424 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1425 &PL_vtbl_mglob, NULL, 0);
0af80b60 1426 }
07bc277f
NC
1427 if (RX_OFFS(rx)[0].start != -1) {
1428 mg->mg_len = RX_OFFS(rx)[0].end;
1429 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
0af80b60
HS
1430 mg->mg_flags |= MGf_MINMATCH;
1431 else
1432 mg->mg_flags &= ~MGf_MINMATCH;
1433 }
1434 }
07bc277f
NC
1435 had_zerolen = (RX_OFFS(rx)[0].start != -1
1436 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1437 == (UV)RX_OFFS(rx)[0].end));
c277df42 1438 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1439 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1440 goto play_it_again;
1441 }
ffc61ed2 1442 else if (!nparens)
bde848c5 1443 XPUSHs(&PL_sv_yes);
4633a7c4 1444 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1445 RETURN;
1446 }
1447 else {
1448 if (global) {
cbbf8932 1449 MAGIC* mg;
a0d0e21e 1450 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
14befaf4 1451 mg = mg_find(TARG, PERL_MAGIC_regex_global);
cbbf8932
AL
1452 else
1453 mg = NULL;
a0d0e21e 1454 if (!mg) {
d83f0a82
NC
1455#ifdef PERL_OLD_COPY_ON_WRITE
1456 if (SvIsCOW(TARG))
1457 sv_force_normal_flags(TARG, 0);
1458#endif
1459 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1460 &PL_vtbl_mglob, NULL, 0);
a0d0e21e 1461 }
07bc277f
NC
1462 if (RX_OFFS(rx)[0].start != -1) {
1463 mg->mg_len = RX_OFFS(rx)[0].end;
1464 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
748a9306
LW
1465 mg->mg_flags |= MGf_MINMATCH;
1466 else
1467 mg->mg_flags &= ~MGf_MINMATCH;
1468 }
a0d0e21e 1469 }
4633a7c4 1470 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1471 RETPUSHYES;
1472 }
1473
f722798b 1474yup: /* Confirmed by INTUIT */
72311751
GS
1475 if (rxtainted)
1476 RX_MATCH_TAINTED_on(rx);
1477 TAINT_IF(RX_MATCH_TAINTED(rx));
3280af22 1478 PL_curpm = pm;
c737faaf
YO
1479 if (dynpm->op_pmflags & PMf_ONCE) {
1480#ifdef USE_ITHREADS
1481 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1482#else
1483 dynpm->op_pmflags |= PMf_USED;
1484#endif
1485 }
cf93c79d 1486 if (RX_MATCH_COPIED(rx))
07bc277f 1487 Safefree(RX_SUBBEG(rx));
cf93c79d 1488 RX_MATCH_COPIED_off(rx);
07bc277f 1489 RX_SUBBEG(rx) = NULL;
a0d0e21e 1490 if (global) {
5c144d81 1491 /* FIXME - should rx->subbeg be const char *? */
07bc277f
NC
1492 RX_SUBBEG(rx) = (char *) truebase;
1493 RX_OFFS(rx)[0].start = s - truebase;
a30b2f1f 1494 if (RX_MATCH_UTF8(rx)) {
07bc277f
NC
1495 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1496 RX_OFFS(rx)[0].end = t - truebase;
60aeb6fd
NIS
1497 }
1498 else {
07bc277f 1499 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
60aeb6fd 1500 }
07bc277f 1501 RX_SUBLEN(rx) = strend - truebase;
a0d0e21e 1502 goto gotcha;
1c846c1f 1503 }
07bc277f 1504 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
14977893 1505 I32 off;
f8c7b90f 1506#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
1507 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1508 if (DEBUG_C_TEST) {
1509 PerlIO_printf(Perl_debug_log,
1510 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
6c9570dc 1511 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
ed252734
NC
1512 (int)(t-truebase));
1513 }
bdd9a1b1
NC
1514 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1515 RX_SUBBEG(rx)
1516 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1517 assert (SvPOKp(RX_SAVED_COPY(rx)));
ed252734
NC
1518 } else
1519#endif
1520 {
14977893 1521
07bc277f 1522 RX_SUBBEG(rx) = savepvn(t, strend - t);
f8c7b90f 1523#ifdef PERL_OLD_COPY_ON_WRITE
bdd9a1b1 1524 RX_SAVED_COPY(rx) = NULL;
ed252734
NC
1525#endif
1526 }
07bc277f 1527 RX_SUBLEN(rx) = strend - t;
14977893 1528 RX_MATCH_COPIED_on(rx);
07bc277f
NC
1529 off = RX_OFFS(rx)[0].start = s - t;
1530 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
14977893
JH
1531 }
1532 else { /* startp/endp are used by @- @+. */
07bc277f
NC
1533 RX_OFFS(rx)[0].start = s - truebase;
1534 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
14977893 1535 }
7e1a2c8d
DM
1536 /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
1537 assert(!RX_NPARENS(rx));
1538 RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
4633a7c4 1539 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1540 RETPUSHYES;
1541
1542nope:
a0d0e21e 1543ret_no:
d65afb4b 1544 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e 1545 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
6136c704 1546 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1547 if (mg)
565764a8 1548 mg->mg_len = -1;
a0d0e21e
LW
1549 }
1550 }
4633a7c4 1551 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1552 if (gimme == G_ARRAY)
1553 RETURN;
1554 RETPUSHNO;
1555}
1556
1557OP *
864dbfa3 1558Perl_do_readline(pTHX)
a0d0e21e 1559{
27da23d5 1560 dVAR; dSP; dTARGETSTACKED;
a0d0e21e
LW
1561 register SV *sv;
1562 STRLEN tmplen = 0;
1563 STRLEN offset;
760ac839 1564 PerlIO *fp;
a3b680e6
AL
1565 register IO * const io = GvIO(PL_last_in_gv);
1566 register const I32 type = PL_op->op_type;
1567 const I32 gimme = GIMME_V;
a0d0e21e 1568
6136c704 1569 if (io) {
50db69d8 1570 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 1571 if (mg) {
50db69d8 1572 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 1573 if (gimme == G_SCALAR) {
50db69d8
NC
1574 SPAGAIN;
1575 SvSetSV_nosteal(TARG, TOPs);
1576 SETTARG;
6136c704 1577 }
50db69d8 1578 return NORMAL;
0b7c7b4f 1579 }
e79b0511 1580 }
4608196e 1581 fp = NULL;
a0d0e21e
LW
1582 if (io) {
1583 fp = IoIFP(io);
1584 if (!fp) {
1585 if (IoFLAGS(io) & IOf_ARGV) {
1586 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1587 IoLINES(io) = 0;
3280af22 1588 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1589 IoFLAGS(io) &= ~IOf_START;
4608196e 1590 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
76f68e9b 1591 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3280af22 1592 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1593 fp = IoIFP(io);
1594 goto have_fp;
a0d0e21e
LW
1595 }
1596 }
3280af22 1597 fp = nextargv(PL_last_in_gv);
a0d0e21e 1598 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1599 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1600 }
1601 }
0d44d22b
NC
1602 else if (type == OP_GLOB)
1603 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1604 }
1605 else if (type == OP_GLOB)
1606 SP--;
7716c5c5 1607 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 1608 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 1609 }
a0d0e21e
LW
1610 }
1611 if (!fp) {
041457d9
DM
1612 if ((!io || !(IoFLAGS(io) & IOf_START))
1613 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1614 {
3f4520fe 1615 if (type == OP_GLOB)
63922903 1616 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
af8c498a
GS
1617 "glob failed (can't start child: %s)",
1618 Strerror(errno));
69282e91 1619 else
831e4cc3 1620 report_evil_fh(PL_last_in_gv);
3f4520fe 1621 }
54310121 1622 if (gimme == G_SCALAR) {
79628082 1623 /* undef TARG, and push that undefined value */
ba92458f
AE
1624 if (type != OP_RCATLINE) {
1625 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1626 SvOK_off(TARG);
ba92458f 1627 }
a0d0e21e
LW
1628 PUSHTARG;
1629 }
1630 RETURN;
1631 }
a2008d6d 1632 have_fp:
54310121 1633 if (gimme == G_SCALAR) {
a0d0e21e 1634 sv = TARG;
0f722b55
RGS
1635 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1636 mg_get(sv);
48de12d9
RGS
1637 if (SvROK(sv)) {
1638 if (type == OP_RCATLINE)
5668452f 1639 SvPV_force_nomg_nolen(sv);
48de12d9
RGS
1640 else
1641 sv_unref(sv);
1642 }
f7877b28 1643 else if (isGV_with_GP(sv)) {
5668452f 1644 SvPV_force_nomg_nolen(sv);
f7877b28 1645 }
862a34c6 1646 SvUPGRADE(sv, SVt_PV);
a0d0e21e 1647 tmplen = SvLEN(sv); /* remember if already alloced */
f72e8700
JJ
1648 if (!tmplen && !SvREADONLY(sv)) {
1649 /* try short-buffering it. Please update t/op/readline.t
1650 * if you change the growth length.
1651 */
1652 Sv_Grow(sv, 80);
1653 }
2b5e58c4
AMS
1654 offset = 0;
1655 if (type == OP_RCATLINE && SvOK(sv)) {
1656 if (!SvPOK(sv)) {
5668452f 1657 SvPV_force_nomg_nolen(sv);
2b5e58c4 1658 }
a0d0e21e 1659 offset = SvCUR(sv);
2b5e58c4 1660 }
a0d0e21e 1661 }
54310121 1662 else {
561b68a9 1663 sv = sv_2mortal(newSV(80));
54310121
PP
1664 offset = 0;
1665 }
fbad3eb5 1666
3887d568
AP
1667 /* This should not be marked tainted if the fp is marked clean */
1668#define MAYBE_TAINT_LINE(io, sv) \
1669 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1670 TAINT; \
1671 SvTAINTED_on(sv); \
1672 }
1673
684bef36 1674/* delay EOF state for a snarfed empty file */
fbad3eb5 1675#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1676 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1677 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1678
a0d0e21e 1679 for (;;) {
09e8efcc 1680 PUTBACK;
fbad3eb5 1681 if (!sv_gets(sv, fp, offset)
2d726892
TF
1682 && (type == OP_GLOB
1683 || SNARF_EOF(gimme, PL_rs, io, sv)
1684 || PerlIO_error(fp)))
fbad3eb5 1685 {
760ac839 1686 PerlIO_clearerr(fp);
a0d0e21e 1687 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1688 fp = nextargv(PL_last_in_gv);
a0d0e21e
LW
1689 if (fp)
1690 continue;
3280af22 1691 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1692 }
1693 else if (type == OP_GLOB) {
a2a5de95
NC
1694 if (!do_close(PL_last_in_gv, FALSE)) {
1695 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1696 "glob failed (child exited with status %d%s)",
1697 (int)(STATUS_CURRENT >> 8),
1698 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1699 }
a0d0e21e 1700 }
54310121 1701 if (gimme == G_SCALAR) {
ba92458f
AE
1702 if (type != OP_RCATLINE) {
1703 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1704 SvOK_off(TARG);
ba92458f 1705 }
09e8efcc 1706 SPAGAIN;
a0d0e21e
LW
1707 PUSHTARG;
1708 }
3887d568 1709 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1710 RETURN;
1711 }
3887d568 1712 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1713 IoLINES(io)++;
b9fee9ba 1714 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1715 SvSETMAGIC(sv);
09e8efcc 1716 SPAGAIN;
a0d0e21e 1717 XPUSHs(sv);
a0d0e21e 1718 if (type == OP_GLOB) {
349d4f2f 1719 const char *t1;
a0d0e21e 1720
3280af22 1721 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 1722 char * const tmps = SvEND(sv) - 1;
aa07b2f6 1723 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 1724 *tmps = '\0';
b162af07 1725 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
1726 }
1727 }
349d4f2f 1728 for (t1 = SvPVX_const(sv); *t1; t1++)
937b2e03 1729 if (!isALNUMC(*t1) &&
349d4f2f 1730 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
a0d0e21e 1731 break;
349d4f2f 1732 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1733 (void)POPs; /* Unmatched wildcard? Chuck it... */
1734 continue;
1735 }
2d79bf7f 1736 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
1737 if (ckWARN(WARN_UTF8)) {
1738 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1739 const STRLEN len = SvCUR(sv) - offset;
1740 const U8 *f;
1741
1742 if (!is_utf8_string_loc(s, len, &f))
1743 /* Emulate :encoding(utf8) warning in the same case. */
1744 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1745 "utf8 \"\\x%02X\" does not map to Unicode",
1746 f < (U8*)SvEND(sv) ? *f : 0);
1747 }
a0d0e21e 1748 }
54310121 1749 if (gimme == G_ARRAY) {
a0d0e21e 1750 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 1751 SvPV_shrink_to_cur(sv);
a0d0e21e 1752 }
561b68a9 1753 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
1754 continue;
1755 }
54310121 1756 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 1757 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
1758 const STRLEN new_len
1759 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 1760 SvPV_renew(sv, new_len);
a0d0e21e
LW
1761 }
1762 RETURN;
1763 }
1764}
1765
a0d0e21e
LW
1766PP(pp_helem)
1767{
97aff369 1768 dVAR; dSP;
760ac839 1769 HE* he;
ae77835f 1770 SV **svp;
c445ea15 1771 SV * const keysv = POPs;
85fbaab2 1772 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
1773 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1774 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1775 SV *sv;
c158a4fd 1776 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
92970b93 1777 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 1778 bool preeminent = TRUE;
a0d0e21e 1779
d4c19fe8 1780 if (SvTYPE(hv) != SVt_PVHV)
a0d0e21e 1781 RETPUSHUNDEF;
d4c19fe8 1782
92970b93 1783 if (localizing) {
d4c19fe8
AL
1784 MAGIC *mg;
1785 HV *stash;
d30e492c
VP
1786
1787 /* If we can determine whether the element exist,
1788 * Try to preserve the existenceness of a tied hash
1789 * element by using EXISTS and DELETE if possible.
1790 * Fallback to FETCH and STORE otherwise. */
1791 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1792 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 1793 }
d30e492c 1794
d4c19fe8
AL
1795 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1796 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 1797 if (lval) {
746f6409 1798 if (!svp || !*svp || *svp == &PL_sv_undef) {
68dc0745
PP
1799 SV* lv;
1800 SV* key2;
2d8e6c8d 1801 if (!defer) {
be2597df 1802 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 1803 }
68dc0745
PP
1804 lv = sv_newmortal();
1805 sv_upgrade(lv, SVt_PVLV);
1806 LvTYPE(lv) = 'y';
6136c704 1807 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
68dc0745 1808 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
b37c2d43 1809 LvTARG(lv) = SvREFCNT_inc_simple(hv);
68dc0745
PP
1810 LvTARGLEN(lv) = 1;
1811 PUSHs(lv);
1812 RETURN;
1813 }
92970b93 1814 if (localizing) {
bfcb3514 1815 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 1816 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
1817 else if (preeminent)
1818 save_helem_flags(hv, keysv, svp,
1819 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1820 else
1821 SAVEHDELETE(hv, keysv);
5f05dabc 1822 }
9026059d
GG
1823 else if (PL_op->op_private & OPpDEREF) {
1824 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1825 RETURN;
1826 }
a0d0e21e 1827 }
746f6409 1828 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
1829 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1830 * was to make C<local $tied{foo} = $tied{foo}> possible.
1831 * However, it seems no longer to be needed for that purpose, and
1832 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1833 * would loop endlessly since the pos magic is getting set on the
1834 * mortal copy and lost. However, the copy has the effect of
1835 * triggering the get magic, and losing it altogether made things like
1836 * c<$tied{foo};> in void context no longer do get magic, which some
1837 * code relied on. Also, delayed triggering of magic on @+ and friends
1838 * meant the original regex may be out of scope by now. So as a
1839 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1840 * being called too many times). */
39cf747a 1841 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 1842 mg_get(sv);
be6c24e0 1843 PUSHs(sv);
a0d0e21e
LW
1844 RETURN;
1845}
1846
a0d0e21e
LW
1847PP(pp_iter)
1848{
97aff369 1849 dVAR; dSP;
c09156bb 1850 register PERL_CONTEXT *cx;
dc09a129 1851 SV *sv, *oldsv;
1d7c1841 1852 SV **itersvp;
d01136d6
BS
1853 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1854 bool av_is_stack = FALSE;
a0d0e21e 1855
924508f0 1856 EXTEND(SP, 1);
a0d0e21e 1857 cx = &cxstack[cxstack_ix];
3b719c58 1858 if (!CxTYPE_is_LOOP(cx))
5637ef5b 1859 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
a0d0e21e 1860
1d7c1841 1861 itersvp = CxITERVAR(cx);
d01136d6 1862 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
89ea2908 1863 /* string increment */
d01136d6
BS
1864 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1865 SV *end = cx->blk_loop.state_u.lazysv.end;
267cc4a8
NC
1866 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1867 It has SvPVX of "" and SvCUR of 0, which is what we want. */
4fe3f0fa 1868 STRLEN maxlen = 0;
d01136d6 1869 const char *max = SvPV_const(end, maxlen);
89ea2908 1870 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1d7c1841 1871 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1872 /* safe to reuse old SV */
1d7c1841 1873 sv_setsv(*itersvp, cur);
eaa5c2d6 1874 }
1c846c1f 1875 else
eaa5c2d6
GA
1876 {
1877 /* we need a fresh SV every time so that loop body sees a
1878 * completely new SV for closures/references to work as
1879 * they used to */
dc09a129 1880 oldsv = *itersvp;
1d7c1841 1881 *itersvp = newSVsv(cur);
dc09a129 1882 SvREFCNT_dec(oldsv);
eaa5c2d6 1883 }
aa07b2f6 1884 if (strEQ(SvPVX_const(cur), max))
89ea2908
GA
1885 sv_setiv(cur, 0); /* terminate next time */
1886 else
1887 sv_inc(cur);
1888 RETPUSHYES;
1889 }
1890 RETPUSHNO;
d01136d6
BS
1891 }
1892 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
89ea2908 1893 /* integer increment */
d01136d6 1894 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
89ea2908 1895 RETPUSHNO;
7f61b687 1896
3db8f154 1897 /* don't risk potential race */
1d7c1841 1898 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1899 /* safe to reuse old SV */
d01136d6 1900 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
eaa5c2d6 1901 }
1c846c1f 1902 else
eaa5c2d6
GA
1903 {
1904 /* we need a fresh SV every time so that loop body sees a
1905 * completely new SV for closures/references to work as they
1906 * used to */
dc09a129 1907 oldsv = *itersvp;
d01136d6 1908 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
dc09a129 1909 SvREFCNT_dec(oldsv);
eaa5c2d6 1910 }
a2309040
JH
1911
1912 /* Handle end of range at IV_MAX */
d01136d6
BS
1913 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1914 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
a2309040 1915 {
d01136d6
BS
1916 cx->blk_loop.state_u.lazyiv.cur++;
1917 cx->blk_loop.state_u.lazyiv.end++;
a2309040
JH
1918 }
1919
89ea2908
GA
1920 RETPUSHYES;
1921 }
1922
1923 /* iterate array */
d01136d6
BS
1924 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1925 av = cx->blk_loop.state_u.ary.ary;
1926 if (!av) {
1927 av_is_stack = TRUE;
1928 av = PL_curstack;
1929 }
ef3e5ea9 1930 if (PL_op->op_private & OPpITER_REVERSED) {
d01136d6
BS
1931 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1932 ? cx->blk_loop.resetsp + 1 : 0))
ef3e5ea9 1933 RETPUSHNO;
a0d0e21e 1934
ef3e5ea9 1935 if (SvMAGICAL(av) || AvREIFY(av)) {
d01136d6 1936 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
a0714e2c 1937 sv = svp ? *svp : NULL;
ef3e5ea9
NC
1938 }
1939 else {
d01136d6 1940 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
ef3e5ea9 1941 }
d42935ef
JH
1942 }
1943 else {
d01136d6 1944 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
ef3e5ea9
NC
1945 AvFILL(av)))
1946 RETPUSHNO;
1947
1948 if (SvMAGICAL(av) || AvREIFY(av)) {
d01136d6 1949 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
a0714e2c 1950 sv = svp ? *svp : NULL;
ef3e5ea9
NC
1951 }
1952 else {
d01136d6 1953 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
ef3e5ea9 1954 }
d42935ef 1955 }
ef3e5ea9 1956
0565a181 1957 if (sv && SvIS_FREED(sv)) {
a0714e2c 1958 *itersvp = NULL;
b6c83531 1959 Perl_croak(aTHX_ "Use of freed value in iteration");
cccede53
DM
1960 }
1961
d01136d6 1962 if (sv) {
a0d0e21e 1963 SvTEMP_off(sv);
d01136d6
BS
1964 SvREFCNT_inc_simple_void_NN(sv);
1965 }
a0d0e21e 1966 else
3280af22 1967 sv = &PL_sv_undef;
d01136d6
BS
1968 if (!av_is_stack && sv == &PL_sv_undef) {
1969 SV *lv = newSV_type(SVt_PVLV);
1970 LvTYPE(lv) = 'y';
1971 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
b37c2d43 1972 LvTARG(lv) = SvREFCNT_inc_simple(av);
d01136d6 1973 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
42718184 1974 LvTARGLEN(lv) = (STRLEN)UV_MAX;
d01136d6 1975 sv = lv;
5f05dabc 1976 }
a0d0e21e 1977
dc09a129 1978 oldsv = *itersvp;
d01136d6 1979 *itersvp = sv;
dc09a129
DM
1980 SvREFCNT_dec(oldsv);
1981
a0d0e21e
LW
1982 RETPUSHYES;
1983}
1984
ef07e810
DM
1985/*
1986A description of how taint works in pattern matching and substitution.
1987
4e19c54b 1988While the pattern is being assembled/concatenated and then compiled,
0ab462a6
DM
1989PL_tainted will get set if any component of the pattern is tainted, e.g.
1990/.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
1991is set on the pattern if PL_tainted is set.
ef07e810 1992
0ab462a6
DM
1993When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1994the pattern is marked as tainted. This means that subsequent usage, such
1995as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
ef07e810
DM
1996
1997During execution of a pattern, locale-variant ops such as ALNUML set the
1998local flag RF_tainted. At the end of execution, the engine sets the
0ab462a6
DM
1999RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2000otherwise.
ef07e810
DM
2001
2002In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2003of $1 et al to indicate whether the returned value should be tainted.
2004It is the responsibility of the caller of the pattern (i.e. pp_match,
2005pp_subst etc) to set this flag for any other circumstances where $1 needs
2006to be tainted.
2007
2008The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2009
2010There are three possible sources of taint
2011 * the source string
2012 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2013 * the replacement string (or expression under /e)
2014
2015There are four destinations of taint and they are affected by the sources
2016according to the rules below:
2017
2018 * the return value (not including /r):
2019 tainted by the source string and pattern, but only for the
2020 number-of-iterations case; boolean returns aren't tainted;
2021 * the modified string (or modified copy under /r):
2022 tainted by the source string, pattern, and replacement strings;
2023 * $1 et al:
2024 tainted by the pattern, and under 'use re "taint"', by the source
2025 string too;
2026 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2027 should always be unset before executing subsequent code.
2028
2029The overall action of pp_subst is:
2030
2031 * at the start, set bits in rxtainted indicating the taint status of
2032 the various sources.
2033
2034 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2035 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2036 pattern has subsequently become tainted via locale ops.
2037
2038 * If control is being passed to pp_substcont to execute a /e block,
2039 save rxtainted in the CXt_SUBST block, for future use by
2040 pp_substcont.
2041
2042 * Whenever control is being returned to perl code (either by falling
2043 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2044 use the flag bits in rxtainted to make all the appropriate types of
0ab462a6
DM
2045 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2046 et al will appear tainted.
ef07e810
DM
2047
2048pp_match is just a simpler version of the above.
2049
2050*/
2051
a0d0e21e
LW
2052PP(pp_subst)
2053{
97aff369 2054 dVAR; dSP; dTARG;
a0d0e21e
LW
2055 register PMOP *pm = cPMOP;
2056 PMOP *rpm = pm;
a0d0e21e
LW
2057 register char *s;
2058 char *strend;
2059 register char *m;
5c144d81 2060 const char *c;
a0d0e21e
LW
2061 register char *d;
2062 STRLEN clen;
2063 I32 iters = 0;
2064 I32 maxiters;
2065 register I32 i;
2066 bool once;
ef07e810
DM
2067 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2068 See "how taint works" above */
a0d0e21e 2069 char *orig;
1ed74d04 2070 U8 r_flags;
aaa362c4 2071 register REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
2072 STRLEN len;
2073 int force_on_match = 0;
0bcc34c2 2074 const I32 oldsave = PL_savestack_ix;
792b2c16 2075 STRLEN slen;
f272994b 2076 bool doutf8 = FALSE;
f8c7b90f 2077#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2078 bool is_cow;
2079#endif
a0714e2c 2080 SV *nsv = NULL;
b770e143
NC
2081 /* known replacement string? */
2082 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
a0d0e21e 2083
f410a211
NC
2084 PERL_ASYNC_CHECK();
2085
533c011a 2086 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 2087 TARG = POPs;
59f00321
RGS
2088 else if (PL_op->op_private & OPpTARGET_MY)
2089 GETTARGET;
a0d0e21e 2090 else {
54b9620d 2091 TARG = DEFSV;
a0d0e21e 2092 EXTEND(SP,1);
1c846c1f 2093 }
d9f424b2 2094
f8c7b90f 2095#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2096 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2097 because they make integers such as 256 "false". */
2098 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2099#else
765f542d
NC
2100 if (SvIsCOW(TARG))
2101 sv_force_normal_flags(TARG,0);
ed252734 2102#endif
8ca8a454 2103 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
f8c7b90f 2104#ifdef PERL_OLD_COPY_ON_WRITE
8ca8a454 2105 && !is_cow
ed252734 2106#endif
8ca8a454
NC
2107 && (SvREADONLY(TARG)
2108 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2109 || SvTYPE(TARG) > SVt_PVLV)
2110 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
6ad8f254 2111 Perl_croak_no_modify(aTHX);
8ec5e241
NIS
2112 PUTBACK;
2113
3e462cdc 2114 setup_match:
d5263905 2115 s = SvPV_mutable(TARG, len);
68dc0745 2116 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 2117 force_on_match = 1;
20be6587
DM
2118
2119 /* only replace once? */
2120 once = !(rpm->op_pmflags & PMf_GLOBAL);
2121
ef07e810 2122 /* See "how taint works" above */
20be6587
DM
2123 if (PL_tainting) {
2124 rxtainted = (
2125 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2126 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2127 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2128 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2129 ? SUBST_TAINT_BOOLRET : 0));
2130 TAINT_NOT;
2131 }
a12c0f56 2132
a30b2f1f 2133 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 2134
a0d0e21e
LW
2135 force_it:
2136 if (!pm || !s)
5637ef5b 2137 DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
a0d0e21e
LW
2138
2139 strend = s + len;
a30b2f1f 2140 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH
2141 maxiters = 2 * slen + 10; /* We can match twice at each
2142 position, once with zero-length,
2143 second time with non-zero. */
a0d0e21e 2144
220fc49f 2145 if (!RX_PRELEN(rx) && PL_curpm) {
3280af22 2146 pm = PL_curpm;
aaa362c4 2147 rx = PM_GETRE(pm);
a0d0e21e 2148 }
07bc277f
NC
2149 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2150 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
ed252734 2151 ? REXEC_COPY_STR : 0;
7fba1cd6 2152
a0d0e21e 2153 orig = m = s;
07bc277f 2154 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
ee0b7718 2155 PL_bostr = orig;
f9f4320a 2156 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
f722798b
IZ
2157
2158 if (!s)
df34c13a 2159 goto ret_no;
f722798b 2160 /* How to do it in subst? */
07bc277f 2161/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1c846c1f 2162 && !PL_sawampersand
a91cc451 2163 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
f722798b
IZ
2164 goto yup;
2165*/
a0d0e21e 2166 }
71be2cbc 2167
8b64c330
DM
2168 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2169 r_flags | REXEC_CHECKED))
2170 {
5e79dfb9
DM
2171 ret_no:
2172 SPAGAIN;
2173 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2174 LEAVE_SCOPE(oldsave);
2175 RETURN;
2176 }
2177
71be2cbc 2178 /* known replacement string? */
f272994b 2179 if (dstr) {
20be6587
DM
2180 if (SvTAINTED(dstr))
2181 rxtainted |= SUBST_TAINT_REPL;
3e462cdc
KW
2182
2183 /* Upgrade the source if the replacement is utf8 but the source is not,
2184 * but only if it matched; see
2185 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2186 */
5e79dfb9 2187 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
c95ca9b8
DM
2188 char * const orig_pvx = SvPVX(TARG);
2189 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
3e462cdc
KW
2190
2191 /* If the lengths are the same, the pattern contains only
2192 * invariants, can keep going; otherwise, various internal markers
2193 * could be off, so redo */
c95ca9b8 2194 if (new_len != len || orig_pvx != SvPVX(TARG)) {
3e462cdc
KW
2195 goto setup_match;
2196 }
2197 }
2198
8514a05a
JH
2199 /* replacement needing upgrading? */
2200 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2201 nsv = sv_newmortal();
4a176938 2202 SvSetSV(nsv, dstr);
8514a05a
JH
2203 if (PL_encoding)
2204 sv_recode_to_utf8(nsv, PL_encoding);
2205 else
2206 sv_utf8_upgrade(nsv);
5c144d81 2207 c = SvPV_const(nsv, clen);
4a176938
JH
2208 doutf8 = TRUE;
2209 }
2210 else {
5c144d81 2211 c = SvPV_const(dstr, clen);
4a176938 2212 doutf8 = DO_UTF8(dstr);
8514a05a 2213 }
f272994b
A
2214 }
2215 else {
6136c704 2216 c = NULL;
f272994b
A
2217 doutf8 = FALSE;
2218 }
2219
71be2cbc 2220 /* can do inplace substitution? */
ed252734 2221 if (c
f8c7b90f 2222#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2223 && !is_cow
2224#endif
07bc277f
NC
2225 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2226 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
8ca8a454
NC
2227 && (!doutf8 || SvUTF8(TARG))
2228 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
8b030b38 2229 {
ec911639 2230
f8c7b90f 2231#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2232 if (SvIsCOW(TARG)) {
2233 assert (!force_on_match);
2234 goto have_a_cow;
2235 }
2236#endif
71be2cbc
PP
2237 if (force_on_match) {
2238 force_on_match = 0;
2239 s = SvPV_force(TARG, len);
2240 goto force_it;
2241 }
71be2cbc 2242 d = s;
3280af22 2243 PL_curpm = pm;
71be2cbc 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)++;
3a76ca88
RGS
2688 if (CvDEPTH(cv) >= 2) {
2689 PERL_STACK_OVERFLOW_CHECK();
2690 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2691 }
3a76ca88
RGS
2692 SAVECOMPPAD();
2693 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2694 if (hasargs) {
10533ace 2695 AV *const av = MUTABLE_AV(PAD_SVl(0));
221373f0
GS
2696 if (AvREAL(av)) {
2697 /* @_ is normally not REAL--this should only ever
2698 * happen when DB::sub() calls things that modify @_ */
2699 av_clear(av);
2700 AvREAL_off(av);
2701 AvREIFY_on(av);
2702 }
3280af22 2703 cx->blk_sub.savearray = GvAV(PL_defgv);
502c6561 2704 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
dd2155a4 2705 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2706 cx->blk_sub.argarray = av;
a0d0e21e
LW
2707 ++MARK;
2708
2709 if (items > AvMAX(av) + 1) {
504618e9 2710 SV **ary = AvALLOC(av);
a0d0e21e
LW
2711 if (AvARRAY(av) != ary) {
2712 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 2713 AvARRAY(av) = ary;
a0d0e21e
LW
2714 }
2715 if (items > AvMAX(av) + 1) {
2716 AvMAX(av) = items - 1;
2717 Renew(ary,items,SV*);
2718 AvALLOC(av) = ary;
9c6bc640 2719 AvARRAY(av) = ary;
a0d0e21e
LW
2720 }
2721 }
2722 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2723 AvFILLp(av) = items - 1;
1c846c1f 2724
a0d0e21e
LW
2725 while (items--) {
2726 if (*MARK)
2727 SvTEMP_off(*MARK);
2728 MARK++;
2729 }
2730 }
da1dff94
FC
2731 if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2732 !CvLVALUE(cv))
2733 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
4a925ff6
GS
2734 /* warning must come *after* we fully set up the context
2735 * stuff so that __WARN__ handlers can safely dounwind()
2736 * if they want to
2737 */
2b9dff67 2738 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
4a925ff6
GS
2739 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2740 sub_crush_depth(cv);
a0d0e21e
LW
2741 RETURNOP(CvSTART(cv));
2742 }
f1025168 2743 else {
3a76ca88 2744 I32 markix = TOPMARK;
f1025168 2745
3a76ca88 2746 PUTBACK;
f1025168 2747
3a76ca88
RGS
2748 if (!hasargs) {
2749 /* Need to copy @_ to stack. Alternative may be to
2750 * switch stack to @_, and copy return values
2751 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2752 AV * const av = GvAV(PL_defgv);
2753 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2754
2755 if (items) {
2756 /* Mark is at the end of the stack. */
2757 EXTEND(SP, items);
2758 Copy(AvARRAY(av), SP + 1, items, SV*);
2759 SP += items;
2760 PUTBACK ;
2761 }
2762 }
2763 /* We assume first XSUB in &DB::sub is the called one. */
2764 if (PL_curcopdb) {
2765 SAVEVPTR(PL_curcop);
2766 PL_curcop = PL_curcopdb;
2767 PL_curcopdb = NULL;
2768 }
2769 /* Do we need to open block here? XXXX */
72df79cf 2770
2771 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2772 assert(CvXSUB(cv));
16c91539 2773 CvXSUB(cv)(aTHX_ cv);
3a76ca88
RGS
2774
2775 /* Enforce some sanity in scalar context. */
2776 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2777 if (markix > PL_stack_sp - PL_stack_base)
2778 *(PL_stack_base + markix) = &PL_sv_undef;
2779 else
2780 *(PL_stack_base + markix) = *PL_stack_sp;
2781 PL_stack_sp = PL_stack_base + markix;
2782 }
a57c6685 2783 LEAVE;
f1025168
NC
2784 return NORMAL;
2785 }
a0d0e21e
LW
2786}
2787
44a8e56a 2788void
864dbfa3 2789Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 2790{
7918f24d
NC
2791 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2792
44a8e56a 2793 if (CvANON(cv))
9014280d 2794 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 2795 else {
aec46f14 2796 SV* const tmpstr = sv_newmortal();
6136c704 2797 gv_efullname3(tmpstr, CvGV(cv), NULL);
35c1215d 2798 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
be2597df 2799 SVfARG(tmpstr));
44a8e56a
PP
2800 }
2801}
2802
a0d0e21e
LW
2803PP(pp_aelem)
2804{
97aff369 2805 dVAR; dSP;
a0d0e21e 2806 SV** svp;
a3b680e6 2807 SV* const elemsv = POPs;
d804643f 2808 IV elem = SvIV(elemsv);
502c6561 2809 AV *const av = MUTABLE_AV(POPs);
e1ec3a88
AL
2810 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2811 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
4ad10a0b
VP
2812 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2813 bool preeminent = TRUE;
be6c24e0 2814 SV *sv;
a0d0e21e 2815
e35c1634 2816 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
95b63a38
JH
2817 Perl_warner(aTHX_ packWARN(WARN_MISC),
2818 "Use of reference \"%"SVf"\" as array index",
be2597df 2819 SVfARG(elemsv));
a0d0e21e
LW
2820 if (SvTYPE(av) != SVt_PVAV)
2821 RETPUSHUNDEF;
4ad10a0b
VP
2822
2823 if (localizing) {
2824 MAGIC *mg;
2825 HV *stash;
2826
2827 /* If we can determine whether the element exist,
2828 * Try to preserve the existenceness of a tied array
2829 * element by using EXISTS and DELETE if possible.
2830 * Fallback to FETCH and STORE otherwise. */
2831 if (SvCANEXISTDELETE(av))
2832 preeminent = av_exists(av, elem);
2833 }
2834
68dc0745 2835 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2836 if (lval) {
2b573ace 2837#ifdef PERL_MALLOC_WRAP
2b573ace 2838 if (SvUOK(elemsv)) {
a9c4fd4e 2839 const UV uv = SvUV(elemsv);
2b573ace
JH
2840 elem = uv > IV_MAX ? IV_MAX : uv;
2841 }
2842 else if (SvNOK(elemsv))
2843 elem = (IV)SvNV(elemsv);
a3b680e6
AL
2844 if (elem > 0) {
2845 static const char oom_array_extend[] =
2846 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 2847 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 2848 }
2b573ace 2849#endif
3280af22 2850 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2851 SV* lv;
2852 if (!defer)
cea2e8a9 2853 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2854 lv = sv_newmortal();
2855 sv_upgrade(lv, SVt_PVLV);
2856 LvTYPE(lv) = 'y';
a0714e2c 2857 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
b37c2d43 2858 LvTARG(lv) = SvREFCNT_inc_simple(av);
68dc0745
PP
2859 LvTARGOFF(lv) = elem;
2860 LvTARGLEN(lv) = 1;
2861 PUSHs(lv);
2862 RETURN;
2863 }
4ad10a0b
VP
2864 if (localizing) {
2865 if (preeminent)
2866 save_aelem(av, elem, svp);
2867 else
2868 SAVEADELETE(av, elem);
2869 }
9026059d
GG
2870 else if (PL_op->op_private & OPpDEREF) {
2871 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2872 RETURN;
2873 }
a0d0e21e 2874 }
3280af22 2875 sv = (svp ? *svp : &PL_sv_undef);
39cf747a 2876 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 2877 mg_get(sv);
be6c24e0 2878 PUSHs(sv);
a0d0e21e
LW
2879 RETURN;
2880}
2881
9026059d 2882SV*
864dbfa3 2883Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 2884{
7918f24d
NC
2885 PERL_ARGS_ASSERT_VIVIFY_REF;
2886
5b295bef 2887 SvGETMAGIC(sv);
02a9e968
CS
2888 if (!SvOK(sv)) {
2889 if (SvREADONLY(sv))
6ad8f254 2890 Perl_croak_no_modify(aTHX);
43230e26 2891 prepare_SV_for_RV(sv);
68dc0745 2892 switch (to_what) {
5f05dabc 2893 case OPpDEREF_SV:
561b68a9 2894 SvRV_set(sv, newSV(0));
5f05dabc
PP
2895 break;
2896 case OPpDEREF_AV:
ad64d0ec 2897 SvRV_set(sv, MUTABLE_SV(newAV()));
5f05dabc
PP
2898 break;
2899 case OPpDEREF_HV:
ad64d0ec 2900 SvRV_set(sv, MUTABLE_SV(newHV()));
5f05dabc
PP
2901 break;
2902 }
02a9e968
CS
2903 SvROK_on(sv);
2904 SvSETMAGIC(sv);
7e482323 2905 SvGETMAGIC(sv);
02a9e968 2906 }
9026059d
GG
2907 if (SvGMAGICAL(sv)) {
2908 /* copy the sv without magic to prevent magic from being
2909 executed twice */
2910 SV* msv = sv_newmortal();
2911 sv_setsv_nomg(msv, sv);
2912 return msv;
2913 }
2914 return sv;
02a9e968
CS
2915}
2916
a0d0e21e
LW
2917PP(pp_method)
2918{
97aff369 2919 dVAR; dSP;
890ce7af 2920 SV* const sv = TOPs;
f5d5a27c
CS
2921
2922 if (SvROK(sv)) {
890ce7af 2923 SV* const rsv = SvRV(sv);
f5d5a27c
CS
2924 if (SvTYPE(rsv) == SVt_PVCV) {
2925 SETs(rsv);
2926 RETURN;
2927 }
2928 }
2929
4608196e 2930 SETs(method_common(sv, NULL));
f5d5a27c
CS
2931 RETURN;
2932}
2933
2934PP(pp_method_named)
2935{
97aff369 2936 dVAR; dSP;
890ce7af 2937 SV* const sv = cSVOP_sv;
c158a4fd 2938 U32 hash = SvSHARED_HASH(sv);
f5d5a27c
CS
2939
2940 XPUSHs(method_common(sv, &hash));
2941 RETURN;
2942}
2943
2944STATIC SV *
2945S_method_common(pTHX_ SV* meth, U32* hashp)
2946{
97aff369 2947 dVAR;
a0d0e21e
LW
2948 SV* ob;
2949 GV* gv;
56304f61 2950 HV* stash;
a0714e2c 2951 SV *packsv = NULL;
f226e9be
FC
2952 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2953 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2954 "package or object reference", SVfARG(meth)),
2955 (SV *)NULL)
2956 : *(PL_stack_base + TOPMARK + 1);
f5d5a27c 2957
7918f24d
NC
2958 PERL_ARGS_ASSERT_METHOD_COMMON;
2959
4f1b7578 2960 if (!sv)
a214957f
VP
2961 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2962 SVfARG(meth));
4f1b7578 2963
5b295bef 2964 SvGETMAGIC(sv);
a0d0e21e 2965 if (SvROK(sv))
ad64d0ec 2966 ob = MUTABLE_SV(SvRV(sv));
a0d0e21e
LW
2967 else {
2968 GV* iogv;
f937af42
BF
2969 STRLEN packlen;
2970 const char * packname = NULL;
da6b625f 2971 bool packname_is_utf8 = FALSE;
a0d0e21e 2972
af09ea45 2973 /* this isn't a reference */
da6b625f
FC
2974 if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2975 const HE* const he =
2976 (const HE *)hv_common_key_len(
2977 PL_stashcache, packname,
2978 packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2979 );
2980
081fc587 2981 if (he) {
5e6396ae 2982 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
081fc587
AB
2983 goto fetch;
2984 }
2985 }
2986
a0d0e21e 2987 if (!SvOK(sv) ||
05f5af9a 2988 !(packname) ||
da6b625f
FC
2989 !(iogv = gv_fetchpvn_flags(
2990 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2991 )) ||
ad64d0ec 2992 !(ob=MUTABLE_SV(GvIO(iogv))))
a0d0e21e 2993 {
af09ea45 2994 /* this isn't the name of a filehandle either */
1c846c1f 2995 if (!packname ||
fd400ab9 2996 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 2997 ? !isIDFIRST_utf8((U8*)packname)
d47f310d 2998 : !isIDFIRST_L1((U8)*packname)
834a4ddd
LW
2999 ))
3000 {
d5e45555 3001 /* diag_listed_as: Can't call method "%s" without a package or object reference */
a214957f
VP
3002 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3003 SVfARG(meth),
f5d5a27c
CS
3004 SvOK(sv) ? "without a package or object reference"
3005 : "on an undefined value");
834a4ddd 3006 }
af09ea45 3007 /* assume it's a package name */
f937af42 3008 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
0dae17bd
GS
3009 if (!stash)
3010 packsv = sv;
081fc587 3011 else {
d4c19fe8 3012 SV* const ref = newSViv(PTR2IV(stash));
f937af42 3013 (void)hv_store(PL_stashcache, packname,
c60dbbc3 3014 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
7e8961ec 3015 }
ac91690f 3016 goto fetch;
a0d0e21e 3017 }
af09ea45 3018 /* it _is_ a filehandle name -- replace with a reference */
ad64d0ec 3019 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
a0d0e21e
LW
3020 }
3021
af09ea45 3022 /* if we got here, ob should be a reference or a glob */
f0d43078 3023 if (!ob || !(SvOBJECT(ob)
6e592b3a
BM
3024 || (SvTYPE(ob) == SVt_PVGV
3025 && isGV_with_GP(ob)
159b6efe 3026 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
f0d43078
GS
3027 && SvOBJECT(ob))))
3028 {
b375e37b
BF
3029 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3030 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3031 ? newSVpvs_flags("DOES", SVs_TEMP)
3032 : meth));
f0d43078 3033 }
a0d0e21e 3034
56304f61 3035 stash = SvSTASH(ob);
a0d0e21e 3036
ac91690f 3037 fetch:
af09ea45
IK
3038 /* NOTE: stash may be null, hope hv_fetch_ent and
3039 gv_fetchmethod can cope (it seems they can) */
3040
f5d5a27c
CS
3041 /* shortcut for simple names */
3042 if (hashp) {
b464bac0 3043 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
f5d5a27c 3044 if (he) {
159b6efe 3045 gv = MUTABLE_GV(HeVAL(he));
f5d5a27c 3046 if (isGV(gv) && GvCV(gv) &&
e1a479c5 3047 (!GvCVGEN(gv) || GvCVGEN(gv)
dd69841b 3048 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
ad64d0ec 3049 return MUTABLE_SV(GvCV(gv));
f5d5a27c
CS
3050 }
3051 }
3052
f937af42
BF
3053 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3054 meth, GV_AUTOLOAD | GV_CROAK);
9b9d0b15 3055
256d1bb2 3056 assert(gv);
9b9d0b15 3057
ad64d0ec 3058 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
a0d0e21e 3059}
241d1a3b
NC
3060
3061/*
3062 * Local variables:
3063 * c-indentation-style: bsd
3064 * c-basic-offset: 4
14d04a33 3065 * indent-tabs-mode: nil
241d1a3b
NC
3066 * End:
3067 *
14d04a33 3068 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3069 */