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