This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
stop $foo =~ /(bar)/g skipping copy
[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;
eb578fdb 402 SV* sv;
6136c704 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. */
eb578fdb 516 UV auv = 0;
9c5ffd7c 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 {
eb578fdb 532 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;
eb578fdb 546 UV buv;
800401ee 547 bool buvok = SvUOK(svr);
a00b5bd3 548
7dca457a 549 if (buvok)
800401ee 550 buv = SvUVX(svr);
7dca457a 551 else {
eb578fdb 552 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;
eb578fdb 671 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);
3da99855
FC
780 else if (PL_op->op_flags & OPf_MOD
781 && PL_op->op_private & OPpLVAL_INTRO)
782 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e 783 }
9f527363 784 else if (SvTYPE(sv) != type) {
67955e0c 785 GV *gv;
1c846c1f 786
6e592b3a 787 if (!isGV_with_GP(sv)) {
dc3c76f8
NC
788 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
789 type, &sp);
790 if (!gv)
791 RETURN;
35cd451c
GS
792 }
793 else {
159b6efe 794 gv = MUTABLE_GV(sv);
a0d0e21e 795 }
ad64d0ec 796 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 797 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 798 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
9f527363
FC
799 }
800 if (PL_op->op_flags & OPf_REF) {
17ab7946 801 SETs(sv);
a0d0e21e 802 RETURN;
9f527363
FC
803 }
804 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
40c94d11
FC
805 const I32 flags = is_lvalue_sub();
806 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 807 if (gimme != G_ARRAY)
042560a6 808 goto croak_cant_return;
17ab7946 809 SETs(sv);
78f9721b 810 RETURN;
40c94d11 811 }
a0d0e21e
LW
812 }
813
17ab7946 814 if (is_pp_rv2av) {
502c6561 815 AV *const av = MUTABLE_AV(sv);
486ec47a 816 /* The guts of pp_rv2av, with no intending change to preserve history
17ab7946
NC
817 (until such time as we get tools that can do blame annotation across
818 whitespace changes. */
96913b52
VP
819 if (gimme == G_ARRAY) {
820 const I32 maxarg = AvFILL(av) + 1;
821 (void)POPs; /* XXXX May be optimized away? */
822 EXTEND(SP, maxarg);
823 if (SvRMAGICAL(av)) {
824 U32 i;
825 for (i=0; i < (U32)maxarg; i++) {
826 SV ** const svp = av_fetch(av, i, FALSE);
827 /* See note in pp_helem, and bug id #27839 */
828 SP[i+1] = svp
829 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
830 : &PL_sv_undef;
831 }
832 }
833 else {
834 Copy(AvARRAY(av), SP+1, maxarg, SV*);
93965878 835 }
96913b52 836 SP += maxarg;
1c846c1f 837 }
96913b52
VP
838 else if (gimme == G_SCALAR) {
839 dTARGET;
840 const I32 maxarg = AvFILL(av) + 1;
841 SETi(maxarg);
93965878 842 }
17ab7946
NC
843 } else {
844 /* The guts of pp_rv2hv */
96913b52
VP
845 if (gimme == G_ARRAY) { /* array wanted */
846 *PL_stack_sp = sv;
981b7185 847 return Perl_do_kv(aTHX);
96913b52 848 }
c8fe3bdf 849 else if ((PL_op->op_private & OPpTRUEBOOL
adc42c31 850 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
c8fe3bdf
FC
851 && block_gimme() == G_VOID ))
852 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
853 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
96913b52
VP
854 else if (gimme == G_SCALAR) {
855 dTARGET;
856 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
857 SPAGAIN;
858 SETTARG;
859 }
17ab7946 860 }
be85d344 861 RETURN;
042560a6
NC
862
863 croak_cant_return:
864 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
865 is_pp_rv2av ? "array" : "hash");
77e217c6 866 RETURN;
a0d0e21e
LW
867}
868
10c8fecd
GS
869STATIC void
870S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
871{
97aff369 872 dVAR;
7918f24d
NC
873
874 PERL_ARGS_ASSERT_DO_ODDBALL;
875
10c8fecd
GS
876 if (*relem) {
877 SV *tmpstr;
b464bac0 878 const HE *didstore;
6d822dc4
MS
879
880 if (ckWARN(WARN_MISC)) {
a3b680e6 881 const char *err;
10c8fecd
GS
882 if (relem == firstrelem &&
883 SvROK(*relem) &&
884 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
885 SvTYPE(SvRV(*relem)) == SVt_PVHV))
886 {
a3b680e6 887 err = "Reference found where even-sized list expected";
10c8fecd
GS
888 }
889 else
a3b680e6 890 err = "Odd number of elements in hash assignment";
f1f66076 891 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
10c8fecd 892 }
6d822dc4 893
561b68a9 894 tmpstr = newSV(0);
6d822dc4
MS
895 didstore = hv_store_ent(hash,*relem,tmpstr,0);
896 if (SvMAGICAL(hash)) {
897 if (SvSMAGICAL(tmpstr))
898 mg_set(tmpstr);
899 if (!didstore)
900 sv_2mortal(tmpstr);
901 }
902 TAINT_NOT;
10c8fecd
GS
903 }
904}
905
a0d0e21e
LW
906PP(pp_aassign)
907{
27da23d5 908 dVAR; dSP;
3280af22
NIS
909 SV **lastlelem = PL_stack_sp;
910 SV **lastrelem = PL_stack_base + POPMARK;
911 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
912 SV **firstlelem = lastrelem + 1;
913
eb578fdb
KW
914 SV **relem;
915 SV **lelem;
a0d0e21e 916
eb578fdb
KW
917 SV *sv;
918 AV *ary;
a0d0e21e 919
54310121 920 I32 gimme;
a0d0e21e
LW
921 HV *hash;
922 I32 i;
923 int magic;
ca65944e 924 int duplicates = 0;
cbbf8932 925 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
5637b936 926
3280af22 927 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
ca65944e 928 gimme = GIMME_V;
a0d0e21e
LW
929
930 /* If there's a common identifier on both sides we have to take
931 * special care that assigning the identifier on the left doesn't
932 * clobber a value on the right that's used later in the list.
acdea6f0 933 * Don't bother if LHS is just an empty hash or array.
a0d0e21e 934 */
acdea6f0
DM
935
936 if ( (PL_op->op_private & OPpASSIGN_COMMON)
937 && (
938 firstlelem != lastlelem
939 || ! ((sv = *firstlelem))
940 || SvMAGICAL(sv)
941 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
942 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1b95d04f 943 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
acdea6f0
DM
944 )
945 ) {
cc5e57d2 946 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd 947 for (relem = firstrelem; relem <= lastrelem; relem++) {
155aba94 948 if ((sv = *relem)) {
a1f49e72 949 TAINT_NOT; /* Each item is independent */
61e5f455
NC
950
951 /* Dear TODO test in t/op/sort.t, I love you.
952 (It's relying on a panic, not a "semi-panic" from newSVsv()
953 and then an assertion failure below.) */
954 if (SvIS_FREED(sv)) {
955 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
956 (void*)sv);
957 }
958 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
959 and we need a second copy of a temp here. */
960 *relem = sv_2mortal(newSVsv(sv));
a1f49e72 961 }
10c8fecd 962 }
a0d0e21e
LW
963 }
964
965 relem = firstrelem;
966 lelem = firstlelem;
4608196e
RGS
967 ary = NULL;
968 hash = NULL;
10c8fecd 969
a0d0e21e 970 while (lelem <= lastlelem) {
bbce6d69 971 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e
LW
972 sv = *lelem++;
973 switch (SvTYPE(sv)) {
974 case SVt_PVAV:
60edcf09 975 ary = MUTABLE_AV(sv);
748a9306 976 magic = SvMAGICAL(ary) != 0;
60edcf09
FC
977 ENTER;
978 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 979 av_clear(ary);
7e42bd57 980 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
981 i = 0;
982 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 983 SV **didstore;
a0d0e21e 984 assert(*relem);
4f0556e9
NC
985 sv = newSV(0);
986 sv_setsv(sv, *relem);
a0d0e21e 987 *(relem++) = sv;
5117ca91
GS
988 didstore = av_store(ary,i++,sv);
989 if (magic) {
8ef24240 990 if (SvSMAGICAL(sv))
fb73857a 991 mg_set(sv);
5117ca91 992 if (!didstore)
8127e0e3 993 sv_2mortal(sv);
5117ca91 994 }
bbce6d69 995 TAINT_NOT;
a0d0e21e 996 }
354b0578 997 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 998 SvSETMAGIC(MUTABLE_SV(ary));
60edcf09 999 LEAVE;
a0d0e21e 1000 break;
10c8fecd 1001 case SVt_PVHV: { /* normal hash */
a0d0e21e 1002 SV *tmpstr;
45960564 1003 SV** topelem = relem;
a0d0e21e 1004
60edcf09 1005 hash = MUTABLE_HV(sv);
748a9306 1006 magic = SvMAGICAL(hash) != 0;
60edcf09
FC
1007 ENTER;
1008 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1009 hv_clear(hash);
ca65944e 1010 firsthashrelem = relem;
a0d0e21e
LW
1011
1012 while (relem < lastrelem) { /* gobble up all the rest */
5117ca91 1013 HE *didstore;
6136c704
AL
1014 sv = *relem ? *relem : &PL_sv_no;
1015 relem++;
561b68a9 1016 tmpstr = newSV(0);
a0d0e21e
LW
1017 if (*relem)
1018 sv_setsv(tmpstr,*relem); /* value */
45960564
DM
1019 relem++;
1020 if (gimme != G_VOID) {
1021 if (hv_exists_ent(hash, sv, 0))
1022 /* key overwrites an existing entry */
1023 duplicates += 2;
1024 else
1025 if (gimme == G_ARRAY) {
1026 /* copy element back: possibly to an earlier
1027 * stack location if we encountered dups earlier */
1028 *topelem++ = sv;
1029 *topelem++ = tmpstr;
1030 }
1031 }
5117ca91
GS
1032 didstore = hv_store_ent(hash,sv,tmpstr,0);
1033 if (magic) {
8ef24240 1034 if (SvSMAGICAL(tmpstr))
fb73857a 1035 mg_set(tmpstr);
5117ca91 1036 if (!didstore)
8127e0e3 1037 sv_2mortal(tmpstr);
5117ca91 1038 }
bbce6d69 1039 TAINT_NOT;
8e07c86e 1040 }
6a0deba8 1041 if (relem == lastrelem) {
10c8fecd 1042 do_oddball(hash, relem, firstrelem);
6a0deba8 1043 relem++;
1930e939 1044 }
60edcf09 1045 LEAVE;
a0d0e21e
LW
1046 }
1047 break;
1048 default:
6fc92669
GS
1049 if (SvIMMORTAL(sv)) {
1050 if (relem <= lastrelem)
1051 relem++;
1052 break;
a0d0e21e
LW
1053 }
1054 if (relem <= lastrelem) {
1c70fb82
FC
1055 if (
1056 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1057 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1058 )
1059 Perl_warner(aTHX_
1060 packWARN(WARN_MISC),
1061 "Useless assignment to a temporary"
1062 );
a0d0e21e
LW
1063 sv_setsv(sv, *relem);
1064 *(relem++) = sv;
1065 }
1066 else
3280af22 1067 sv_setsv(sv, &PL_sv_undef);
8ef24240 1068 SvSETMAGIC(sv);
a0d0e21e
LW
1069 break;
1070 }
1071 }
3280af22 1072 if (PL_delaymagic & ~DM_DELAY) {
985213f2
AB
1073 /* Will be used to set PL_tainting below */
1074 UV tmp_uid = PerlProc_getuid();
1075 UV tmp_euid = PerlProc_geteuid();
1076 UV tmp_gid = PerlProc_getgid();
1077 UV tmp_egid = PerlProc_getegid();
1078
3280af22 1079 if (PL_delaymagic & DM_UID) {
a0d0e21e 1080#ifdef HAS_SETRESUID
985213f2
AB
1081 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1082 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
fb934a90 1083 (Uid_t)-1);
56febc5e
AD
1084#else
1085# ifdef HAS_SETREUID
985213f2
AB
1086 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1087 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
56febc5e
AD
1088# else
1089# ifdef HAS_SETRUID
b28d0864 1090 if ((PL_delaymagic & DM_UID) == DM_RUID) {
985213f2 1091 (void)setruid(PL_delaymagic_uid);
b28d0864 1092 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1093 }
56febc5e
AD
1094# endif /* HAS_SETRUID */
1095# ifdef HAS_SETEUID
b28d0864 1096 if ((PL_delaymagic & DM_UID) == DM_EUID) {
985213f2 1097 (void)seteuid(PL_delaymagic_euid);
b28d0864 1098 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1099 }
56febc5e 1100# endif /* HAS_SETEUID */
b28d0864 1101 if (PL_delaymagic & DM_UID) {
985213f2 1102 if (PL_delaymagic_uid != PL_delaymagic_euid)
cea2e8a9 1103 DIE(aTHX_ "No setreuid available");
985213f2 1104 (void)PerlProc_setuid(PL_delaymagic_uid);
a0d0e21e 1105 }
56febc5e
AD
1106# endif /* HAS_SETREUID */
1107#endif /* HAS_SETRESUID */
985213f2
AB
1108 tmp_uid = PerlProc_getuid();
1109 tmp_euid = PerlProc_geteuid();
a0d0e21e 1110 }
3280af22 1111 if (PL_delaymagic & DM_GID) {
a0d0e21e 1112#ifdef HAS_SETRESGID
985213f2
AB
1113 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1114 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
fb934a90 1115 (Gid_t)-1);
56febc5e
AD
1116#else
1117# ifdef HAS_SETREGID
985213f2
AB
1118 (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1119 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
56febc5e
AD
1120# else
1121# ifdef HAS_SETRGID
b28d0864 1122 if ((PL_delaymagic & DM_GID) == DM_RGID) {
985213f2 1123 (void)setrgid(PL_delaymagic_gid);
b28d0864 1124 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1125 }
56febc5e
AD
1126# endif /* HAS_SETRGID */
1127# ifdef HAS_SETEGID
b28d0864 1128 if ((PL_delaymagic & DM_GID) == DM_EGID) {
985213f2 1129 (void)setegid(PL_delaymagic_egid);
b28d0864 1130 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1131 }
56febc5e 1132# endif /* HAS_SETEGID */
b28d0864 1133 if (PL_delaymagic & DM_GID) {
985213f2 1134 if (PL_delaymagic_gid != PL_delaymagic_egid)
cea2e8a9 1135 DIE(aTHX_ "No setregid available");
985213f2 1136 (void)PerlProc_setgid(PL_delaymagic_gid);
a0d0e21e 1137 }
56febc5e
AD
1138# endif /* HAS_SETREGID */
1139#endif /* HAS_SETRESGID */
985213f2
AB
1140 tmp_gid = PerlProc_getgid();
1141 tmp_egid = PerlProc_getegid();
a0d0e21e 1142 }
985213f2 1143 PL_tainting |= (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid));
a0d0e21e 1144 }
3280af22 1145 PL_delaymagic = 0;
54310121 1146
54310121
PP
1147 if (gimme == G_VOID)
1148 SP = firstrelem - 1;
1149 else if (gimme == G_SCALAR) {
1150 dTARGET;
1151 SP = firstrelem;
ca65944e 1152 SETi(lastrelem - firstrelem + 1 - duplicates);
54310121
PP
1153 }
1154 else {
ca65944e 1155 if (ary)
a0d0e21e 1156 SP = lastrelem;
ca65944e
RGS
1157 else if (hash) {
1158 if (duplicates) {
45960564
DM
1159 /* at this point we have removed the duplicate key/value
1160 * pairs from the stack, but the remaining values may be
1161 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1162 * the (a 2), but the stack now probably contains
1163 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1164 * obliterates the earlier key. So refresh all values. */
ca65944e 1165 lastrelem -= duplicates;
45960564
DM
1166 relem = firsthashrelem;
1167 while (relem < lastrelem) {
1168 HE *he;
1169 sv = *relem++;
1170 he = hv_fetch_ent(hash, sv, 0, 0);
1171 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1172 }
ca65944e
RGS
1173 }
1174 SP = lastrelem;
1175 }
a0d0e21e
LW
1176 else
1177 SP = firstrelem + (lastlelem - firstlelem);
0c8c7a05 1178 lelem = firstlelem + (relem - firstrelem);
5f05dabc 1179 while (relem <= SP)
3280af22 1180 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
a0d0e21e 1181 }
08aeb9f7 1182
54310121 1183 RETURN;
a0d0e21e
LW
1184}
1185
8782bef2
GB
1186PP(pp_qr)
1187{
97aff369 1188 dVAR; dSP;
eb578fdb 1189 PMOP * const pm = cPMOP;
fe578d7f 1190 REGEXP * rx = PM_GETRE(pm);
10599a69 1191 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
c4420975 1192 SV * const rv = sv_newmortal();
d63c20f2
DM
1193 CV **cvp;
1194 CV *cv;
288b8c02
NC
1195
1196 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
1197 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1198 loathe to use it here, but it seems to be the right fix. Or close.
1199 The key part appears to be that it's essential for pp_qr to return a new
1200 object (SV), which implies that there needs to be an effective way to
1201 generate a new SV from the existing SV that is pre-compiled in the
1202 optree. */
1203 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
1204 SvROK_on(rv);
1205
d63c20f2
DM
1206 cvp = &( ((struct regexp*)SvANY(SvRV(rv)))->qr_anoncv);
1207 if ((cv = *cvp) && CvCLONE(*cvp)) {
1208 *cvp = cv_clone(cv);
1209 SvREFCNT_dec(cv);
1210 }
1211
288b8c02 1212 if (pkg) {
f815daf2 1213 HV *const stash = gv_stashsv(pkg, GV_ADD);
a954f6ee 1214 SvREFCNT_dec(pkg);
288b8c02
NC
1215 (void)sv_bless(rv, stash);
1216 }
1217
9274aefd 1218 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
e08e52cf 1219 SvTAINTED_on(rv);
9274aefd
DM
1220 SvTAINTED_on(SvRV(rv));
1221 }
c8c13c22 1222 XPUSHs(rv);
1223 RETURN;
8782bef2
GB
1224}
1225
a0d0e21e
LW
1226PP(pp_match)
1227{
97aff369 1228 dVAR; dSP; dTARG;
eb578fdb 1229 PMOP *pm = cPMOP;
d65afb4b 1230 PMOP *dynpm = pm;
eb578fdb
KW
1231 const char *t;
1232 const char *s;
5c144d81 1233 const char *strend;
a0d0e21e 1234 I32 global;
1ed74d04 1235 U8 r_flags = REXEC_CHECKED;
5c144d81 1236 const char *truebase; /* Start of string */
eb578fdb 1237 REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1238 bool rxtainted;
a3b680e6 1239 const I32 gimme = GIMME;
a0d0e21e 1240 STRLEN len;
748a9306 1241 I32 minmatch = 0;
a3b680e6 1242 const I32 oldsave = PL_savestack_ix;
f86702cc 1243 I32 update_minmatch = 1;
e60df1fa 1244 I32 had_zerolen = 0;
58e23c8d 1245 U32 gpos = 0;
a0d0e21e 1246
533c011a 1247 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1248 TARG = POPs;
59f00321
RGS
1249 else if (PL_op->op_private & OPpTARGET_MY)
1250 GETTARGET;
a0d0e21e 1251 else {
54b9620d 1252 TARG = DEFSV;
a0d0e21e
LW
1253 EXTEND(SP,1);
1254 }
d9f424b2 1255
c277df42 1256 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
1257 /* Skip get-magic if this is a qr// clone, because regcomp has
1258 already done it. */
1259 s = ((struct regexp *)SvANY(rx))->mother_re
1260 ? SvPV_nomg_const(TARG, len)
1261 : SvPV_const(TARG, len);
a0d0e21e 1262 if (!s)
2269b42e 1263 DIE(aTHX_ "panic: pp_match");
890ce7af 1264 strend = s + len;
07bc277f 1265 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
3280af22 1266 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1267 TAINT_NOT;
a0d0e21e 1268
a30b2f1f 1269 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 1270
d65afb4b 1271 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
1272 if (
1273#ifdef USE_ITHREADS
1274 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1275#else
1276 pm->op_pmflags & PMf_USED
1277#endif
1278 ) {
e5dc5375 1279 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
c277df42 1280 failure:
e5dc5375 1281
a0d0e21e
LW
1282 if (gimme == G_ARRAY)
1283 RETURN;
1284 RETPUSHNO;
1285 }
1286
c737faaf
YO
1287
1288
d65afb4b 1289 /* empty pattern special-cased to use last successful pattern if possible */
220fc49f 1290 if (!RX_PRELEN(rx) && PL_curpm) {
3280af22 1291 pm = PL_curpm;
aaa362c4 1292 rx = PM_GETRE(pm);
a0d0e21e 1293 }
d65afb4b 1294
e5dc5375
KW
1295 if (RX_MINLEN(rx) > (I32)len) {
1296 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
d65afb4b 1297 goto failure;
e5dc5375 1298 }
c277df42 1299
a0d0e21e 1300 truebase = t = s;
ad94a511
IZ
1301
1302 /* XXXX What part of this is needed with true \G-support? */
d65afb4b 1303 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
07bc277f 1304 RX_OFFS(rx)[0].start = -1;
a0d0e21e 1305 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
c445ea15 1306 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
565764a8 1307 if (mg && mg->mg_len >= 0) {
07bc277f
NC
1308 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1309 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1310 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
0ef3e39e 1311 r_flags |= REXEC_IGNOREPOS;
07bc277f
NC
1312 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1313 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
58e23c8d
YO
1314 gpos = mg->mg_len;
1315 else
07bc277f
NC
1316 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1317 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
f86702cc 1318 update_minmatch = 0;
748a9306 1319 }
a0d0e21e
LW
1320 }
1321 }
a41aa44d 1322 if ( RX_NPARENS(rx)
6502e081
DM
1323 || PL_sawampersand
1324 || SvTEMP(TARG)
1325 || SvAMAGIC(TARG)
1326 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1327 ) {
1328 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1329 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1330 * only on the first iteration. Therefore we need to copy $' as well
1331 * as $&, to make the rest of the string available for captures in
1332 * subsequent iterations */
1333 if (! (global && gimme == G_ARRAY))
1334 r_flags |= REXEC_COPY_SKIP_POST;
1335 };
22e551b9 1336
d7be1480 1337 play_it_again:
07bc277f
NC
1338 if (global && RX_OFFS(rx)[0].start != -1) {
1339 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
e5dc5375
KW
1340 if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
1341 DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
a0d0e21e 1342 goto nope;
e5dc5375 1343 }
f86702cc 1344 if (update_minmatch++)
e60df1fa 1345 minmatch = had_zerolen;
a0d0e21e 1346 }
07bc277f 1347 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
3c8556c3 1348 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
5c144d81
NC
1349 /* FIXME - can PL_bostr be made const char *? */
1350 PL_bostr = (char *)truebase;
f9f4320a 1351 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
f722798b
IZ
1352
1353 if (!s)
1354 goto nope;
07bc277f 1355 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
14977893 1356 && !PL_sawampersand
07bc277f 1357 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
05b4157f 1358 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
f722798b 1359 goto yup;
a0d0e21e 1360 }
77da2310
NC
1361 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1362 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1363 goto ret_no;
1364
1365 PL_curpm = pm;
1366 if (dynpm->op_pmflags & PMf_ONCE) {
c737faaf 1367#ifdef USE_ITHREADS
77da2310 1368 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 1369#else
77da2310 1370 dynpm->op_pmflags |= PMf_USED;
c737faaf 1371#endif
a0d0e21e 1372 }
a0d0e21e
LW
1373
1374 gotcha:
72311751
GS
1375 if (rxtainted)
1376 RX_MATCH_TAINTED_on(rx);
1377 TAINT_IF(RX_MATCH_TAINTED(rx));
a0d0e21e 1378 if (gimme == G_ARRAY) {
07bc277f 1379 const I32 nparens = RX_NPARENS(rx);
a3b680e6 1380 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 1381
c277df42 1382 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1383 EXTEND(SP, nparens + i);
1384 EXTEND_MORTAL(nparens + i);
1385 for (i = !i; i <= nparens; i++) {
a0d0e21e 1386 PUSHs(sv_newmortal());
07bc277f
NC
1387 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1388 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1389 s = RX_OFFS(rx)[i].start + truebase;
1390 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
290deeac 1391 len < 0 || len > strend - s)
5637ef5b
NC
1392 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1393 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1394 (long) i, (long) RX_OFFS(rx)[i].start,
1395 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
a0d0e21e 1396 sv_setpvn(*SP, s, len);
cce850e4 1397 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1398 SvUTF8_on(*SP);
a0d0e21e
LW
1399 }
1400 }
1401 if (global) {
d65afb4b 1402 if (dynpm->op_pmflags & PMf_CONTINUE) {
6136c704 1403 MAGIC* mg = NULL;
0af80b60
HS
1404 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1405 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1406 if (!mg) {
d83f0a82
NC
1407#ifdef PERL_OLD_COPY_ON_WRITE
1408 if (SvIsCOW(TARG))
1409 sv_force_normal_flags(TARG, 0);
1410#endif
1411 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1412 &PL_vtbl_mglob, NULL, 0);
0af80b60 1413 }
07bc277f
NC
1414 if (RX_OFFS(rx)[0].start != -1) {
1415 mg->mg_len = RX_OFFS(rx)[0].end;
1416 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
0af80b60
HS
1417 mg->mg_flags |= MGf_MINMATCH;
1418 else
1419 mg->mg_flags &= ~MGf_MINMATCH;
1420 }
1421 }
07bc277f
NC
1422 had_zerolen = (RX_OFFS(rx)[0].start != -1
1423 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1424 == (UV)RX_OFFS(rx)[0].end));
c277df42 1425 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1426 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1427 goto play_it_again;
1428 }
ffc61ed2 1429 else if (!nparens)
bde848c5 1430 XPUSHs(&PL_sv_yes);
4633a7c4 1431 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1432 RETURN;
1433 }
1434 else {
1435 if (global) {
cbbf8932 1436 MAGIC* mg;
a0d0e21e 1437 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
14befaf4 1438 mg = mg_find(TARG, PERL_MAGIC_regex_global);
cbbf8932
AL
1439 else
1440 mg = NULL;
a0d0e21e 1441 if (!mg) {
d83f0a82
NC
1442#ifdef PERL_OLD_COPY_ON_WRITE
1443 if (SvIsCOW(TARG))
1444 sv_force_normal_flags(TARG, 0);
1445#endif
1446 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1447 &PL_vtbl_mglob, NULL, 0);
a0d0e21e 1448 }
07bc277f
NC
1449 if (RX_OFFS(rx)[0].start != -1) {
1450 mg->mg_len = RX_OFFS(rx)[0].end;
1451 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
748a9306
LW
1452 mg->mg_flags |= MGf_MINMATCH;
1453 else
1454 mg->mg_flags &= ~MGf_MINMATCH;
1455 }
a0d0e21e 1456 }
4633a7c4 1457 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1458 RETPUSHYES;
1459 }
1460
f722798b 1461yup: /* Confirmed by INTUIT */
72311751
GS
1462 if (rxtainted)
1463 RX_MATCH_TAINTED_on(rx);
1464 TAINT_IF(RX_MATCH_TAINTED(rx));
3280af22 1465 PL_curpm = pm;
c737faaf
YO
1466 if (dynpm->op_pmflags & PMf_ONCE) {
1467#ifdef USE_ITHREADS
1468 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1469#else
1470 dynpm->op_pmflags |= PMf_USED;
1471#endif
1472 }
cf93c79d 1473 if (RX_MATCH_COPIED(rx))
07bc277f 1474 Safefree(RX_SUBBEG(rx));
cf93c79d 1475 RX_MATCH_COPIED_off(rx);
07bc277f 1476 RX_SUBBEG(rx) = NULL;
a0d0e21e 1477 if (global) {
5c144d81 1478 /* FIXME - should rx->subbeg be const char *? */
07bc277f 1479 RX_SUBBEG(rx) = (char *) truebase;
6502e081
DM
1480 RX_SUBOFFSET(rx) = 0;
1481 RX_SUBCOFFSET(rx) = 0;
07bc277f 1482 RX_OFFS(rx)[0].start = s - truebase;
a30b2f1f 1483 if (RX_MATCH_UTF8(rx)) {
07bc277f
NC
1484 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1485 RX_OFFS(rx)[0].end = t - truebase;
60aeb6fd
NIS
1486 }
1487 else {
07bc277f 1488 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
60aeb6fd 1489 }
07bc277f 1490 RX_SUBLEN(rx) = strend - truebase;
a0d0e21e 1491 goto gotcha;
1c846c1f 1492 }
07bc277f 1493 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
14977893 1494 I32 off;
f8c7b90f 1495#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
1496 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1497 if (DEBUG_C_TEST) {
1498 PerlIO_printf(Perl_debug_log,
1499 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
6c9570dc 1500 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
ed252734
NC
1501 (int)(t-truebase));
1502 }
bdd9a1b1
NC
1503 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1504 RX_SUBBEG(rx)
1505 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1506 assert (SvPOKp(RX_SAVED_COPY(rx)));
ed252734
NC
1507 } else
1508#endif
1509 {
14977893 1510
07bc277f 1511 RX_SUBBEG(rx) = savepvn(t, strend - t);
f8c7b90f 1512#ifdef PERL_OLD_COPY_ON_WRITE
bdd9a1b1 1513 RX_SAVED_COPY(rx) = NULL;
ed252734
NC
1514#endif
1515 }
07bc277f 1516 RX_SUBLEN(rx) = strend - t;
6502e081
DM
1517 RX_SUBOFFSET(rx) = 0;
1518 RX_SUBCOFFSET(rx) = 0;
14977893 1519 RX_MATCH_COPIED_on(rx);
07bc277f
NC
1520 off = RX_OFFS(rx)[0].start = s - t;
1521 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
14977893
JH
1522 }
1523 else { /* startp/endp are used by @- @+. */
07bc277f
NC
1524 RX_OFFS(rx)[0].start = s - truebase;
1525 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
14977893 1526 }
7e1a2c8d
DM
1527 /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
1528 assert(!RX_NPARENS(rx));
1529 RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
4633a7c4 1530 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1531 RETPUSHYES;
1532
1533nope:
a0d0e21e 1534ret_no:
d65afb4b 1535 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e 1536 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
6136c704 1537 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1538 if (mg)
565764a8 1539 mg->mg_len = -1;
a0d0e21e
LW
1540 }
1541 }
4633a7c4 1542 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1543 if (gimme == G_ARRAY)
1544 RETURN;
1545 RETPUSHNO;
1546}
1547
1548OP *
864dbfa3 1549Perl_do_readline(pTHX)
a0d0e21e 1550{
27da23d5 1551 dVAR; dSP; dTARGETSTACKED;
eb578fdb 1552 SV *sv;
a0d0e21e
LW
1553 STRLEN tmplen = 0;
1554 STRLEN offset;
760ac839 1555 PerlIO *fp;
eb578fdb
KW
1556 IO * const io = GvIO(PL_last_in_gv);
1557 const I32 type = PL_op->op_type;
a3b680e6 1558 const I32 gimme = GIMME_V;
a0d0e21e 1559
6136c704 1560 if (io) {
50db69d8 1561 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 1562 if (mg) {
50db69d8 1563 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 1564 if (gimme == G_SCALAR) {
50db69d8
NC
1565 SPAGAIN;
1566 SvSetSV_nosteal(TARG, TOPs);
1567 SETTARG;
6136c704 1568 }
50db69d8 1569 return NORMAL;
0b7c7b4f 1570 }
e79b0511 1571 }
4608196e 1572 fp = NULL;
a0d0e21e
LW
1573 if (io) {
1574 fp = IoIFP(io);
1575 if (!fp) {
1576 if (IoFLAGS(io) & IOf_ARGV) {
1577 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1578 IoLINES(io) = 0;
3280af22 1579 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1580 IoFLAGS(io) &= ~IOf_START;
4608196e 1581 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
4bac9ae4 1582 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
76f68e9b 1583 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3280af22 1584 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1585 fp = IoIFP(io);
1586 goto have_fp;
a0d0e21e
LW
1587 }
1588 }
3280af22 1589 fp = nextargv(PL_last_in_gv);
a0d0e21e 1590 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1591 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1592 }
1593 }
0d44d22b
NC
1594 else if (type == OP_GLOB)
1595 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1596 }
1597 else if (type == OP_GLOB)
1598 SP--;
7716c5c5 1599 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 1600 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 1601 }
a0d0e21e
LW
1602 }
1603 if (!fp) {
041457d9
DM
1604 if ((!io || !(IoFLAGS(io) & IOf_START))
1605 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1606 {
3f4520fe 1607 if (type == OP_GLOB)
63922903 1608 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
af8c498a
GS
1609 "glob failed (can't start child: %s)",
1610 Strerror(errno));
69282e91 1611 else
831e4cc3 1612 report_evil_fh(PL_last_in_gv);
3f4520fe 1613 }
54310121 1614 if (gimme == G_SCALAR) {
79628082 1615 /* undef TARG, and push that undefined value */
ba92458f
AE
1616 if (type != OP_RCATLINE) {
1617 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1618 SvOK_off(TARG);
ba92458f 1619 }
a0d0e21e
LW
1620 PUSHTARG;
1621 }
1622 RETURN;
1623 }
a2008d6d 1624 have_fp:
54310121 1625 if (gimme == G_SCALAR) {
a0d0e21e 1626 sv = TARG;
0f722b55
RGS
1627 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1628 mg_get(sv);
48de12d9
RGS
1629 if (SvROK(sv)) {
1630 if (type == OP_RCATLINE)
5668452f 1631 SvPV_force_nomg_nolen(sv);
48de12d9
RGS
1632 else
1633 sv_unref(sv);
1634 }
f7877b28 1635 else if (isGV_with_GP(sv)) {
5668452f 1636 SvPV_force_nomg_nolen(sv);
f7877b28 1637 }
862a34c6 1638 SvUPGRADE(sv, SVt_PV);
a0d0e21e 1639 tmplen = SvLEN(sv); /* remember if already alloced */
f72e8700
JJ
1640 if (!tmplen && !SvREADONLY(sv)) {
1641 /* try short-buffering it. Please update t/op/readline.t
1642 * if you change the growth length.
1643 */
1644 Sv_Grow(sv, 80);
1645 }
2b5e58c4
AMS
1646 offset = 0;
1647 if (type == OP_RCATLINE && SvOK(sv)) {
1648 if (!SvPOK(sv)) {
5668452f 1649 SvPV_force_nomg_nolen(sv);
2b5e58c4 1650 }
a0d0e21e 1651 offset = SvCUR(sv);
2b5e58c4 1652 }
a0d0e21e 1653 }
54310121 1654 else {
561b68a9 1655 sv = sv_2mortal(newSV(80));
54310121
PP
1656 offset = 0;
1657 }
fbad3eb5 1658
3887d568
AP
1659 /* This should not be marked tainted if the fp is marked clean */
1660#define MAYBE_TAINT_LINE(io, sv) \
1661 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1662 TAINT; \
1663 SvTAINTED_on(sv); \
1664 }
1665
684bef36 1666/* delay EOF state for a snarfed empty file */
fbad3eb5 1667#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1668 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1669 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1670
a0d0e21e 1671 for (;;) {
09e8efcc 1672 PUTBACK;
fbad3eb5 1673 if (!sv_gets(sv, fp, offset)
2d726892
TF
1674 && (type == OP_GLOB
1675 || SNARF_EOF(gimme, PL_rs, io, sv)
1676 || PerlIO_error(fp)))
fbad3eb5 1677 {
760ac839 1678 PerlIO_clearerr(fp);
a0d0e21e 1679 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1680 fp = nextargv(PL_last_in_gv);
a0d0e21e
LW
1681 if (fp)
1682 continue;
3280af22 1683 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1684 }
1685 else if (type == OP_GLOB) {
a2a5de95
NC
1686 if (!do_close(PL_last_in_gv, FALSE)) {
1687 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1688 "glob failed (child exited with status %d%s)",
1689 (int)(STATUS_CURRENT >> 8),
1690 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1691 }
a0d0e21e 1692 }
54310121 1693 if (gimme == G_SCALAR) {
ba92458f
AE
1694 if (type != OP_RCATLINE) {
1695 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1696 SvOK_off(TARG);
ba92458f 1697 }
09e8efcc 1698 SPAGAIN;
a0d0e21e
LW
1699 PUSHTARG;
1700 }
3887d568 1701 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1702 RETURN;
1703 }
3887d568 1704 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1705 IoLINES(io)++;
b9fee9ba 1706 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1707 SvSETMAGIC(sv);
09e8efcc 1708 SPAGAIN;
a0d0e21e 1709 XPUSHs(sv);
a0d0e21e 1710 if (type == OP_GLOB) {
349d4f2f 1711 const char *t1;
a0d0e21e 1712
3280af22 1713 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 1714 char * const tmps = SvEND(sv) - 1;
aa07b2f6 1715 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 1716 *tmps = '\0';
b162af07 1717 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
1718 }
1719 }
349d4f2f 1720 for (t1 = SvPVX_const(sv); *t1; t1++)
937b2e03 1721 if (!isALNUMC(*t1) &&
349d4f2f 1722 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
a0d0e21e 1723 break;
349d4f2f 1724 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1725 (void)POPs; /* Unmatched wildcard? Chuck it... */
1726 continue;
1727 }
2d79bf7f 1728 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
1729 if (ckWARN(WARN_UTF8)) {
1730 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1731 const STRLEN len = SvCUR(sv) - offset;
1732 const U8 *f;
1733
1734 if (!is_utf8_string_loc(s, len, &f))
1735 /* Emulate :encoding(utf8) warning in the same case. */
1736 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1737 "utf8 \"\\x%02X\" does not map to Unicode",
1738 f < (U8*)SvEND(sv) ? *f : 0);
1739 }
a0d0e21e 1740 }
54310121 1741 if (gimme == G_ARRAY) {
a0d0e21e 1742 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 1743 SvPV_shrink_to_cur(sv);
a0d0e21e 1744 }
561b68a9 1745 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
1746 continue;
1747 }
54310121 1748 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 1749 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
1750 const STRLEN new_len
1751 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 1752 SvPV_renew(sv, new_len);
a0d0e21e
LW
1753 }
1754 RETURN;
1755 }
1756}
1757
a0d0e21e
LW
1758PP(pp_helem)
1759{
97aff369 1760 dVAR; dSP;
760ac839 1761 HE* he;
ae77835f 1762 SV **svp;
c445ea15 1763 SV * const keysv = POPs;
85fbaab2 1764 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
1765 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1766 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1767 SV *sv;
c158a4fd 1768 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
92970b93 1769 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 1770 bool preeminent = TRUE;
a0d0e21e 1771
d4c19fe8 1772 if (SvTYPE(hv) != SVt_PVHV)
a0d0e21e 1773 RETPUSHUNDEF;
d4c19fe8 1774
92970b93 1775 if (localizing) {
d4c19fe8
AL
1776 MAGIC *mg;
1777 HV *stash;
d30e492c
VP
1778
1779 /* If we can determine whether the element exist,
1780 * Try to preserve the existenceness of a tied hash
1781 * element by using EXISTS and DELETE if possible.
1782 * Fallback to FETCH and STORE otherwise. */
2c5f48c2 1783 if (SvCANEXISTDELETE(hv))
d30e492c 1784 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 1785 }
d30e492c 1786
d4c19fe8
AL
1787 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1788 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 1789 if (lval) {
746f6409 1790 if (!svp || !*svp || *svp == &PL_sv_undef) {
68dc0745
PP
1791 SV* lv;
1792 SV* key2;
2d8e6c8d 1793 if (!defer) {
be2597df 1794 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 1795 }
68dc0745
PP
1796 lv = sv_newmortal();
1797 sv_upgrade(lv, SVt_PVLV);
1798 LvTYPE(lv) = 'y';
6136c704 1799 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
68dc0745 1800 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
b37c2d43 1801 LvTARG(lv) = SvREFCNT_inc_simple(hv);
68dc0745
PP
1802 LvTARGLEN(lv) = 1;
1803 PUSHs(lv);
1804 RETURN;
1805 }
92970b93 1806 if (localizing) {
bfcb3514 1807 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 1808 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
1809 else if (preeminent)
1810 save_helem_flags(hv, keysv, svp,
1811 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1812 else
1813 SAVEHDELETE(hv, keysv);
5f05dabc 1814 }
9026059d
GG
1815 else if (PL_op->op_private & OPpDEREF) {
1816 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1817 RETURN;
1818 }
a0d0e21e 1819 }
746f6409 1820 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
1821 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1822 * was to make C<local $tied{foo} = $tied{foo}> possible.
1823 * However, it seems no longer to be needed for that purpose, and
1824 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1825 * would loop endlessly since the pos magic is getting set on the
1826 * mortal copy and lost. However, the copy has the effect of
1827 * triggering the get magic, and losing it altogether made things like
1828 * c<$tied{foo};> in void context no longer do get magic, which some
1829 * code relied on. Also, delayed triggering of magic on @+ and friends
1830 * meant the original regex may be out of scope by now. So as a
1831 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1832 * being called too many times). */
39cf747a 1833 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 1834 mg_get(sv);
be6c24e0 1835 PUSHs(sv);
a0d0e21e
LW
1836 RETURN;
1837}
1838
a0d0e21e
LW
1839PP(pp_iter)
1840{
97aff369 1841 dVAR; dSP;
eb578fdb 1842 PERL_CONTEXT *cx;
dc09a129 1843 SV *sv, *oldsv;
1d7c1841 1844 SV **itersvp;
d01136d6
BS
1845 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1846 bool av_is_stack = FALSE;
a0d0e21e 1847
924508f0 1848 EXTEND(SP, 1);
a0d0e21e 1849 cx = &cxstack[cxstack_ix];
3b719c58 1850 if (!CxTYPE_is_LOOP(cx))
5637ef5b 1851 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
a0d0e21e 1852
1d7c1841 1853 itersvp = CxITERVAR(cx);
d01136d6 1854 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
89ea2908 1855 /* string increment */
d01136d6
BS
1856 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1857 SV *end = cx->blk_loop.state_u.lazysv.end;
267cc4a8
NC
1858 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1859 It has SvPVX of "" and SvCUR of 0, which is what we want. */
4fe3f0fa 1860 STRLEN maxlen = 0;
d01136d6 1861 const char *max = SvPV_const(end, maxlen);
89ea2908 1862 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1d7c1841 1863 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1864 /* safe to reuse old SV */
1d7c1841 1865 sv_setsv(*itersvp, cur);
eaa5c2d6 1866 }
1c846c1f 1867 else
eaa5c2d6
GA
1868 {
1869 /* we need a fresh SV every time so that loop body sees a
1870 * completely new SV for closures/references to work as
1871 * they used to */
dc09a129 1872 oldsv = *itersvp;
1d7c1841 1873 *itersvp = newSVsv(cur);
dc09a129 1874 SvREFCNT_dec(oldsv);
eaa5c2d6 1875 }
aa07b2f6 1876 if (strEQ(SvPVX_const(cur), max))
89ea2908
GA
1877 sv_setiv(cur, 0); /* terminate next time */
1878 else
1879 sv_inc(cur);
1880 RETPUSHYES;
1881 }
1882 RETPUSHNO;
d01136d6
BS
1883 }
1884 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
89ea2908 1885 /* integer increment */
d01136d6 1886 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
89ea2908 1887 RETPUSHNO;
7f61b687 1888
3db8f154 1889 /* don't risk potential race */
1d7c1841 1890 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1891 /* safe to reuse old SV */
cdc1aa42 1892 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur);
eaa5c2d6 1893 }
1c846c1f 1894 else
eaa5c2d6
GA
1895 {
1896 /* we need a fresh SV every time so that loop body sees a
1897 * completely new SV for closures/references to work as they
1898 * used to */
dc09a129 1899 oldsv = *itersvp;
cdc1aa42 1900 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur);
dc09a129 1901 SvREFCNT_dec(oldsv);
eaa5c2d6 1902 }
a2309040 1903
cdc1aa42
NC
1904 if (cx->blk_loop.state_u.lazyiv.cur == IV_MAX) {
1905 /* Handle end of range at IV_MAX */
1906 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1907 } else
1908 ++cx->blk_loop.state_u.lazyiv.cur;
a2309040 1909
89ea2908
GA
1910 RETPUSHYES;
1911 }
1912
1913 /* iterate array */
d01136d6
BS
1914 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1915 av = cx->blk_loop.state_u.ary.ary;
1916 if (!av) {
1917 av_is_stack = TRUE;
1918 av = PL_curstack;
1919 }
ef3e5ea9 1920 if (PL_op->op_private & OPpITER_REVERSED) {
d01136d6
BS
1921 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1922 ? cx->blk_loop.resetsp + 1 : 0))
ef3e5ea9 1923 RETPUSHNO;
a0d0e21e 1924
ef3e5ea9 1925 if (SvMAGICAL(av) || AvREIFY(av)) {
d01136d6 1926 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
a0714e2c 1927 sv = svp ? *svp : NULL;
ef3e5ea9
NC
1928 }
1929 else {
d01136d6 1930 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
ef3e5ea9 1931 }
d42935ef
JH
1932 }
1933 else {
d01136d6 1934 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
ef3e5ea9
NC
1935 AvFILL(av)))
1936 RETPUSHNO;
1937
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 1945 }
ef3e5ea9 1946
0565a181 1947 if (sv && SvIS_FREED(sv)) {
a0714e2c 1948 *itersvp = NULL;
b6c83531 1949 Perl_croak(aTHX_ "Use of freed value in iteration");
cccede53
DM
1950 }
1951
d01136d6 1952 if (sv) {
a0d0e21e 1953 SvTEMP_off(sv);
d01136d6
BS
1954 SvREFCNT_inc_simple_void_NN(sv);
1955 }
a0d0e21e 1956 else
3280af22 1957 sv = &PL_sv_undef;
d01136d6
BS
1958 if (!av_is_stack && sv == &PL_sv_undef) {
1959 SV *lv = newSV_type(SVt_PVLV);
1960 LvTYPE(lv) = 'y';
1961 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
b37c2d43 1962 LvTARG(lv) = SvREFCNT_inc_simple(av);
d01136d6 1963 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
42718184 1964 LvTARGLEN(lv) = (STRLEN)UV_MAX;
d01136d6 1965 sv = lv;
5f05dabc 1966 }
a0d0e21e 1967
dc09a129 1968 oldsv = *itersvp;
d01136d6 1969 *itersvp = sv;
dc09a129
DM
1970 SvREFCNT_dec(oldsv);
1971
a0d0e21e
LW
1972 RETPUSHYES;
1973}
1974
ef07e810
DM
1975/*
1976A description of how taint works in pattern matching and substitution.
1977
4e19c54b 1978While the pattern is being assembled/concatenated and then compiled,
0ab462a6
DM
1979PL_tainted will get set if any component of the pattern is tainted, e.g.
1980/.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
1981is set on the pattern if PL_tainted is set.
ef07e810 1982
0ab462a6
DM
1983When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1984the pattern is marked as tainted. This means that subsequent usage, such
1985as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
ef07e810
DM
1986
1987During execution of a pattern, locale-variant ops such as ALNUML set the
1988local flag RF_tainted. At the end of execution, the engine sets the
0ab462a6
DM
1989RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1990otherwise.
ef07e810
DM
1991
1992In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1993of $1 et al to indicate whether the returned value should be tainted.
1994It is the responsibility of the caller of the pattern (i.e. pp_match,
1995pp_subst etc) to set this flag for any other circumstances where $1 needs
1996to be tainted.
1997
1998The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1999
2000There are three possible sources of taint
2001 * the source string
2002 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2003 * the replacement string (or expression under /e)
2004
2005There are four destinations of taint and they are affected by the sources
2006according to the rules below:
2007
2008 * the return value (not including /r):
2009 tainted by the source string and pattern, but only for the
2010 number-of-iterations case; boolean returns aren't tainted;
2011 * the modified string (or modified copy under /r):
2012 tainted by the source string, pattern, and replacement strings;
2013 * $1 et al:
2014 tainted by the pattern, and under 'use re "taint"', by the source
2015 string too;
2016 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2017 should always be unset before executing subsequent code.
2018
2019The overall action of pp_subst is:
2020
2021 * at the start, set bits in rxtainted indicating the taint status of
2022 the various sources.
2023
2024 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2025 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2026 pattern has subsequently become tainted via locale ops.
2027
2028 * If control is being passed to pp_substcont to execute a /e block,
2029 save rxtainted in the CXt_SUBST block, for future use by
2030 pp_substcont.
2031
2032 * Whenever control is being returned to perl code (either by falling
2033 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2034 use the flag bits in rxtainted to make all the appropriate types of
0ab462a6
DM
2035 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2036 et al will appear tainted.
ef07e810
DM
2037
2038pp_match is just a simpler version of the above.
2039
2040*/
2041
a0d0e21e
LW
2042PP(pp_subst)
2043{
97aff369 2044 dVAR; dSP; dTARG;
eb578fdb 2045 PMOP *pm = cPMOP;
a0d0e21e 2046 PMOP *rpm = pm;
eb578fdb 2047 char *s;
a0d0e21e 2048 char *strend;
eb578fdb 2049 char *m;
5c144d81 2050 const char *c;
eb578fdb 2051 char *d;
a0d0e21e
LW
2052 STRLEN clen;
2053 I32 iters = 0;
2054 I32 maxiters;
eb578fdb 2055 I32 i;
a0d0e21e 2056 bool once;
ef07e810
DM
2057 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2058 See "how taint works" above */
a0d0e21e 2059 char *orig;
1ed74d04 2060 U8 r_flags;
eb578fdb 2061 REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
2062 STRLEN len;
2063 int force_on_match = 0;
0bcc34c2 2064 const I32 oldsave = PL_savestack_ix;
792b2c16 2065 STRLEN slen;
f272994b 2066 bool doutf8 = FALSE;
f8c7b90f 2067#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2068 bool is_cow;
2069#endif
a0714e2c 2070 SV *nsv = NULL;
b770e143 2071 /* known replacement string? */
eb578fdb 2072 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
a0d0e21e 2073
f410a211
NC
2074 PERL_ASYNC_CHECK();
2075
533c011a 2076 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 2077 TARG = POPs;
59f00321
RGS
2078 else if (PL_op->op_private & OPpTARGET_MY)
2079 GETTARGET;
a0d0e21e 2080 else {
54b9620d 2081 TARG = DEFSV;
a0d0e21e 2082 EXTEND(SP,1);
1c846c1f 2083 }
d9f424b2 2084
f8c7b90f 2085#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2086 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2087 because they make integers such as 256 "false". */
2088 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2089#else
765f542d
NC
2090 if (SvIsCOW(TARG))
2091 sv_force_normal_flags(TARG,0);
ed252734 2092#endif
8ca8a454 2093 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
f8c7b90f 2094#ifdef PERL_OLD_COPY_ON_WRITE
8ca8a454 2095 && !is_cow
ed252734 2096#endif
8ca8a454
NC
2097 && (SvREADONLY(TARG)
2098 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2099 || SvTYPE(TARG) > SVt_PVLV)
2100 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
6ad8f254 2101 Perl_croak_no_modify(aTHX);
8ec5e241
NIS
2102 PUTBACK;
2103
3e462cdc 2104 setup_match:
d5263905 2105 s = SvPV_mutable(TARG, len);
4499db73 2106 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
a0d0e21e 2107 force_on_match = 1;
20be6587
DM
2108
2109 /* only replace once? */
2110 once = !(rpm->op_pmflags & PMf_GLOBAL);
2111
ef07e810 2112 /* See "how taint works" above */
20be6587
DM
2113 if (PL_tainting) {
2114 rxtainted = (
2115 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2116 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2117 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2118 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2119 ? SUBST_TAINT_BOOLRET : 0));
2120 TAINT_NOT;
2121 }
a12c0f56 2122
a30b2f1f 2123 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 2124
a0d0e21e
LW
2125 force_it:
2126 if (!pm || !s)
5637ef5b 2127 DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
a0d0e21e
LW
2128
2129 strend = s + len;
a30b2f1f 2130 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH
2131 maxiters = 2 * slen + 10; /* We can match twice at each
2132 position, once with zero-length,
2133 second time with non-zero. */
a0d0e21e 2134
220fc49f 2135 if (!RX_PRELEN(rx) && PL_curpm) {
3280af22 2136 pm = PL_curpm;
aaa362c4 2137 rx = PM_GETRE(pm);
a0d0e21e 2138 }
6502e081
DM
2139
2140 r_flags = ( RX_NPARENS(rx)
2141 || PL_sawampersand
2142 || SvTEMP(TARG)
2143 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2144 )
2145 ? REXEC_COPY_STR
2146 : 0;
7fba1cd6 2147
a0d0e21e 2148 orig = m = s;
07bc277f 2149 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
ee0b7718 2150 PL_bostr = orig;
f9f4320a 2151 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
f722798b
IZ
2152
2153 if (!s)
df34c13a 2154 goto ret_no;
f722798b 2155 /* How to do it in subst? */
07bc277f 2156/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1c846c1f 2157 && !PL_sawampersand
a91cc451 2158 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
f722798b
IZ
2159 goto yup;
2160*/
a0d0e21e 2161 }
71be2cbc 2162
8b64c330
DM
2163 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2164 r_flags | REXEC_CHECKED))
2165 {
5e79dfb9
DM
2166 ret_no:
2167 SPAGAIN;
2168 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2169 LEAVE_SCOPE(oldsave);
2170 RETURN;
2171 }
2172
71be2cbc 2173 /* known replacement string? */
f272994b 2174 if (dstr) {
20be6587
DM
2175 if (SvTAINTED(dstr))
2176 rxtainted |= SUBST_TAINT_REPL;
3e462cdc
KW
2177
2178 /* Upgrade the source if the replacement is utf8 but the source is not,
2179 * but only if it matched; see
2180 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2181 */
5e79dfb9 2182 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
c95ca9b8
DM
2183 char * const orig_pvx = SvPVX(TARG);
2184 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
3e462cdc
KW
2185
2186 /* If the lengths are the same, the pattern contains only
2187 * invariants, can keep going; otherwise, various internal markers
2188 * could be off, so redo */
c95ca9b8 2189 if (new_len != len || orig_pvx != SvPVX(TARG)) {
3e462cdc
KW
2190 goto setup_match;
2191 }
2192 }
2193
8514a05a
JH
2194 /* replacement needing upgrading? */
2195 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2196 nsv = sv_newmortal();
4a176938 2197 SvSetSV(nsv, dstr);
8514a05a
JH
2198 if (PL_encoding)
2199 sv_recode_to_utf8(nsv, PL_encoding);
2200 else
2201 sv_utf8_upgrade(nsv);
5c144d81 2202 c = SvPV_const(nsv, clen);
4a176938
JH
2203 doutf8 = TRUE;
2204 }
2205 else {
5c144d81 2206 c = SvPV_const(dstr, clen);
4a176938 2207 doutf8 = DO_UTF8(dstr);
8514a05a 2208 }
f272994b
A
2209 }
2210 else {
6136c704 2211 c = NULL;
f272994b
A
2212 doutf8 = FALSE;
2213 }
2214
71be2cbc 2215 /* can do inplace substitution? */
ed252734 2216 if (c
f8c7b90f 2217#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2218 && !is_cow
2219#endif
07bc277f
NC
2220 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2221 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
8ca8a454
NC
2222 && (!doutf8 || SvUTF8(TARG))
2223 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
8b030b38 2224 {
ec911639 2225
f8c7b90f 2226#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2227 if (SvIsCOW(TARG)) {
2228 assert (!force_on_match);
2229 goto have_a_cow;
2230 }
2231#endif
71be2cbc
PP
2232 if (force_on_match) {
2233 force_on_match = 0;
2234 s = SvPV_force(TARG, len);
2235 goto force_it;
2236 }
71be2cbc 2237 d = s;
3280af22 2238 PL_curpm = pm;
71be2cbc 2239 if (once) {
20be6587
DM
2240 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2241 rxtainted |= SUBST_TAINT_PAT;
07bc277f
NC
2242 m = orig + RX_OFFS(rx)[0].start;
2243 d = orig + RX_OFFS(rx)[0].end;
71be2cbc
PP
2244 s = orig;
2245 if (m - s > strend - d) { /* faster to shorten from end */
2246 if (clen) {
2247 Copy(c, m, clen, char);
2248 m += clen;
a0d0e21e 2249 }
71be2cbc
PP
2250 i = strend - d;
2251 if (i > 0) {
2252 Move(d, m, i, char);
2253 m += i;
a0d0e21e 2254 }
71be2cbc
PP
2255 *m = '\0';
2256 SvCUR_set(TARG, m - s);
2257 }
155aba94 2258 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
2259 d -= clen;
2260 m = d;
0d3c21b0 2261 Move(s, d - i, i, char);
71be2cbc 2262 sv_chop(TARG, d-i);
71be2cbc
PP
2263 if (clen)
2264 Copy(c, m, clen, char);
2265 }
2266 else if (clen) {
2267 d -= clen;
2268 sv_chop(TARG, d);
2269 Copy(c, d, clen, char);
2270 }
2271 else {
2272 sv_chop(TARG, d);
2273 }
8ec5e241 2274 SPAGAIN;
8ca8a454 2275 PUSHs(&PL_sv_yes);
71be2cbc
PP
2276 }
2277 else {
71be2cbc
PP
2278 do {
2279 if (iters++ > maxiters)
cea2e8a9 2280 DIE(aTHX_ "Substitution loop");
20be6587
DM
2281 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2282 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2283 m = RX_OFFS(rx)[0].start + orig;
155aba94 2284 if ((i = m - s)) {
71be2cbc
PP
2285 if (s != d)
2286 Move(s, d, i, char);
2287 d += i;
a0d0e21e 2288 }
71be2cbc
PP
2289 if (clen) {
2290 Copy(c, d, clen, char);
2291 d += clen;
2292 }
07bc277f 2293 s = RX_OFFS(rx)[0].end + orig;
f9f4320a 2294 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
f722798b
IZ
2295 TARG, NULL,
2296 /* don't match same null twice */
2297 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
2298 if (s != d) {
2299 i = strend - s;
aa07b2f6 2300 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 2301 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2302 }
8ec5e241 2303 SPAGAIN;
8ca8a454 2304 mPUSHi((I32)iters);
a0d0e21e
LW
2305 }
2306 }
ff6e92e8 2307 else {
a0d0e21e
LW
2308 if (force_on_match) {
2309 force_on_match = 0;
0c1438a1
NC
2310 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2311 /* I feel that it should be possible to avoid this mortal copy
2312 given that the code below copies into a new destination.
2313 However, I suspect it isn't worth the complexity of
2314 unravelling the C<goto force_it> for the small number of
2315 cases where it would be viable to drop into the copy code. */
2316 TARG = sv_2mortal(newSVsv(TARG));
2317 }
a0d0e21e
LW
2318 s = SvPV_force(TARG, len);
2319 goto force_it;
2320 }
f8c7b90f 2321#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2322 have_a_cow:
2323#endif
20be6587
DM
2324 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2325 rxtainted |= SUBST_TAINT_PAT;
815dd406 2326 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3280af22 2327 PL_curpm = pm;
a0d0e21e 2328 if (!c) {
eb578fdb 2329 PERL_CONTEXT *cx;
8ec5e241 2330 SPAGAIN;
20be6587
DM
2331 /* note that a whole bunch of local vars are saved here for
2332 * use by pp_substcont: here's a list of them in case you're
2333 * searching for places in this sub that uses a particular var:
2334 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2335 * s m strend rx once */
a0d0e21e 2336 PUSHSUBST(cx);
20e98b0f 2337 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
a0d0e21e 2338 }
cf93c79d 2339 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2340 do {
2341 if (iters++ > maxiters)
cea2e8a9 2342 DIE(aTHX_ "Substitution loop");
20be6587
DM
2343 if (RX_MATCH_TAINTED(rx))
2344 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2345 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
a0d0e21e
LW
2346 m = s;
2347 s = orig;
6502e081 2348 assert(RX_SUBOFFSET(rx) == 0);
07bc277f 2349 orig = RX_SUBBEG(rx);
a0d0e21e
LW
2350 s = orig + (m - s);
2351 strend = s + (strend - m);
2352 }
07bc277f 2353 m = RX_OFFS(rx)[0].start + orig;
db79b45b 2354 if (doutf8 && !SvUTF8(dstr))
4bac9ae4 2355 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
db79b45b 2356 else
4bac9ae4 2357 sv_catpvn_nomg(dstr, s, m-s);
07bc277f 2358 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e 2359 if (clen)
4bac9ae4 2360 sv_catpvn_nomg(dstr, c, clen);
a0d0e21e
LW
2361 if (once)
2362 break;
f9f4320a 2363 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
ffc61ed2 2364 TARG, NULL, r_flags));
db79b45b 2365 if (doutf8 && !DO_UTF8(TARG))
4bac9ae4 2366 sv_catpvn_nomg_utf8_upgrade(dstr, s, strend - s, nsv);
89afcb60 2367 else
4bac9ae4 2368 sv_catpvn_nomg(dstr, s, strend - s);
748a9306 2369
8ca8a454
NC
2370 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2371 /* From here on down we're using the copy, and leaving the original
2372 untouched. */
2373 TARG = dstr;
2374 SPAGAIN;
2375 PUSHs(dstr);
2376 } else {
f8c7b90f 2377#ifdef PERL_OLD_COPY_ON_WRITE
8ca8a454
NC
2378 /* The match may make the string COW. If so, brilliant, because
2379 that's just saved us one malloc, copy and free - the regexp has
2380 donated the old buffer, and we malloc an entirely new one, rather
2381 than the regexp malloc()ing a buffer and copying our original,
2382 only for us to throw it away here during the substitution. */
2383 if (SvIsCOW(TARG)) {
2384 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2385 } else
ed252734 2386#endif
8ca8a454
NC
2387 {
2388 SvPV_free(TARG);
2389 }
2390 SvPV_set(TARG, SvPVX(dstr));
2391 SvCUR_set(TARG, SvCUR(dstr));
2392 SvLEN_set(TARG, SvLEN(dstr));
2393 doutf8 |= DO_UTF8(dstr);
2394 SvPV_set(dstr, NULL);
748a9306 2395
8ca8a454 2396 SPAGAIN;
4f4d7508 2397 mPUSHi((I32)iters);
8ca8a454
NC
2398 }
2399 }
2400
2401 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2402 (void)SvPOK_only_UTF8(TARG);
2403 if (doutf8)
2404 SvUTF8_on(TARG);
a0d0e21e 2405 }
20be6587 2406
ef07e810 2407 /* See "how taint works" above */
20be6587
DM
2408 if (PL_tainting) {
2409 if ((rxtainted & SUBST_TAINT_PAT) ||
2410 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2411 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2412 )
2413 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2414
2415 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2416 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2417 )
2418 SvTAINTED_on(TOPs); /* taint return value */
2419 else
2420 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2421
2422 /* needed for mg_set below */
2423 PL_tainted =
2424 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2425 SvTAINT(TARG);
2426 }
2427 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2428 TAINT_NOT;
f1a76097
DM
2429 LEAVE_SCOPE(oldsave);
2430 RETURN;
a0d0e21e
LW
2431}
2432
2433PP(pp_grepwhile)
2434{
27da23d5 2435 dVAR; dSP;
a0d0e21e
LW
2436
2437 if (SvTRUEx(POPs))
3280af22
NIS
2438 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2439 ++*PL_markstack_ptr;
b2a2a901 2440 FREETMPS;
d343c3ef 2441 LEAVE_with_name("grep_item"); /* exit inner scope */
a0d0e21e
LW
2442
2443 /* All done yet? */
3280af22 2444 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2445 I32 items;
c4420975 2446 const I32 gimme = GIMME_V;
a0d0e21e 2447
d343c3ef 2448 LEAVE_with_name("grep"); /* exit outer scope */
a0d0e21e 2449 (void)POPMARK; /* pop src */
3280af22 2450 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2451 (void)POPMARK; /* pop dst */
3280af22 2452 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2453 if (gimme == G_SCALAR) {
7cc47870 2454 if (PL_op->op_private & OPpGREP_LEX) {
c4420975 2455 SV* const sv = sv_newmortal();
7cc47870
RGS
2456 sv_setiv(sv, items);
2457 PUSHs(sv);
2458 }
2459 else {
2460 dTARGET;
2461 XPUSHi(items);
2462 }
a0d0e21e 2463 }
54310121
PP
2464 else if (gimme == G_ARRAY)
2465 SP += items;
a0d0e21e
LW
2466 RETURN;
2467 }
2468 else {
2469 SV *src;
2470
d343c3ef 2471 ENTER_with_name("grep_item"); /* enter inner scope */
1d7c1841 2472 SAVEVPTR(PL_curpm);
a0d0e21e 2473
3280af22 2474 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2475 SvTEMP_off(src);
59f00321
RGS
2476 if (PL_op->op_private & OPpGREP_LEX)
2477 PAD_SVl(PL_op->op_targ) = src;
2478 else
414bf5ae 2479 DEFSV_set(src);
a0d0e21e
LW
2480
2481 RETURNOP(cLOGOP->op_other);
2482 }
2483}
2484
2485PP(pp_leavesub)
2486{
27da23d5 2487 dVAR; dSP;
a0d0e21e
LW
2488 SV **mark;
2489 SV **newsp;
2490 PMOP *newpm;
2491 I32 gimme;
eb578fdb 2492 PERL_CONTEXT *cx;
b0d9ce38 2493 SV *sv;
a0d0e21e 2494
9850bf21
RH
2495 if (CxMULTICALL(&cxstack[cxstack_ix]))
2496 return 0;
2497
a0d0e21e 2498 POPBLOCK(cx,newpm);
5dd42e15 2499 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2500
a1f49e72 2501 TAINT_NOT;
a0d0e21e
LW
2502 if (gimme == G_SCALAR) {
2503 MARK = newsp + 1;
a29cdaf0 2504 if (MARK <= SP) {
a8bba7fa 2505 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
6f48390a
FC
2506 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2507 && !SvMAGICAL(TOPs)) {
a29cdaf0
IZ
2508 *MARK = SvREFCNT_inc(TOPs);
2509 FREETMPS;
2510 sv_2mortal(*MARK);
cd06dffe
GS
2511 }
2512 else {
959e3673 2513 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2514 FREETMPS;
959e3673
GS
2515 *MARK = sv_mortalcopy(sv);
2516 SvREFCNT_dec(sv);
a29cdaf0 2517 }
cd06dffe 2518 }
6f48390a
FC
2519 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2520 && !SvMAGICAL(TOPs)) {
767eda44 2521 *MARK = TOPs;
767eda44 2522 }
cd06dffe 2523 else
767eda44 2524 *MARK = sv_mortalcopy(TOPs);
cd06dffe
GS
2525 }
2526 else {
f86702cc 2527 MEXTEND(MARK, 0);
3280af22 2528 *MARK = &PL_sv_undef;
a0d0e21e
LW
2529 }
2530 SP = MARK;
2531 }
54310121 2532 else if (gimme == G_ARRAY) {
f86702cc 2533 for (MARK = newsp + 1; MARK <= SP; MARK++) {
6f48390a
FC
2534 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2535 || SvMAGICAL(*MARK)) {
f86702cc 2536 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2537 TAINT_NOT; /* Each item is independent */
2538 }
f86702cc 2539 }
a0d0e21e 2540 }
f86702cc 2541 PUTBACK;
1c846c1f 2542
a57c6685 2543 LEAVE;
5dd42e15 2544 cxstack_ix--;
b0d9ce38 2545 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2546 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2547
b0d9ce38 2548 LEAVESUB(sv);
f39bc417 2549 return cx->blk_sub.retop;
a0d0e21e
LW
2550}
2551
2552PP(pp_entersub)
2553{
27da23d5 2554 dVAR; dSP; dPOPss;
a0d0e21e 2555 GV *gv;
eb578fdb
KW
2556 CV *cv;
2557 PERL_CONTEXT *cx;
5d94fbed 2558 I32 gimme;
a9c4fd4e 2559 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2560
2561 if (!sv)
cea2e8a9 2562 DIE(aTHX_ "Not a CODE reference");
a0d0e21e 2563 switch (SvTYPE(sv)) {
f1025168
NC
2564 /* This is overwhelming the most common case: */
2565 case SVt_PVGV:
13be902c 2566 we_have_a_glob:
159b6efe 2567 if (!(cv = GvCVu((const GV *)sv))) {
f730a42d 2568 HV *stash;
f2c0649b 2569 cv = sv_2cv(sv, &stash, &gv, 0);
f730a42d 2570 }
f1025168 2571 if (!cv) {
a57c6685 2572 ENTER;
f1025168
NC
2573 SAVETMPS;
2574 goto try_autoload;
2575 }
2576 break;
13be902c
FC
2577 case SVt_PVLV:
2578 if(isGV_with_GP(sv)) goto we_have_a_glob;
2579 /*FALLTHROUGH*/
a0d0e21e 2580 default:
7c75014e
DM
2581 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2582 if (hasargs)
2583 SP = PL_stack_base + POPMARK;
4d198de3
DM
2584 else
2585 (void)POPMARK;
7c75014e
DM
2586 RETURN;
2587 }
2588 SvGETMAGIC(sv);
2589 if (SvROK(sv)) {
93d7320b
DM
2590 if (SvAMAGIC(sv)) {
2591 sv = amagic_deref_call(sv, to_cv_amg);
2592 /* Don't SPAGAIN here. */
2593 }
7c75014e
DM
2594 }
2595 else {
a9c4fd4e 2596 const char *sym;
780a5241 2597 STRLEN len;
79a3e5ea 2598 if (!SvOK(sv))
cea2e8a9 2599 DIE(aTHX_ PL_no_usym, "a subroutine");
79a3e5ea 2600 sym = SvPV_nomg_const(sv, len);
533c011a 2601 if (PL_op->op_private & HINT_STRICT_REFS)
b375e37b 2602 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
780a5241 2603 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
a0d0e21e
LW
2604 break;
2605 }
ea726b52 2606 cv = MUTABLE_CV(SvRV(sv));
a0d0e21e
LW
2607 if (SvTYPE(cv) == SVt_PVCV)
2608 break;
2609 /* FALL THROUGH */
2610 case SVt_PVHV:
2611 case SVt_PVAV:
cea2e8a9 2612 DIE(aTHX_ "Not a CODE reference");
f1025168 2613 /* This is the second most common case: */
a0d0e21e 2614 case SVt_PVCV:
ea726b52 2615 cv = MUTABLE_CV(sv);
a0d0e21e 2616 break;
a0d0e21e
LW
2617 }
2618
a57c6685 2619 ENTER;
a0d0e21e
LW
2620 SAVETMPS;
2621
2622 retry:
541ed3a9
FC
2623 if (CvCLONE(cv) && ! CvCLONED(cv))
2624 DIE(aTHX_ "Closure prototype called");
a0d0e21e 2625 if (!CvROOT(cv) && !CvXSUB(cv)) {
2f349aa0
NC
2626 GV* autogv;
2627 SV* sub_name;
2628
2629 /* anonymous or undef'd function leaves us no recourse */
2630 if (CvANON(cv) || !(gv = CvGV(cv)))
2631 DIE(aTHX_ "Undefined subroutine called");
2632
2633 /* autoloaded stub? */
2634 if (cv != GvCV(gv)) {
2635 cv = GvCV(gv);
2636 }
2637 /* should call AUTOLOAD now? */
2638 else {
7e623da3 2639try_autoload:
d1089224
BF
2640 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2641 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2f349aa0
NC
2642 {
2643 cv = GvCV(autogv);
2644 }
2f349aa0 2645 else {
c220e1a1 2646 sorry:
2f349aa0 2647 sub_name = sv_newmortal();
6136c704 2648 gv_efullname3(sub_name, gv, NULL);
be2597df 2649 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2f349aa0
NC
2650 }
2651 }
2652 if (!cv)
c220e1a1 2653 goto sorry;
2f349aa0 2654 goto retry;
a0d0e21e
LW
2655 }
2656
54310121 2657 gimme = GIMME_V;
67caa1fe 2658 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
005a8a35 2659 Perl_get_db_sub(aTHX_ &sv, cv);
a9ef256d
NC
2660 if (CvISXSUB(cv))
2661 PL_curcopdb = PL_curcop;
1ad62f64 2662 if (CvLVALUE(cv)) {
2663 /* check for lsub that handles lvalue subroutines */
ae5c1e95 2664 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
1ad62f64 2665 /* if lsub not found then fall back to DB::sub */
2666 if (!cv) cv = GvCV(PL_DBsub);
2667 } else {
2668 cv = GvCV(PL_DBsub);
2669 }
a9ef256d 2670
ccafdc96
RGS
2671 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2672 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2673 }
a0d0e21e 2674
aed2304a 2675 if (!(CvISXSUB(cv))) {
f1025168 2676 /* This path taken at least 75% of the time */
a0d0e21e 2677 dMARK;
eb578fdb 2678 I32 items = SP - MARK;
b70d5558 2679 PADLIST * const padlist = CvPADLIST(cv);
a0d0e21e
LW
2680 PUSHBLOCK(cx, CXt_SUB, MARK);
2681 PUSHSUB(cx);
f39bc417 2682 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 2683 CvDEPTH(cv)++;
3a76ca88
RGS
2684 if (CvDEPTH(cv) >= 2) {
2685 PERL_STACK_OVERFLOW_CHECK();
2686 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2687 }
3a76ca88
RGS
2688 SAVECOMPPAD();
2689 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2690 if (hasargs) {
10533ace 2691 AV *const av = MUTABLE_AV(PAD_SVl(0));
221373f0
GS
2692 if (AvREAL(av)) {
2693 /* @_ is normally not REAL--this should only ever
2694 * happen when DB::sub() calls things that modify @_ */
2695 av_clear(av);
2696 AvREAL_off(av);
2697 AvREIFY_on(av);
2698 }
3280af22 2699 cx->blk_sub.savearray = GvAV(PL_defgv);
502c6561 2700 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
dd2155a4 2701 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2702 cx->blk_sub.argarray = av;
a0d0e21e
LW
2703 ++MARK;
2704
2705 if (items > AvMAX(av) + 1) {
504618e9 2706 SV **ary = AvALLOC(av);
a0d0e21e
LW
2707 if (AvARRAY(av) != ary) {
2708 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 2709 AvARRAY(av) = ary;
a0d0e21e
LW
2710 }
2711 if (items > AvMAX(av) + 1) {
2712 AvMAX(av) = items - 1;
2713 Renew(ary,items,SV*);
2714 AvALLOC(av) = ary;
9c6bc640 2715 AvARRAY(av) = ary;
a0d0e21e
LW
2716 }
2717 }
2718 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2719 AvFILLp(av) = items - 1;
1c846c1f 2720
a0d0e21e
LW
2721 while (items--) {
2722 if (*MARK)
2723 SvTEMP_off(*MARK);
2724 MARK++;
2725 }
2726 }
da1dff94
FC
2727 if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2728 !CvLVALUE(cv))
2729 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
4a925ff6
GS
2730 /* warning must come *after* we fully set up the context
2731 * stuff so that __WARN__ handlers can safely dounwind()
2732 * if they want to
2733 */
2b9dff67 2734 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
4a925ff6
GS
2735 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2736 sub_crush_depth(cv);
a0d0e21e
LW
2737 RETURNOP(CvSTART(cv));
2738 }
f1025168 2739 else {
3a76ca88 2740 I32 markix = TOPMARK;
f1025168 2741
3a76ca88 2742 PUTBACK;
f1025168 2743
3a76ca88
RGS
2744 if (!hasargs) {
2745 /* Need to copy @_ to stack. Alternative may be to
2746 * switch stack to @_, and copy return values
2747 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2748 AV * const av = GvAV(PL_defgv);
2749 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2750
2751 if (items) {
2752 /* Mark is at the end of the stack. */
2753 EXTEND(SP, items);
2754 Copy(AvARRAY(av), SP + 1, items, SV*);
2755 SP += items;
2756 PUTBACK ;
2757 }
2758 }
2759 /* We assume first XSUB in &DB::sub is the called one. */
2760 if (PL_curcopdb) {
2761 SAVEVPTR(PL_curcop);
2762 PL_curcop = PL_curcopdb;
2763 PL_curcopdb = NULL;
2764 }
2765 /* Do we need to open block here? XXXX */
72df79cf 2766
2767 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2768 assert(CvXSUB(cv));
16c91539 2769 CvXSUB(cv)(aTHX_ cv);
3a76ca88
RGS
2770
2771 /* Enforce some sanity in scalar context. */
2772 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2773 if (markix > PL_stack_sp - PL_stack_base)
2774 *(PL_stack_base + markix) = &PL_sv_undef;
2775 else
2776 *(PL_stack_base + markix) = *PL_stack_sp;
2777 PL_stack_sp = PL_stack_base + markix;
2778 }
a57c6685 2779 LEAVE;
f1025168
NC
2780 return NORMAL;
2781 }
a0d0e21e
LW
2782}
2783
44a8e56a 2784void
864dbfa3 2785Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 2786{
7918f24d
NC
2787 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2788
44a8e56a 2789 if (CvANON(cv))
9014280d 2790 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 2791 else {
aec46f14 2792 SV* const tmpstr = sv_newmortal();
6136c704 2793 gv_efullname3(tmpstr, CvGV(cv), NULL);
35c1215d 2794 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
be2597df 2795 SVfARG(tmpstr));
44a8e56a
PP
2796 }
2797}
2798
a0d0e21e
LW
2799PP(pp_aelem)
2800{
97aff369 2801 dVAR; dSP;
a0d0e21e 2802 SV** svp;
a3b680e6 2803 SV* const elemsv = POPs;
d804643f 2804 IV elem = SvIV(elemsv);
502c6561 2805 AV *const av = MUTABLE_AV(POPs);
e1ec3a88
AL
2806 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2807 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
4ad10a0b
VP
2808 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2809 bool preeminent = TRUE;
be6c24e0 2810 SV *sv;
a0d0e21e 2811
e35c1634 2812 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
95b63a38
JH
2813 Perl_warner(aTHX_ packWARN(WARN_MISC),
2814 "Use of reference \"%"SVf"\" as array index",
be2597df 2815 SVfARG(elemsv));
a0d0e21e
LW
2816 if (SvTYPE(av) != SVt_PVAV)
2817 RETPUSHUNDEF;
4ad10a0b
VP
2818
2819 if (localizing) {
2820 MAGIC *mg;
2821 HV *stash;
2822
2823 /* If we can determine whether the element exist,
2824 * Try to preserve the existenceness of a tied array
2825 * element by using EXISTS and DELETE if possible.
2826 * Fallback to FETCH and STORE otherwise. */
2827 if (SvCANEXISTDELETE(av))
2828 preeminent = av_exists(av, elem);
2829 }
2830
68dc0745 2831 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2832 if (lval) {
2b573ace 2833#ifdef PERL_MALLOC_WRAP
2b573ace 2834 if (SvUOK(elemsv)) {
a9c4fd4e 2835 const UV uv = SvUV(elemsv);
2b573ace
JH
2836 elem = uv > IV_MAX ? IV_MAX : uv;
2837 }
2838 else if (SvNOK(elemsv))
2839 elem = (IV)SvNV(elemsv);
a3b680e6
AL
2840 if (elem > 0) {
2841 static const char oom_array_extend[] =
2842 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 2843 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 2844 }
2b573ace 2845#endif
3280af22 2846 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2847 SV* lv;
2848 if (!defer)
cea2e8a9 2849 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2850 lv = sv_newmortal();
2851 sv_upgrade(lv, SVt_PVLV);
2852 LvTYPE(lv) = 'y';
a0714e2c 2853 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
b37c2d43 2854 LvTARG(lv) = SvREFCNT_inc_simple(av);
68dc0745
PP
2855 LvTARGOFF(lv) = elem;
2856 LvTARGLEN(lv) = 1;
2857 PUSHs(lv);
2858 RETURN;
2859 }
4ad10a0b
VP
2860 if (localizing) {
2861 if (preeminent)
2862 save_aelem(av, elem, svp);
2863 else
2864 SAVEADELETE(av, elem);
2865 }
9026059d
GG
2866 else if (PL_op->op_private & OPpDEREF) {
2867 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2868 RETURN;
2869 }
a0d0e21e 2870 }
3280af22 2871 sv = (svp ? *svp : &PL_sv_undef);
39cf747a 2872 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 2873 mg_get(sv);
be6c24e0 2874 PUSHs(sv);
a0d0e21e
LW
2875 RETURN;
2876}
2877
9026059d 2878SV*
864dbfa3 2879Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 2880{
7918f24d
NC
2881 PERL_ARGS_ASSERT_VIVIFY_REF;
2882
5b295bef 2883 SvGETMAGIC(sv);
02a9e968
CS
2884 if (!SvOK(sv)) {
2885 if (SvREADONLY(sv))
6ad8f254 2886 Perl_croak_no_modify(aTHX);
43230e26 2887 prepare_SV_for_RV(sv);
68dc0745 2888 switch (to_what) {
5f05dabc 2889 case OPpDEREF_SV:
561b68a9 2890 SvRV_set(sv, newSV(0));
5f05dabc
PP
2891 break;
2892 case OPpDEREF_AV:
ad64d0ec 2893 SvRV_set(sv, MUTABLE_SV(newAV()));
5f05dabc
PP
2894 break;
2895 case OPpDEREF_HV:
ad64d0ec 2896 SvRV_set(sv, MUTABLE_SV(newHV()));
5f05dabc
PP
2897 break;
2898 }
02a9e968
CS
2899 SvROK_on(sv);
2900 SvSETMAGIC(sv);
7e482323 2901 SvGETMAGIC(sv);
02a9e968 2902 }
9026059d
GG
2903 if (SvGMAGICAL(sv)) {
2904 /* copy the sv without magic to prevent magic from being
2905 executed twice */
2906 SV* msv = sv_newmortal();
2907 sv_setsv_nomg(msv, sv);
2908 return msv;
2909 }
2910 return sv;
02a9e968
CS
2911}
2912
a0d0e21e
LW
2913PP(pp_method)
2914{
97aff369 2915 dVAR; dSP;
890ce7af 2916 SV* const sv = TOPs;
f5d5a27c
CS
2917
2918 if (SvROK(sv)) {
890ce7af 2919 SV* const rsv = SvRV(sv);
f5d5a27c
CS
2920 if (SvTYPE(rsv) == SVt_PVCV) {
2921 SETs(rsv);
2922 RETURN;
2923 }
2924 }
2925
4608196e 2926 SETs(method_common(sv, NULL));
f5d5a27c
CS
2927 RETURN;
2928}
2929
2930PP(pp_method_named)
2931{
97aff369 2932 dVAR; dSP;
890ce7af 2933 SV* const sv = cSVOP_sv;
c158a4fd 2934 U32 hash = SvSHARED_HASH(sv);
f5d5a27c
CS
2935
2936 XPUSHs(method_common(sv, &hash));
2937 RETURN;
2938}
2939
2940STATIC SV *
2941S_method_common(pTHX_ SV* meth, U32* hashp)
2942{
97aff369 2943 dVAR;
a0d0e21e
LW
2944 SV* ob;
2945 GV* gv;
56304f61 2946 HV* stash;
a0714e2c 2947 SV *packsv = NULL;
f226e9be
FC
2948 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2949 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2950 "package or object reference", SVfARG(meth)),
2951 (SV *)NULL)
2952 : *(PL_stack_base + TOPMARK + 1);
f5d5a27c 2953
7918f24d
NC
2954 PERL_ARGS_ASSERT_METHOD_COMMON;
2955
4f1b7578 2956 if (!sv)
a214957f
VP
2957 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2958 SVfARG(meth));
4f1b7578 2959
5b295bef 2960 SvGETMAGIC(sv);
a0d0e21e 2961 if (SvROK(sv))
ad64d0ec 2962 ob = MUTABLE_SV(SvRV(sv));
a0d0e21e
LW
2963 else {
2964 GV* iogv;
f937af42
BF
2965 STRLEN packlen;
2966 const char * packname = NULL;
da6b625f 2967 bool packname_is_utf8 = FALSE;
a0d0e21e 2968
af09ea45 2969 /* this isn't a reference */
da6b625f
FC
2970 if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2971 const HE* const he =
2972 (const HE *)hv_common_key_len(
2973 PL_stashcache, packname,
2974 packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2975 );
2976
081fc587 2977 if (he) {
5e6396ae 2978 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
081fc587
AB
2979 goto fetch;
2980 }
2981 }
2982
a0d0e21e 2983 if (!SvOK(sv) ||
05f5af9a 2984 !(packname) ||
da6b625f
FC
2985 !(iogv = gv_fetchpvn_flags(
2986 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2987 )) ||
ad64d0ec 2988 !(ob=MUTABLE_SV(GvIO(iogv))))
a0d0e21e 2989 {
af09ea45 2990 /* this isn't the name of a filehandle either */
1c846c1f 2991 if (!packname ||
fd400ab9 2992 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 2993 ? !isIDFIRST_utf8((U8*)packname)
d47f310d 2994 : !isIDFIRST_L1((U8)*packname)
834a4ddd
LW
2995 ))
2996 {
d5e45555 2997 /* diag_listed_as: Can't call method "%s" without a package or object reference */
a214957f
VP
2998 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
2999 SVfARG(meth),
f5d5a27c
CS
3000 SvOK(sv) ? "without a package or object reference"
3001 : "on an undefined value");
834a4ddd 3002 }
af09ea45 3003 /* assume it's a package name */
f937af42 3004 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
0dae17bd
GS
3005 if (!stash)
3006 packsv = sv;
081fc587 3007 else {
d4c19fe8 3008 SV* const ref = newSViv(PTR2IV(stash));
f937af42 3009 (void)hv_store(PL_stashcache, packname,
c60dbbc3 3010 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
7e8961ec 3011 }
ac91690f 3012 goto fetch;
a0d0e21e 3013 }
af09ea45 3014 /* it _is_ a filehandle name -- replace with a reference */
ad64d0ec 3015 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
a0d0e21e
LW
3016 }
3017
af09ea45 3018 /* if we got here, ob should be a reference or a glob */
f0d43078 3019 if (!ob || !(SvOBJECT(ob)
6e592b3a
BM
3020 || (SvTYPE(ob) == SVt_PVGV
3021 && isGV_with_GP(ob)
159b6efe 3022 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
f0d43078
GS
3023 && SvOBJECT(ob))))
3024 {
b375e37b
BF
3025 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3026 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3027 ? newSVpvs_flags("DOES", SVs_TEMP)
3028 : meth));
f0d43078 3029 }
a0d0e21e 3030
56304f61 3031 stash = SvSTASH(ob);
a0d0e21e 3032
ac91690f 3033 fetch:
af09ea45
IK
3034 /* NOTE: stash may be null, hope hv_fetch_ent and
3035 gv_fetchmethod can cope (it seems they can) */
3036
f5d5a27c
CS
3037 /* shortcut for simple names */
3038 if (hashp) {
b464bac0 3039 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
f5d5a27c 3040 if (he) {
159b6efe 3041 gv = MUTABLE_GV(HeVAL(he));
f5d5a27c 3042 if (isGV(gv) && GvCV(gv) &&
e1a479c5 3043 (!GvCVGEN(gv) || GvCVGEN(gv)
dd69841b 3044 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
ad64d0ec 3045 return MUTABLE_SV(GvCV(gv));
f5d5a27c
CS
3046 }
3047 }
3048
f937af42
BF
3049 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3050 meth, GV_AUTOLOAD | GV_CROAK);
9b9d0b15 3051
256d1bb2 3052 assert(gv);
9b9d0b15 3053
ad64d0ec 3054 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
a0d0e21e 3055}
241d1a3b
NC
3056
3057/*
3058 * Local variables:
3059 * c-indentation-style: bsd
3060 * c-basic-offset: 4
14d04a33 3061 * indent-tabs-mode: nil
241d1a3b
NC
3062 * End:
3063 *
14d04a33 3064 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3065 */