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