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