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