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