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