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