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