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