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