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