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