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