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