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