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