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