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