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