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