This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Break out the item normalisation code into a method normalise_items.
[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,
241d1a3b 4 * 2000, 2001, 2002, 2003, 2004, 2005, 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;
c75ab21a
RH
204 const char *rpv;
205 bool rbyte;
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;
6a077020
DM
611 AV *av = PL_op->op_flags & OPf_SPECIAL ?
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;
5637b936
NC
1039 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
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)) {
14befaf4 1314 MAGIC* 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) {
1422 MAGIC* mg = 0;
1423 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
14befaf4 1424 mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1425 if (!mg) {
14befaf4
DM
1426 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1427 mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1428 }
cf93c79d
IZ
1429 if (rx->startp[0] != -1) {
1430 mg->mg_len = rx->endp[0];
d9f97599 1431 if (rx->startp[0] == rx->endp[0])
748a9306
LW
1432 mg->mg_flags |= MGf_MINMATCH;
1433 else
1434 mg->mg_flags &= ~MGf_MINMATCH;
1435 }
a0d0e21e 1436 }
4633a7c4 1437 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1438 RETPUSHYES;
1439 }
1440
f722798b 1441yup: /* Confirmed by INTUIT */
72311751
GS
1442 if (rxtainted)
1443 RX_MATCH_TAINTED_on(rx);
1444 TAINT_IF(RX_MATCH_TAINTED(rx));
3280af22 1445 PL_curpm = pm;
d65afb4b
HS
1446 if (dynpm->op_pmflags & PMf_ONCE)
1447 dynpm->op_pmdynflags |= PMdf_USED;
cf93c79d
IZ
1448 if (RX_MATCH_COPIED(rx))
1449 Safefree(rx->subbeg);
1450 RX_MATCH_COPIED_off(rx);
1451 rx->subbeg = Nullch;
a0d0e21e 1452 if (global) {
5c144d81
NC
1453 /* FIXME - should rx->subbeg be const char *? */
1454 rx->subbeg = (char *) truebase;
cf93c79d 1455 rx->startp[0] = s - truebase;
a30b2f1f 1456 if (RX_MATCH_UTF8(rx)) {
0bcc34c2 1457 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
60aeb6fd
NIS
1458 rx->endp[0] = t - truebase;
1459 }
1460 else {
1461 rx->endp[0] = s - truebase + rx->minlen;
1462 }
cf93c79d 1463 rx->sublen = strend - truebase;
a0d0e21e 1464 goto gotcha;
1c846c1f 1465 }
14977893
JH
1466 if (PL_sawampersand) {
1467 I32 off;
f8c7b90f 1468#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
1469 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1470 if (DEBUG_C_TEST) {
1471 PerlIO_printf(Perl_debug_log,
1472 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1473 (int) SvTYPE(TARG), truebase, t,
1474 (int)(t-truebase));
1475 }
1476 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
555831ce 1477 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
ed252734
NC
1478 assert (SvPOKp(rx->saved_copy));
1479 } else
1480#endif
1481 {
14977893 1482
ed252734 1483 rx->subbeg = savepvn(t, strend - t);
f8c7b90f 1484#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
1485 rx->saved_copy = Nullsv;
1486#endif
1487 }
14977893
JH
1488 rx->sublen = strend - t;
1489 RX_MATCH_COPIED_on(rx);
1490 off = rx->startp[0] = s - t;
1491 rx->endp[0] = off + rx->minlen;
1492 }
1493 else { /* startp/endp are used by @- @+. */
1494 rx->startp[0] = s - truebase;
1495 rx->endp[0] = s - truebase + rx->minlen;
1496 }
2d862feb 1497 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
4633a7c4 1498 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1499 RETPUSHYES;
1500
1501nope:
a0d0e21e 1502ret_no:
d65afb4b 1503 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e 1504 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
14befaf4 1505 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1506 if (mg)
565764a8 1507 mg->mg_len = -1;
a0d0e21e
LW
1508 }
1509 }
4633a7c4 1510 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1511 if (gimme == G_ARRAY)
1512 RETURN;
1513 RETPUSHNO;
1514}
1515
1516OP *
864dbfa3 1517Perl_do_readline(pTHX)
a0d0e21e 1518{
27da23d5 1519 dVAR; dSP; dTARGETSTACKED;
a0d0e21e
LW
1520 register SV *sv;
1521 STRLEN tmplen = 0;
1522 STRLEN offset;
760ac839 1523 PerlIO *fp;
a3b680e6
AL
1524 register IO * const io = GvIO(PL_last_in_gv);
1525 register const I32 type = PL_op->op_type;
1526 const I32 gimme = GIMME_V;
e79b0511 1527 MAGIC *mg;
a0d0e21e 1528
5b468f54 1529 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
e79b0511 1530 PUSHMARK(SP);
5b468f54 1531 XPUSHs(SvTIED_obj((SV*)io, mg));
e79b0511
PP
1532 PUTBACK;
1533 ENTER;
864dbfa3 1534 call_method("READLINE", gimme);
e79b0511
PP
1535 LEAVE;
1536 SPAGAIN;
0b7c7b4f
HS
1537 if (gimme == G_SCALAR) {
1538 SV* result = POPs;
1539 SvSetSV_nosteal(TARG, result);
1540 PUSHTARG;
1541 }
e79b0511
PP
1542 RETURN;
1543 }
a0d0e21e
LW
1544 fp = Nullfp;
1545 if (io) {
1546 fp = IoIFP(io);
1547 if (!fp) {
1548 if (IoFLAGS(io) & IOf_ARGV) {
1549 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1550 IoLINES(io) = 0;
3280af22 1551 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1552 IoFLAGS(io) &= ~IOf_START;
9d116dd7 1553 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
c69033f2 1554 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
3280af22 1555 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1556 fp = IoIFP(io);
1557 goto have_fp;
a0d0e21e
LW
1558 }
1559 }
3280af22 1560 fp = nextargv(PL_last_in_gv);
a0d0e21e 1561 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1562 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1563 }
1564 }
0d44d22b
NC
1565 else if (type == OP_GLOB)
1566 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1567 }
1568 else if (type == OP_GLOB)
1569 SP--;
a00b5bd3 1570 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
4c80c0b2 1571 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
a00b5bd3 1572 }
a0d0e21e
LW
1573 }
1574 if (!fp) {
041457d9
DM
1575 if ((!io || !(IoFLAGS(io) & IOf_START))
1576 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1577 {
3f4520fe 1578 if (type == OP_GLOB)
9014280d 1579 Perl_warner(aTHX_ packWARN(WARN_GLOB),
af8c498a
GS
1580 "glob failed (can't start child: %s)",
1581 Strerror(errno));
69282e91 1582 else
bc37a18f 1583 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
3f4520fe 1584 }
54310121 1585 if (gimme == G_SCALAR) {
79628082 1586 /* undef TARG, and push that undefined value */
ba92458f
AE
1587 if (type != OP_RCATLINE) {
1588 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1589 SvOK_off(TARG);
ba92458f 1590 }
a0d0e21e
LW
1591 PUSHTARG;
1592 }
1593 RETURN;
1594 }
a2008d6d 1595 have_fp:
54310121 1596 if (gimme == G_SCALAR) {
a0d0e21e 1597 sv = TARG;
9607fc9c
PP
1598 if (SvROK(sv))
1599 sv_unref(sv);
862a34c6 1600 SvUPGRADE(sv, SVt_PV);
a0d0e21e 1601 tmplen = SvLEN(sv); /* remember if already alloced */
bc44a8a2 1602 if (!tmplen && !SvREADONLY(sv))
a0d0e21e 1603 Sv_Grow(sv, 80); /* try short-buffering it */
2b5e58c4
AMS
1604 offset = 0;
1605 if (type == OP_RCATLINE && SvOK(sv)) {
1606 if (!SvPOK(sv)) {
8b6b16e7 1607 SvPV_force_nolen(sv);
2b5e58c4 1608 }
a0d0e21e 1609 offset = SvCUR(sv);
2b5e58c4 1610 }
a0d0e21e 1611 }
54310121
PP
1612 else {
1613 sv = sv_2mortal(NEWSV(57, 80));
1614 offset = 0;
1615 }
fbad3eb5 1616
3887d568
AP
1617 /* This should not be marked tainted if the fp is marked clean */
1618#define MAYBE_TAINT_LINE(io, sv) \
1619 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1620 TAINT; \
1621 SvTAINTED_on(sv); \
1622 }
1623
684bef36 1624/* delay EOF state for a snarfed empty file */
fbad3eb5 1625#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1626 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1627 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1628
a0d0e21e 1629 for (;;) {
09e8efcc 1630 PUTBACK;
fbad3eb5 1631 if (!sv_gets(sv, fp, offset)
2d726892
TF
1632 && (type == OP_GLOB
1633 || SNARF_EOF(gimme, PL_rs, io, sv)
1634 || PerlIO_error(fp)))
fbad3eb5 1635 {
760ac839 1636 PerlIO_clearerr(fp);
a0d0e21e 1637 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1638 fp = nextargv(PL_last_in_gv);
a0d0e21e
LW
1639 if (fp)
1640 continue;
3280af22 1641 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1642 }
1643 else if (type == OP_GLOB) {
e476b1b5 1644 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
9014280d 1645 Perl_warner(aTHX_ packWARN(WARN_GLOB),
4eb79ab5 1646 "glob failed (child exited with status %d%s)",
894356b3 1647 (int)(STATUS_CURRENT >> 8),
cf494569 1648 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1649 }
a0d0e21e 1650 }
54310121 1651 if (gimme == G_SCALAR) {
ba92458f
AE
1652 if (type != OP_RCATLINE) {
1653 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1654 SvOK_off(TARG);
ba92458f 1655 }
09e8efcc 1656 SPAGAIN;
a0d0e21e
LW
1657 PUSHTARG;
1658 }
3887d568 1659 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1660 RETURN;
1661 }
3887d568 1662 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1663 IoLINES(io)++;
b9fee9ba 1664 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1665 SvSETMAGIC(sv);
09e8efcc 1666 SPAGAIN;
a0d0e21e 1667 XPUSHs(sv);
a0d0e21e
LW
1668 if (type == OP_GLOB) {
1669 char *tmps;
349d4f2f 1670 const char *t1;
a0d0e21e 1671
3280af22 1672 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
c07a80fd 1673 tmps = SvEND(sv) - 1;
aa07b2f6 1674 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 1675 *tmps = '\0';
b162af07 1676 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
1677 }
1678 }
349d4f2f
NC
1679 for (t1 = SvPVX_const(sv); *t1; t1++)
1680 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1681 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
a0d0e21e 1682 break;
349d4f2f 1683 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1684 (void)POPs; /* Unmatched wildcard? Chuck it... */
1685 continue;
1686 }
2d79bf7f 1687 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
349d4f2f 1688 const U8 *s = (const U8*)SvPVX_const(sv) + offset;
7fc63493
AL
1689 const STRLEN len = SvCUR(sv) - offset;
1690 const U8 *f;
2d79bf7f 1691
ce44635a 1692 if (ckWARN(WARN_UTF8) &&
3a09494c 1693 !is_utf8_string_loc(s, len, &f))
2d79bf7f
JH
1694 /* Emulate :encoding(utf8) warning in the same case. */
1695 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1696 "utf8 \"\\x%02X\" does not map to Unicode",
1697 f < (U8*)SvEND(sv) ? *f : 0);
a0d0e21e 1698 }
54310121 1699 if (gimme == G_ARRAY) {
a0d0e21e 1700 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 1701 SvPV_shrink_to_cur(sv);
a0d0e21e
LW
1702 }
1703 sv = sv_2mortal(NEWSV(58, 80));
1704 continue;
1705 }
54310121 1706 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 1707 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
1708 const STRLEN new_len
1709 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 1710 SvPV_renew(sv, new_len);
a0d0e21e
LW
1711 }
1712 RETURN;
1713 }
1714}
1715
1716PP(pp_enter)
1717{
27da23d5 1718 dVAR; dSP;
c09156bb 1719 register PERL_CONTEXT *cx;
533c011a 1720 I32 gimme = OP_GIMME(PL_op, -1);
a0d0e21e 1721
54310121
PP
1722 if (gimme == -1) {
1723 if (cxstack_ix >= 0)
1724 gimme = cxstack[cxstack_ix].blk_gimme;
1725 else
1726 gimme = G_SCALAR;
1727 }
a0d0e21e
LW
1728
1729 ENTER;
1730
1731 SAVETMPS;
924508f0 1732 PUSHBLOCK(cx, CXt_BLOCK, SP);
a0d0e21e
LW
1733
1734 RETURN;
1735}
1736
1737PP(pp_helem)
1738{
39644a26 1739 dSP;
760ac839 1740 HE* he;
ae77835f 1741 SV **svp;
a0d0e21e 1742 SV *keysv = POPs;
a0d0e21e 1743 HV *hv = (HV*)POPs;
a3b680e6
AL
1744 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1745 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1746 SV *sv;
c158a4fd 1747 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
9c5ffd7c 1748 I32 preeminent = 0;
a0d0e21e 1749
ae77835f 1750 if (SvTYPE(hv) == SVt_PVHV) {
8d1f198f
DM
1751 if (PL_op->op_private & OPpLVAL_INTRO) {
1752 MAGIC *mg;
1753 HV *stash;
1754 /* does the element we're localizing already exist? */
c39e6ab0 1755 preeminent =
8d1f198f
DM
1756 /* can we determine whether it exists? */
1757 ( !SvRMAGICAL(hv)
1758 || mg_find((SV*)hv, PERL_MAGIC_env)
1759 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1760 /* Try to preserve the existenceness of a tied hash
1761 * element by using EXISTS and DELETE if possible.
1762 * Fallback to FETCH and STORE otherwise */
1763 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1764 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1765 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1766 )
1767 ) ? hv_exists_ent(hv, keysv, 0) : 1;
c39e6ab0 1768
8d1f198f 1769 }
1c846c1f 1770 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
97fcbf96 1771 svp = he ? &HeVAL(he) : 0;
ae77835f 1772 }
c750a3ec 1773 else {
a0d0e21e 1774 RETPUSHUNDEF;
c750a3ec 1775 }
a0d0e21e 1776 if (lval) {
3280af22 1777 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
1778 SV* lv;
1779 SV* key2;
2d8e6c8d 1780 if (!defer) {
ce5030a2 1781 DIE(aTHX_ PL_no_helem_sv, keysv);
2d8e6c8d 1782 }
68dc0745
PP
1783 lv = sv_newmortal();
1784 sv_upgrade(lv, SVt_PVLV);
1785 LvTYPE(lv) = 'y';
14befaf4 1786 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
68dc0745
PP
1787 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1788 LvTARG(lv) = SvREFCNT_inc(hv);
1789 LvTARGLEN(lv) = 1;
1790 PUSHs(lv);
1791 RETURN;
1792 }
533c011a 1793 if (PL_op->op_private & OPpLVAL_INTRO) {
bfcb3514 1794 if (HvNAME_get(hv) && isGV(*svp))
533c011a 1795 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1f5346dc
SC
1796 else {
1797 if (!preeminent) {
1798 STRLEN keylen;
e62f0680 1799 const char * const key = SvPV_const(keysv, keylen);
57813020 1800 SAVEDELETE(hv, savepvn(key,keylen), keylen);
bfc4de9f 1801 } else
1f5346dc
SC
1802 save_helem(hv, keysv, svp);
1803 }
5f05dabc 1804 }
533c011a
NIS
1805 else if (PL_op->op_private & OPpDEREF)
1806 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 1807 }
3280af22 1808 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
1809 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1810 * Pushing the magical RHS on to the stack is useless, since
1811 * that magic is soon destined to be misled by the local(),
1812 * and thus the later pp_sassign() will fail to mg_get() the
1813 * old value. This should also cure problems with delayed
1814 * mg_get()s. GSAR 98-07-03 */
1815 if (!lval && SvGMAGICAL(sv))
1816 sv = sv_mortalcopy(sv);
1817 PUSHs(sv);
a0d0e21e
LW
1818 RETURN;
1819}
1820
1821PP(pp_leave)
1822{
27da23d5 1823 dVAR; dSP;
c09156bb 1824 register PERL_CONTEXT *cx;
a0d0e21e
LW
1825 SV **newsp;
1826 PMOP *newpm;
1827 I32 gimme;
1828
533c011a 1829 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1830 cx = &cxstack[cxstack_ix];
3280af22 1831 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
a0d0e21e
LW
1832 }
1833
1834 POPBLOCK(cx,newpm);
1835
533c011a 1836 gimme = OP_GIMME(PL_op, -1);
54310121
PP
1837 if (gimme == -1) {
1838 if (cxstack_ix >= 0)
1839 gimme = cxstack[cxstack_ix].blk_gimme;
1840 else
1841 gimme = G_SCALAR;
1842 }
a0d0e21e 1843
a1f49e72 1844 TAINT_NOT;
54310121
PP
1845 if (gimme == G_VOID)
1846 SP = newsp;
1847 else if (gimme == G_SCALAR) {
a3b680e6 1848 register SV **mark;
54310121 1849 MARK = newsp + 1;
09256e2f 1850 if (MARK <= SP) {
54310121
PP
1851 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1852 *MARK = TOPs;
1853 else
1854 *MARK = sv_mortalcopy(TOPs);
09256e2f 1855 } else {
54310121 1856 MEXTEND(mark,0);
3280af22 1857 *MARK = &PL_sv_undef;
a0d0e21e 1858 }
54310121 1859 SP = MARK;
a0d0e21e 1860 }
54310121 1861 else if (gimme == G_ARRAY) {
a1f49e72 1862 /* in case LEAVE wipes old return values */
a3b680e6 1863 register SV **mark;
a1f49e72
CS
1864 for (mark = newsp + 1; mark <= SP; mark++) {
1865 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 1866 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
1867 TAINT_NOT; /* Each item is independent */
1868 }
1869 }
a0d0e21e 1870 }
3280af22 1871 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW
1872
1873 LEAVE;
1874
1875 RETURN;
1876}
1877
1878PP(pp_iter)
1879{
39644a26 1880 dSP;
c09156bb 1881 register PERL_CONTEXT *cx;
dc09a129 1882 SV *sv, *oldsv;
4633a7c4 1883 AV* av;
1d7c1841 1884 SV **itersvp;
a0d0e21e 1885
924508f0 1886 EXTEND(SP, 1);
a0d0e21e 1887 cx = &cxstack[cxstack_ix];
6b35e009 1888 if (CxTYPE(cx) != CXt_LOOP)
cea2e8a9 1889 DIE(aTHX_ "panic: pp_iter");
a0d0e21e 1890
1d7c1841 1891 itersvp = CxITERVAR(cx);
4633a7c4 1892 av = cx->blk_loop.iterary;
89ea2908
GA
1893 if (SvTYPE(av) != SVt_PVAV) {
1894 /* iterate ($min .. $max) */
1895 if (cx->blk_loop.iterlval) {
1896 /* string increment */
1897 register SV* cur = cx->blk_loop.iterlval;
4fe3f0fa 1898 STRLEN maxlen = 0;
83003860 1899 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
89ea2908 1900 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1d7c1841 1901 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1902 /* safe to reuse old SV */
1d7c1841 1903 sv_setsv(*itersvp, cur);
eaa5c2d6 1904 }
1c846c1f 1905 else
eaa5c2d6
GA
1906 {
1907 /* we need a fresh SV every time so that loop body sees a
1908 * completely new SV for closures/references to work as
1909 * they used to */
dc09a129 1910 oldsv = *itersvp;
1d7c1841 1911 *itersvp = newSVsv(cur);
dc09a129 1912 SvREFCNT_dec(oldsv);
eaa5c2d6 1913 }
aa07b2f6 1914 if (strEQ(SvPVX_const(cur), max))
89ea2908
GA
1915 sv_setiv(cur, 0); /* terminate next time */
1916 else
1917 sv_inc(cur);
1918 RETPUSHYES;
1919 }
1920 RETPUSHNO;
1921 }
1922 /* integer increment */
1923 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1924 RETPUSHNO;
7f61b687 1925
3db8f154 1926 /* don't risk potential race */
1d7c1841 1927 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1928 /* safe to reuse old SV */
1d7c1841 1929 sv_setiv(*itersvp, cx->blk_loop.iterix++);
eaa5c2d6 1930 }
1c846c1f 1931 else
eaa5c2d6
GA
1932 {
1933 /* we need a fresh SV every time so that loop body sees a
1934 * completely new SV for closures/references to work as they
1935 * used to */
dc09a129 1936 oldsv = *itersvp;
1d7c1841 1937 *itersvp = newSViv(cx->blk_loop.iterix++);
dc09a129 1938 SvREFCNT_dec(oldsv);
eaa5c2d6 1939 }
89ea2908
GA
1940 RETPUSHYES;
1941 }
1942
1943 /* iterate array */
ef3e5ea9
NC
1944 if (PL_op->op_private & OPpITER_REVERSED) {
1945 /* In reverse, use itermax as the min :-) */
c491ecac 1946 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
ef3e5ea9 1947 RETPUSHNO;
a0d0e21e 1948
ef3e5ea9 1949 if (SvMAGICAL(av) || AvREIFY(av)) {
6e585ca0 1950 SV ** const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
0bcc34c2 1951 sv = svp ? *svp : Nullsv;
ef3e5ea9
NC
1952 }
1953 else {
6e585ca0 1954 sv = AvARRAY(av)[--cx->blk_loop.iterix];
ef3e5ea9 1955 }
d42935ef
JH
1956 }
1957 else {
ef3e5ea9
NC
1958 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1959 AvFILL(av)))
1960 RETPUSHNO;
1961
1962 if (SvMAGICAL(av) || AvREIFY(av)) {
0bcc34c2
AL
1963 SV ** const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1964 sv = svp ? *svp : Nullsv;
ef3e5ea9
NC
1965 }
1966 else {
1967 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1968 }
d42935ef 1969 }
ef3e5ea9 1970
0565a181 1971 if (sv && SvIS_FREED(sv)) {
cccede53 1972 *itersvp = Nullsv;
b6c83531 1973 Perl_croak(aTHX_ "Use of freed value in iteration");
cccede53
DM
1974 }
1975
d42935ef 1976 if (sv)
a0d0e21e 1977 SvTEMP_off(sv);
a0d0e21e 1978 else
3280af22 1979 sv = &PL_sv_undef;
8b530633 1980 if (av != PL_curstack && sv == &PL_sv_undef) {
5f05dabc 1981 SV *lv = cx->blk_loop.iterlval;
71be2cbc
PP
1982 if (lv && SvREFCNT(lv) > 1) {
1983 SvREFCNT_dec(lv);
1984 lv = Nullsv;
1985 }
5f05dabc
PP
1986 if (lv)
1987 SvREFCNT_dec(LvTARG(lv));
1988 else {
68dc0745 1989 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
5f05dabc 1990 sv_upgrade(lv, SVt_PVLV);
5f05dabc 1991 LvTYPE(lv) = 'y';
14befaf4 1992 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
5f05dabc
PP
1993 }
1994 LvTARG(lv) = SvREFCNT_inc(av);
1995 LvTARGOFF(lv) = cx->blk_loop.iterix;
42718184 1996 LvTARGLEN(lv) = (STRLEN)UV_MAX;
5f05dabc
PP
1997 sv = (SV*)lv;
1998 }
a0d0e21e 1999
dc09a129 2000 oldsv = *itersvp;
1d7c1841 2001 *itersvp = SvREFCNT_inc(sv);
dc09a129
DM
2002 SvREFCNT_dec(oldsv);
2003
a0d0e21e
LW
2004 RETPUSHYES;
2005}
2006
2007PP(pp_subst)
2008{
39644a26 2009 dSP; dTARG;
a0d0e21e
LW
2010 register PMOP *pm = cPMOP;
2011 PMOP *rpm = pm;
2012 register SV *dstr;
2013 register char *s;
2014 char *strend;
2015 register char *m;
5c144d81 2016 const char *c;
a0d0e21e
LW
2017 register char *d;
2018 STRLEN clen;
2019 I32 iters = 0;
2020 I32 maxiters;
2021 register I32 i;
2022 bool once;
71be2cbc 2023 bool rxtainted;
a0d0e21e 2024 char *orig;
22e551b9 2025 I32 r_flags;
aaa362c4 2026 register REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
2027 STRLEN len;
2028 int force_on_match = 0;
0bcc34c2 2029 const I32 oldsave = PL_savestack_ix;
792b2c16 2030 STRLEN slen;
f272994b 2031 bool doutf8 = FALSE;
f8c7b90f 2032#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2033 bool is_cow;
2034#endif
db79b45b 2035 SV *nsv = Nullsv;
a0d0e21e 2036
5cd24f17
PP
2037 /* known replacement string? */
2038 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
533c011a 2039 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 2040 TARG = POPs;
59f00321
RGS
2041 else if (PL_op->op_private & OPpTARGET_MY)
2042 GETTARGET;
a0d0e21e 2043 else {
54b9620d 2044 TARG = DEFSV;
a0d0e21e 2045 EXTEND(SP,1);
1c846c1f 2046 }
d9f424b2 2047
f8c7b90f 2048#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2049 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2050 because they make integers such as 256 "false". */
2051 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2052#else
765f542d
NC
2053 if (SvIsCOW(TARG))
2054 sv_force_normal_flags(TARG,0);
ed252734
NC
2055#endif
2056 if (
f8c7b90f 2057#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2058 !is_cow &&
2059#endif
2060 (SvREADONLY(TARG)
4ce457a6
TP
2061 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2062 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
d470f89e 2063 DIE(aTHX_ PL_no_modify);
8ec5e241
NIS
2064 PUTBACK;
2065
d5263905 2066 s = SvPV_mutable(TARG, len);
68dc0745 2067 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 2068 force_on_match = 1;
b3eb6a9b 2069 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22
NIS
2070 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2071 if (PL_tainted)
b3eb6a9b 2072 rxtainted |= 2;
9212bbba 2073 TAINT_NOT;
a12c0f56 2074
a30b2f1f 2075 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 2076
a0d0e21e
LW
2077 force_it:
2078 if (!pm || !s)
2269b42e 2079 DIE(aTHX_ "panic: pp_subst");
a0d0e21e
LW
2080
2081 strend = s + len;
a30b2f1f 2082 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH
2083 maxiters = 2 * slen + 10; /* We can match twice at each
2084 position, once with zero-length,
2085 second time with non-zero. */
a0d0e21e 2086
3280af22
NIS
2087 if (!rx->prelen && PL_curpm) {
2088 pm = PL_curpm;
aaa362c4 2089 rx = PM_GETRE(pm);
a0d0e21e 2090 }
22e551b9 2091 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
ed252734 2092 ? REXEC_COPY_STR : 0;
f722798b 2093 if (SvSCREAM(TARG))
22e551b9 2094 r_flags |= REXEC_SCREAM;
7fba1cd6 2095
a0d0e21e 2096 orig = m = s;
f722798b 2097 if (rx->reganch & RE_USE_INTUIT) {
ee0b7718 2098 PL_bostr = orig;
f722798b
IZ
2099 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2100
2101 if (!s)
2102 goto nope;
2103 /* How to do it in subst? */
2104/* if ( (rx->reganch & ROPT_CHECK_ALL)
1c846c1f 2105 && !PL_sawampersand
f722798b
IZ
2106 && ((rx->reganch & ROPT_NOSCAN)
2107 || !((rx->reganch & RE_INTUIT_TAIL)
2108 && (r_flags & REXEC_SCREAM))))
2109 goto yup;
2110*/
a0d0e21e 2111 }
71be2cbc
PP
2112
2113 /* only replace once? */
a0d0e21e 2114 once = !(rpm->op_pmflags & PMf_GLOBAL);
71be2cbc
PP
2115
2116 /* known replacement string? */
f272994b 2117 if (dstr) {
8514a05a
JH
2118 /* replacement needing upgrading? */
2119 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2120 nsv = sv_newmortal();
4a176938 2121 SvSetSV(nsv, dstr);
8514a05a
JH
2122 if (PL_encoding)
2123 sv_recode_to_utf8(nsv, PL_encoding);
2124 else
2125 sv_utf8_upgrade(nsv);
5c144d81 2126 c = SvPV_const(nsv, clen);
4a176938
JH
2127 doutf8 = TRUE;
2128 }
2129 else {
5c144d81 2130 c = SvPV_const(dstr, clen);
4a176938 2131 doutf8 = DO_UTF8(dstr);
8514a05a 2132 }
f272994b
A
2133 }
2134 else {
2135 c = Nullch;
2136 doutf8 = FALSE;
2137 }
2138
71be2cbc 2139 /* can do inplace substitution? */
ed252734 2140 if (c
f8c7b90f 2141#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2142 && !is_cow
2143#endif
2144 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
db79b45b
JH
2145 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2146 && (!doutf8 || SvUTF8(TARG))) {
f722798b
IZ
2147 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2148 r_flags | REXEC_CHECKED))
2149 {
8ec5e241 2150 SPAGAIN;
3280af22 2151 PUSHs(&PL_sv_no);
71be2cbc
PP
2152 LEAVE_SCOPE(oldsave);
2153 RETURN;
2154 }
f8c7b90f 2155#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2156 if (SvIsCOW(TARG)) {
2157 assert (!force_on_match);
2158 goto have_a_cow;
2159 }
2160#endif
71be2cbc
PP
2161 if (force_on_match) {
2162 force_on_match = 0;
2163 s = SvPV_force(TARG, len);
2164 goto force_it;
2165 }
71be2cbc 2166 d = s;
3280af22 2167 PL_curpm = pm;
71be2cbc
PP
2168 SvSCREAM_off(TARG); /* disable possible screamer */
2169 if (once) {
48c036b1 2170 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d
IZ
2171 m = orig + rx->startp[0];
2172 d = orig + rx->endp[0];
71be2cbc
PP
2173 s = orig;
2174 if (m - s > strend - d) { /* faster to shorten from end */
2175 if (clen) {
2176 Copy(c, m, clen, char);
2177 m += clen;
a0d0e21e 2178 }
71be2cbc
PP
2179 i = strend - d;
2180 if (i > 0) {
2181 Move(d, m, i, char);
2182 m += i;
a0d0e21e 2183 }
71be2cbc
PP
2184 *m = '\0';
2185 SvCUR_set(TARG, m - s);
2186 }
155aba94 2187 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
2188 d -= clen;
2189 m = d;
2190 sv_chop(TARG, d-i);
2191 s += i;
2192 while (i--)
2193 *--d = *--s;
2194 if (clen)
2195 Copy(c, m, clen, char);
2196 }
2197 else if (clen) {
2198 d -= clen;
2199 sv_chop(TARG, d);
2200 Copy(c, d, clen, char);
2201 }
2202 else {
2203 sv_chop(TARG, d);
2204 }
48c036b1 2205 TAINT_IF(rxtainted & 1);
8ec5e241 2206 SPAGAIN;
3280af22 2207 PUSHs(&PL_sv_yes);
71be2cbc
PP
2208 }
2209 else {
71be2cbc
PP
2210 do {
2211 if (iters++ > maxiters)
cea2e8a9 2212 DIE(aTHX_ "Substitution loop");
d9f97599 2213 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2214 m = rx->startp[0] + orig;
155aba94 2215 if ((i = m - s)) {
71be2cbc
PP
2216 if (s != d)
2217 Move(s, d, i, char);
2218 d += i;
a0d0e21e 2219 }
71be2cbc
PP
2220 if (clen) {
2221 Copy(c, d, clen, char);
2222 d += clen;
2223 }
cf93c79d 2224 s = rx->endp[0] + orig;
cea2e8a9 2225 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
f722798b
IZ
2226 TARG, NULL,
2227 /* don't match same null twice */
2228 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
2229 if (s != d) {
2230 i = strend - s;
aa07b2f6 2231 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 2232 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2233 }
48c036b1 2234 TAINT_IF(rxtainted & 1);
8ec5e241 2235 SPAGAIN;
71be2cbc 2236 PUSHs(sv_2mortal(newSViv((I32)iters)));
a0d0e21e 2237 }
80b498e0 2238 (void)SvPOK_only_UTF8(TARG);
48c036b1 2239 TAINT_IF(rxtainted);
8ec5e241
NIS
2240 if (SvSMAGICAL(TARG)) {
2241 PUTBACK;
2242 mg_set(TARG);
2243 SPAGAIN;
2244 }
9212bbba 2245 SvTAINT(TARG);
aefe6dfc
JH
2246 if (doutf8)
2247 SvUTF8_on(TARG);
71be2cbc
PP
2248 LEAVE_SCOPE(oldsave);
2249 RETURN;
a0d0e21e 2250 }
71be2cbc 2251
f722798b
IZ
2252 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2253 r_flags | REXEC_CHECKED))
2254 {
a0d0e21e
LW
2255 if (force_on_match) {
2256 force_on_match = 0;
2257 s = SvPV_force(TARG, len);
2258 goto force_it;
2259 }
f8c7b90f 2260#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2261 have_a_cow:
2262#endif
48c036b1 2263 rxtainted |= RX_MATCH_TAINTED(rx);
f2b990bf 2264 dstr = newSVpvn(m, s-m);
ffc61ed2
JH
2265 if (DO_UTF8(TARG))
2266 SvUTF8_on(dstr);
3280af22 2267 PL_curpm = pm;
a0d0e21e 2268 if (!c) {
c09156bb 2269 register PERL_CONTEXT *cx;
8ec5e241 2270 SPAGAIN;
454f1e26 2271 (void)ReREFCNT_inc(rx);
a0d0e21e
LW
2272 PUSHSUBST(cx);
2273 RETURNOP(cPMOP->op_pmreplroot);
2274 }
cf93c79d 2275 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2276 do {
2277 if (iters++ > maxiters)
cea2e8a9 2278 DIE(aTHX_ "Substitution loop");
d9f97599 2279 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2280 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW
2281 m = s;
2282 s = orig;
cf93c79d 2283 orig = rx->subbeg;
a0d0e21e
LW
2284 s = orig + (m - s);
2285 strend = s + (strend - m);
2286 }
cf93c79d 2287 m = rx->startp[0] + orig;
db79b45b
JH
2288 if (doutf8 && !SvUTF8(dstr))
2289 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2290 else
2291 sv_catpvn(dstr, s, m-s);
cf93c79d 2292 s = rx->endp[0] + orig;
a0d0e21e
LW
2293 if (clen)
2294 sv_catpvn(dstr, c, clen);
2295 if (once)
2296 break;
ffc61ed2
JH
2297 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2298 TARG, NULL, r_flags));
db79b45b
JH
2299 if (doutf8 && !DO_UTF8(TARG))
2300 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
89afcb60
A
2301 else
2302 sv_catpvn(dstr, s, strend - s);
748a9306 2303
f8c7b90f 2304#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2305 /* The match may make the string COW. If so, brilliant, because that's
2306 just saved us one malloc, copy and free - the regexp has donated
2307 the old buffer, and we malloc an entirely new one, rather than the
2308 regexp malloc()ing a buffer and copying our original, only for
2309 us to throw it away here during the substitution. */
2310 if (SvIsCOW(TARG)) {
2311 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2312 } else
2313#endif
2314 {
8bd4d4c5 2315 SvPV_free(TARG);
ed252734 2316 }
f880fe2f 2317 SvPV_set(TARG, SvPVX(dstr));
748a9306
LW
2318 SvCUR_set(TARG, SvCUR(dstr));
2319 SvLEN_set(TARG, SvLEN(dstr));
f272994b 2320 doutf8 |= DO_UTF8(dstr);
f880fe2f 2321 SvPV_set(dstr, (char*)0);
748a9306
LW
2322 sv_free(dstr);
2323
48c036b1 2324 TAINT_IF(rxtainted & 1);
f878fbec 2325 SPAGAIN;
48c036b1
GS
2326 PUSHs(sv_2mortal(newSViv((I32)iters)));
2327
a0d0e21e 2328 (void)SvPOK_only(TARG);
f272994b 2329 if (doutf8)
60aeb6fd 2330 SvUTF8_on(TARG);
48c036b1 2331 TAINT_IF(rxtainted);
a0d0e21e 2332 SvSETMAGIC(TARG);
9212bbba 2333 SvTAINT(TARG);
4633a7c4 2334 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2335 RETURN;
2336 }
5cd24f17 2337 goto ret_no;
a0d0e21e
LW
2338
2339nope:
1c846c1f 2340ret_no:
8ec5e241 2341 SPAGAIN;
3280af22 2342 PUSHs(&PL_sv_no);
4633a7c4 2343 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2344 RETURN;
2345}
2346
2347PP(pp_grepwhile)
2348{
27da23d5 2349 dVAR; dSP;
a0d0e21e
LW
2350
2351 if (SvTRUEx(POPs))
3280af22
NIS
2352 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2353 ++*PL_markstack_ptr;
a0d0e21e
LW
2354 LEAVE; /* exit inner scope */
2355
2356 /* All done yet? */
3280af22 2357 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2358 I32 items;
c4420975 2359 const I32 gimme = GIMME_V;
a0d0e21e
LW
2360
2361 LEAVE; /* exit outer scope */
2362 (void)POPMARK; /* pop src */
3280af22 2363 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2364 (void)POPMARK; /* pop dst */
3280af22 2365 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2366 if (gimme == G_SCALAR) {
7cc47870 2367 if (PL_op->op_private & OPpGREP_LEX) {
c4420975 2368 SV* const sv = sv_newmortal();
7cc47870
RGS
2369 sv_setiv(sv, items);
2370 PUSHs(sv);
2371 }
2372 else {
2373 dTARGET;
2374 XPUSHi(items);
2375 }
a0d0e21e 2376 }
54310121
PP
2377 else if (gimme == G_ARRAY)
2378 SP += items;
a0d0e21e
LW
2379 RETURN;
2380 }
2381 else {
2382 SV *src;
2383
2384 ENTER; /* enter inner scope */
1d7c1841 2385 SAVEVPTR(PL_curpm);
a0d0e21e 2386
3280af22 2387 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2388 SvTEMP_off(src);
59f00321
RGS
2389 if (PL_op->op_private & OPpGREP_LEX)
2390 PAD_SVl(PL_op->op_targ) = src;
2391 else
2392 DEFSV = src;
a0d0e21e
LW
2393
2394 RETURNOP(cLOGOP->op_other);
2395 }
2396}
2397
2398PP(pp_leavesub)
2399{
27da23d5 2400 dVAR; dSP;
a0d0e21e
LW
2401 SV **mark;
2402 SV **newsp;
2403 PMOP *newpm;
2404 I32 gimme;
c09156bb 2405 register PERL_CONTEXT *cx;
b0d9ce38 2406 SV *sv;
a0d0e21e 2407
9850bf21
RH
2408 if (CxMULTICALL(&cxstack[cxstack_ix]))
2409 return 0;
2410
a0d0e21e 2411 POPBLOCK(cx,newpm);
5dd42e15 2412 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2413
a1f49e72 2414 TAINT_NOT;
a0d0e21e
LW
2415 if (gimme == G_SCALAR) {
2416 MARK = newsp + 1;
a29cdaf0 2417 if (MARK <= SP) {
a8bba7fa 2418 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2419 if (SvTEMP(TOPs)) {
2420 *MARK = SvREFCNT_inc(TOPs);
2421 FREETMPS;
2422 sv_2mortal(*MARK);
cd06dffe
GS
2423 }
2424 else {
959e3673 2425 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2426 FREETMPS;
959e3673
GS
2427 *MARK = sv_mortalcopy(sv);
2428 SvREFCNT_dec(sv);
a29cdaf0 2429 }
cd06dffe
GS
2430 }
2431 else
a29cdaf0 2432 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
cd06dffe
GS
2433 }
2434 else {
f86702cc 2435 MEXTEND(MARK, 0);
3280af22 2436 *MARK = &PL_sv_undef;
a0d0e21e
LW
2437 }
2438 SP = MARK;
2439 }
54310121 2440 else if (gimme == G_ARRAY) {
f86702cc 2441 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2442 if (!SvTEMP(*MARK)) {
f86702cc 2443 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2444 TAINT_NOT; /* Each item is independent */
2445 }
f86702cc 2446 }
a0d0e21e 2447 }
f86702cc 2448 PUTBACK;
1c846c1f 2449
5dd42e15
DM
2450 LEAVE;
2451 cxstack_ix--;
b0d9ce38 2452 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2453 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2454
b0d9ce38 2455 LEAVESUB(sv);
f39bc417 2456 return cx->blk_sub.retop;
a0d0e21e
LW
2457}
2458
cd06dffe
GS
2459/* This duplicates the above code because the above code must not
2460 * get any slower by more conditions */
2461PP(pp_leavesublv)
2462{
27da23d5 2463 dVAR; dSP;
cd06dffe
GS
2464 SV **mark;
2465 SV **newsp;
2466 PMOP *newpm;
2467 I32 gimme;
2468 register PERL_CONTEXT *cx;
b0d9ce38 2469 SV *sv;
cd06dffe 2470
9850bf21
RH
2471 if (CxMULTICALL(&cxstack[cxstack_ix]))
2472 return 0;
2473
cd06dffe 2474 POPBLOCK(cx,newpm);
5dd42e15 2475 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2476
cd06dffe
GS
2477 TAINT_NOT;
2478
2479 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2480 /* We are an argument to a function or grep().
2481 * This kind of lvalueness was legal before lvalue
2482 * subroutines too, so be backward compatible:
2483 * cannot report errors. */
2484
2485 /* Scalar context *is* possible, on the LHS of -> only,
2486 * as in f()->meth(). But this is not an lvalue. */
2487 if (gimme == G_SCALAR)
2488 goto temporise;
2489 if (gimme == G_ARRAY) {
a8bba7fa 2490 if (!CvLVALUE(cx->blk_sub.cv))
cd06dffe
GS
2491 goto temporise_array;
2492 EXTEND_MORTAL(SP - newsp);
2493 for (mark = newsp + 1; mark <= SP; mark++) {
2494 if (SvTEMP(*mark))
2495 /* empty */ ;
2496 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2497 *mark = sv_mortalcopy(*mark);
2498 else {
2499 /* Can be a localized value subject to deletion. */
2500 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2501 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2502 }
2503 }
2504 }
2505 }
2506 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2507 /* Here we go for robustness, not for speed, so we change all
2508 * the refcounts so the caller gets a live guy. Cannot set
2509 * TEMP, so sv_2mortal is out of question. */
a8bba7fa 2510 if (!CvLVALUE(cx->blk_sub.cv)) {
5dd42e15
DM
2511 LEAVE;
2512 cxstack_ix--;
b0d9ce38 2513 POPSUB(cx,sv);
d470f89e 2514 PL_curpm = newpm;
b0d9ce38 2515 LEAVESUB(sv);
d470f89e
GS
2516 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2517 }
cd06dffe
GS
2518 if (gimme == G_SCALAR) {
2519 MARK = newsp + 1;
2520 EXTEND_MORTAL(1);
2521 if (MARK == SP) {
f9bc45ef
TP
2522 /* Temporaries are bad unless they happen to be elements
2523 * of a tied hash or array */
2524 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2525 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
5dd42e15
DM
2526 LEAVE;
2527 cxstack_ix--;
b0d9ce38 2528 POPSUB(cx,sv);
d470f89e 2529 PL_curpm = newpm;
b0d9ce38 2530 LEAVESUB(sv);
e9f19e3c
HS
2531 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2532 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2533 : "a readonly value" : "a temporary");
d470f89e 2534 }
cd06dffe
GS
2535 else { /* Can be a localized value
2536 * subject to deletion. */
2537 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2538 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2539 }
2540 }
d470f89e 2541 else { /* Should not happen? */
5dd42e15
DM
2542 LEAVE;
2543 cxstack_ix--;
b0d9ce38 2544 POPSUB(cx,sv);
d470f89e 2545 PL_curpm = newpm;
b0d9ce38 2546 LEAVESUB(sv);
d470f89e 2547 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
cd06dffe 2548 (MARK > SP ? "Empty array" : "Array"));
d470f89e 2549 }
cd06dffe
GS
2550 SP = MARK;
2551 }
2552 else if (gimme == G_ARRAY) {
2553 EXTEND_MORTAL(SP - newsp);
2554 for (mark = newsp + 1; mark <= SP; mark++) {
f206cdda
AMS
2555 if (*mark != &PL_sv_undef
2556 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
d470f89e
GS
2557 /* Might be flattened array after $#array = */
2558 PUTBACK;
5dd42e15
DM
2559 LEAVE;
2560 cxstack_ix--;
b0d9ce38 2561 POPSUB(cx,sv);
d470f89e 2562 PL_curpm = newpm;
b0d9ce38 2563 LEAVESUB(sv);
f206cdda
AMS
2564 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2565 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2566 }
cd06dffe 2567 else {
cd06dffe
GS
2568 /* Can be a localized value subject to deletion. */
2569 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2570 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2571 }
2572 }
2573 }
2574 }
2575 else {
2576 if (gimme == G_SCALAR) {
2577 temporise:
2578 MARK = newsp + 1;
2579 if (MARK <= SP) {
a8bba7fa 2580 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
cd06dffe
GS
2581 if (SvTEMP(TOPs)) {
2582 *MARK = SvREFCNT_inc(TOPs);
2583 FREETMPS;
2584 sv_2mortal(*MARK);
2585 }
2586 else {
959e3673 2587 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
cd06dffe 2588 FREETMPS;
959e3673
GS
2589 *MARK = sv_mortalcopy(sv);
2590 SvREFCNT_dec(sv);
cd06dffe
GS
2591 }
2592 }
2593 else
2594 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2595 }
2596 else {
2597 MEXTEND(MARK, 0);
2598 *MARK = &PL_sv_undef;
2599 }
2600 SP = MARK;
2601 }
2602 else if (gimme == G_ARRAY) {
2603 temporise_array:
2604 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2605 if (!SvTEMP(*MARK)) {
2606 *MARK = sv_mortalcopy(*MARK);
2607 TAINT_NOT; /* Each item is independent */
2608 }
2609 }
2610 }
2611 }
2612 PUTBACK;
1c846c1f 2613
5dd42e15
DM
2614 LEAVE;
2615 cxstack_ix--;
b0d9ce38 2616 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cd06dffe
GS
2617 PL_curpm = newpm; /* ... and pop $1 et al */
2618
b0d9ce38 2619 LEAVESUB(sv);
f39bc417 2620 return cx->blk_sub.retop;
cd06dffe
GS
2621}
2622
2623
76e3520e 2624STATIC CV *
cea2e8a9 2625S_get_db_sub(pTHX_ SV **svp, CV *cv)
3de9ffa1 2626{
0bcc34c2 2627 SV * const dbsv = GvSVn(PL_DBsub);
491527d0 2628
f398eb67 2629 save_item(dbsv);
491527d0
GS
2630 if (!PERLDB_SUB_NN) {
2631 GV *gv = CvGV(cv);
2632
491527d0 2633 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
1c846c1f 2634 || strEQ(GvNAME(gv), "END")
491527d0
GS
2635 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2636 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2637 && (gv = (GV*)*svp) ))) {
2638 /* Use GV from the stack as a fallback. */
2639 /* GV is potentially non-unique, or contain different CV. */
823a54a3 2640 SV * const tmp = newRV((SV*)cv);
c2e66d9e
GS
2641 sv_setsv(dbsv, tmp);
2642 SvREFCNT_dec(tmp);
491527d0
GS
2643 }
2644 else {
2645 gv_efullname3(dbsv, gv, Nullch);
2646 }
3de9ffa1
MB
2647 }
2648 else {
a9c4fd4e 2649 const int type = SvTYPE(dbsv);
f398eb67
NC
2650 if (type < SVt_PVIV && type != SVt_IV)
2651 sv_upgrade(dbsv, SVt_PVIV);
155aba94 2652 (void)SvIOK_on(dbsv);
45977657 2653 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
3de9ffa1 2654 }
491527d0 2655
3de9ffa1 2656 if (CvXSUB(cv))
3280af22
NIS
2657 PL_curcopdb = PL_curcop;
2658 cv = GvCV(PL_DBsub);
3de9ffa1
MB
2659 return cv;
2660}
2661
a0d0e21e
LW
2662PP(pp_entersub)
2663{
27da23d5 2664 dVAR; dSP; dPOPss;
a0d0e21e 2665 GV *gv;
a0d0e21e 2666 register CV *cv;
c09156bb 2667 register PERL_CONTEXT *cx;
5d94fbed 2668 I32 gimme;
a9c4fd4e 2669 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2670
2671 if (!sv)
cea2e8a9 2672 DIE(aTHX_ "Not a CODE reference");
a0d0e21e 2673 switch (SvTYPE(sv)) {
f1025168
NC
2674 /* This is overwhelming the most common case: */
2675 case SVt_PVGV:
f730a42d
NC
2676 if (!(cv = GvCVu((GV*)sv))) {
2677 HV *stash;
f2c0649b 2678 cv = sv_2cv(sv, &stash, &gv, 0);
f730a42d 2679 }
f1025168
NC
2680 if (!cv) {
2681 ENTER;
2682 SAVETMPS;
2683 goto try_autoload;
2684 }
2685 break;
a0d0e21e
LW
2686 default:
2687 if (!SvROK(sv)) {
a9c4fd4e 2688 const char *sym;
3280af22 2689 if (sv == &PL_sv_yes) { /* unfound import, ignore */
fb73857a 2690 if (hasargs)
3280af22 2691 SP = PL_stack_base + POPMARK;
a0d0e21e 2692 RETURN;
fb73857a 2693 }
15ff848f
CS
2694 if (SvGMAGICAL(sv)) {
2695 mg_get(sv);
f5f1d18e
AMS
2696 if (SvROK(sv))
2697 goto got_rv;
aa07b2f6 2698 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
15ff848f 2699 }
a9c4fd4e 2700 else {
8b6b16e7 2701 sym = SvPV_nolen_const(sv);
a9c4fd4e 2702 }
15ff848f 2703 if (!sym)
cea2e8a9 2704 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2705 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 2706 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
864dbfa3 2707 cv = get_cv(sym, TRUE);
a0d0e21e
LW
2708 break;
2709 }
f5f1d18e 2710 got_rv:
f5284f61 2711 {
823a54a3 2712 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
f5284f61
IZ
2713 tryAMAGICunDEREF(to_cv);
2714 }
a0d0e21e
LW
2715 cv = (CV*)SvRV(sv);
2716 if (SvTYPE(cv) == SVt_PVCV)
2717 break;
2718 /* FALL THROUGH */
2719 case SVt_PVHV:
2720 case SVt_PVAV:
cea2e8a9 2721 DIE(aTHX_ "Not a CODE reference");
f1025168 2722 /* This is the second most common case: */
a0d0e21e
LW
2723 case SVt_PVCV:
2724 cv = (CV*)sv;
2725 break;
a0d0e21e
LW
2726 }
2727
2728 ENTER;
2729 SAVETMPS;
2730
2731 retry:
a0d0e21e 2732 if (!CvROOT(cv) && !CvXSUB(cv)) {
2f349aa0
NC
2733 GV* autogv;
2734 SV* sub_name;
2735
2736 /* anonymous or undef'd function leaves us no recourse */
2737 if (CvANON(cv) || !(gv = CvGV(cv)))
2738 DIE(aTHX_ "Undefined subroutine called");
2739
2740 /* autoloaded stub? */
2741 if (cv != GvCV(gv)) {
2742 cv = GvCV(gv);
2743 }
2744 /* should call AUTOLOAD now? */
2745 else {
2746try_autoload:
2747 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2748 FALSE)))
2749 {
2750 cv = GvCV(autogv);
2751 }
2752 /* sorry */
2753 else {
2754 sub_name = sv_newmortal();
2755 gv_efullname3(sub_name, gv, Nullch);
2756 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2757 }
2758 }
2759 if (!cv)
2760 DIE(aTHX_ "Not a CODE reference");
2761 goto retry;
a0d0e21e
LW
2762 }
2763
54310121 2764 gimme = GIMME_V;
67caa1fe 2765 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
06492da6
SF
2766 if (CvASSERTION(cv) && PL_DBassertion)
2767 sv_setiv(PL_DBassertion, 1);
2768
4f01c5a5 2769 cv = get_db_sub(&sv, cv);
ccafdc96
RGS
2770 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2771 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2772 }
a0d0e21e 2773
f1025168
NC
2774 if (!(CvXSUB(cv))) {
2775 /* This path taken at least 75% of the time */
a0d0e21e
LW
2776 dMARK;
2777 register I32 items = SP - MARK;
0bcc34c2 2778 AV* const padlist = CvPADLIST(cv);
a0d0e21e
LW
2779 PUSHBLOCK(cx, CXt_SUB, MARK);
2780 PUSHSUB(cx);
f39bc417 2781 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 2782 CvDEPTH(cv)++;
6b35e009
GS
2783 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2784 * that eval'' ops within this sub know the correct lexical space.
a3985cdc
DM
2785 * Owing the speed considerations, we choose instead to search for
2786 * the cv using find_runcv() when calling doeval().
6b35e009 2787 */
b36bdeca 2788 if (CvDEPTH(cv) >= 2) {
1d7c1841 2789 PERL_STACK_OVERFLOW_CHECK();
26019298 2790 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2791 }
9320a037
DM
2792 SAVECOMPPAD();
2793 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
6d4ff0d2 2794 if (hasargs)
6d4ff0d2 2795 {
0bcc34c2 2796 AV* const av = (AV*)PAD_SVl(0);
221373f0
GS
2797 if (AvREAL(av)) {
2798 /* @_ is normally not REAL--this should only ever
2799 * happen when DB::sub() calls things that modify @_ */
2800 av_clear(av);
2801 AvREAL_off(av);
2802 AvREIFY_on(av);
2803 }
3280af22
NIS
2804 cx->blk_sub.savearray = GvAV(PL_defgv);
2805 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2806 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2807 cx->blk_sub.argarray = av;
a0d0e21e
LW
2808 ++MARK;
2809
2810 if (items > AvMAX(av) + 1) {
504618e9 2811 SV **ary = AvALLOC(av);
a0d0e21e
LW
2812 if (AvARRAY(av) != ary) {
2813 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
f880fe2f 2814 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2815 }
2816 if (items > AvMAX(av) + 1) {
2817 AvMAX(av) = items - 1;
2818 Renew(ary,items,SV*);
2819 AvALLOC(av) = ary;
f880fe2f 2820 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2821 }
2822 }
2823 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2824 AvFILLp(av) = items - 1;
1c846c1f 2825
a0d0e21e
LW
2826 while (items--) {
2827 if (*MARK)
2828 SvTEMP_off(*MARK);
2829 MARK++;
2830 }
2831 }
4a925ff6
GS
2832 /* warning must come *after* we fully set up the context
2833 * stuff so that __WARN__ handlers can safely dounwind()
2834 * if they want to
2835 */
2836 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2837 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2838 sub_crush_depth(cv);
77a005ab 2839#if 0
bf49b057 2840 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2841 "%p entersub returning %p\n", thr, CvSTART(cv)));
77a005ab 2842#endif
a0d0e21e
LW
2843 RETURNOP(CvSTART(cv));
2844 }
f1025168
NC
2845 else {
2846#ifdef PERL_XSUB_OLDSTYLE
2847 if (CvOLDSTYLE(cv)) {
2848 I32 (*fp3)(int,int,int);
2849 dMARK;
2850 register I32 items = SP - MARK;
2851 /* We dont worry to copy from @_. */
2852 while (SP > mark) {
2853 SP[1] = SP[0];
2854 SP--;
2855 }
2856 PL_stack_sp = mark + 1;
2857 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2858 items = (*fp3)(CvXSUBANY(cv).any_i32,
2859 MARK - PL_stack_base + 1,
2860 items);
2861 PL_stack_sp = PL_stack_base + items;
2862 }
2863 else
2864#endif /* PERL_XSUB_OLDSTYLE */
2865 {
2866 I32 markix = TOPMARK;
2867
2868 PUTBACK;
2869
2870 if (!hasargs) {
2871 /* Need to copy @_ to stack. Alternative may be to
2872 * switch stack to @_, and copy return values
2873 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
a3b680e6
AL
2874 AV * const av = GvAV(PL_defgv);
2875 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
f1025168
NC
2876
2877 if (items) {
2878 /* Mark is at the end of the stack. */
2879 EXTEND(SP, items);
2880 Copy(AvARRAY(av), SP + 1, items, SV*);
2881 SP += items;
2882 PUTBACK ;
2883 }
2884 }
2885 /* We assume first XSUB in &DB::sub is the called one. */
2886 if (PL_curcopdb) {
2887 SAVEVPTR(PL_curcop);
2888 PL_curcop = PL_curcopdb;
2889 PL_curcopdb = NULL;
2890 }
2891 /* Do we need to open block here? XXXX */
2892 (void)(*CvXSUB(cv))(aTHX_ cv);
2893
2894 /* Enforce some sanity in scalar context. */
2895 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2896 if (markix > PL_stack_sp - PL_stack_base)
2897 *(PL_stack_base + markix) = &PL_sv_undef;
2898 else
2899 *(PL_stack_base + markix) = *PL_stack_sp;
2900 PL_stack_sp = PL_stack_base + markix;
2901 }
2902 }
2903 LEAVE;
2904 return NORMAL;
2905 }
a0d0e21e
LW
2906}
2907
44a8e56a 2908void
864dbfa3 2909Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a
PP
2910{
2911 if (CvANON(cv))
9014280d 2912 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 2913 else {
aec46f14 2914 SV* const tmpstr = sv_newmortal();
44a8e56a 2915 gv_efullname3(tmpstr, CvGV(cv), Nullch);
35c1215d
NC
2916 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2917 tmpstr);
44a8e56a
PP
2918 }
2919}
2920
a0d0e21e
LW
2921PP(pp_aelem)
2922{
39644a26 2923 dSP;
a0d0e21e 2924 SV** svp;
a3b680e6 2925 SV* const elemsv = POPs;
d804643f 2926 IV elem = SvIV(elemsv);
0bcc34c2 2927 AV* const av = (AV*)POPs;
e1ec3a88
AL
2928 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2929 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
be6c24e0 2930 SV *sv;
a0d0e21e 2931
e35c1634 2932 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
35c1215d 2933 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
748a9306 2934 if (elem > 0)
3280af22 2935 elem -= PL_curcop->cop_arybase;
a0d0e21e
LW
2936 if (SvTYPE(av) != SVt_PVAV)
2937 RETPUSHUNDEF;
68dc0745 2938 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2939 if (lval) {
2b573ace 2940#ifdef PERL_MALLOC_WRAP
2b573ace 2941 if (SvUOK(elemsv)) {
a9c4fd4e 2942 const UV uv = SvUV(elemsv);
2b573ace
JH
2943 elem = uv > IV_MAX ? IV_MAX : uv;
2944 }
2945 else if (SvNOK(elemsv))
2946 elem = (IV)SvNV(elemsv);
a3b680e6
AL
2947 if (elem > 0) {
2948 static const char oom_array_extend[] =
2949 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 2950 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 2951 }
2b573ace 2952#endif
3280af22 2953 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2954 SV* lv;
2955 if (!defer)
cea2e8a9 2956 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2957 lv = sv_newmortal();
2958 sv_upgrade(lv, SVt_PVLV);
2959 LvTYPE(lv) = 'y';
14befaf4 2960 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
68dc0745
PP
2961 LvTARG(lv) = SvREFCNT_inc(av);
2962 LvTARGOFF(lv) = elem;
2963 LvTARGLEN(lv) = 1;
2964 PUSHs(lv);
2965 RETURN;
2966 }
bfc4de9f 2967 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2968 save_aelem(av, elem, svp);
533c011a
NIS
2969 else if (PL_op->op_private & OPpDEREF)
2970 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 2971 }
3280af22 2972 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
2973 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2974 sv = sv_mortalcopy(sv);
2975 PUSHs(sv);
a0d0e21e
LW
2976 RETURN;
2977}
2978
02a9e968 2979void
864dbfa3 2980Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 2981{
5b295bef 2982 SvGETMAGIC(sv);
02a9e968
CS
2983 if (!SvOK(sv)) {
2984 if (SvREADONLY(sv))
cea2e8a9 2985 Perl_croak(aTHX_ PL_no_modify);
5f05dabc
PP
2986 if (SvTYPE(sv) < SVt_RV)
2987 sv_upgrade(sv, SVt_RV);
2988 else if (SvTYPE(sv) >= SVt_PV) {
8bd4d4c5 2989 SvPV_free(sv);
b162af07
SP
2990 SvLEN_set(sv, 0);
2991 SvCUR_set(sv, 0);
5f05dabc 2992 }
68dc0745 2993 switch (to_what) {
5f05dabc 2994 case OPpDEREF_SV:
b162af07 2995 SvRV_set(sv, NEWSV(355,0));
5f05dabc
PP
2996 break;
2997 case OPpDEREF_AV:
b162af07 2998 SvRV_set(sv, (SV*)newAV());
5f05dabc
PP
2999 break;
3000 case OPpDEREF_HV:
b162af07 3001 SvRV_set(sv, (SV*)newHV());
5f05dabc
PP
3002 break;
3003 }
02a9e968
CS
3004 SvROK_on(sv);
3005 SvSETMAGIC(sv);
3006 }
3007}
3008
a0d0e21e
LW
3009PP(pp_method)
3010{
39644a26 3011 dSP;
890ce7af 3012 SV* const sv = TOPs;
f5d5a27c
CS
3013
3014 if (SvROK(sv)) {
890ce7af 3015 SV* const rsv = SvRV(sv);
f5d5a27c
CS
3016 if (SvTYPE(rsv) == SVt_PVCV) {
3017 SETs(rsv);
3018 RETURN;
3019 }
3020 }
3021
3022 SETs(method_common(sv, Null(U32*)));
3023 RETURN;
3024}
3025
3026PP(pp_method_named)
3027{
39644a26 3028 dSP;
890ce7af 3029 SV* const sv = cSVOP_sv;
c158a4fd 3030 U32 hash = SvSHARED_HASH(sv);
f5d5a27c
CS
3031
3032 XPUSHs(method_common(sv, &hash));
3033 RETURN;
3034}
3035
3036STATIC SV *
3037S_method_common(pTHX_ SV* meth, U32* hashp)
3038{
a0d0e21e
LW
3039 SV* ob;
3040 GV* gv;
56304f61 3041 HV* stash;
f5d5a27c 3042 STRLEN namelen;
46c461b5 3043 const char* packname = Nullch;
0dae17bd 3044 SV *packsv = Nullsv;
ac91690f 3045 STRLEN packlen;
46c461b5
AL
3046 const char * const name = SvPV_const(meth, namelen);
3047 SV * const sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 3048
4f1b7578
SC
3049 if (!sv)
3050 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3051
5b295bef 3052 SvGETMAGIC(sv);
a0d0e21e 3053 if (SvROK(sv))
16d20bd9 3054 ob = (SV*)SvRV(sv);
a0d0e21e
LW
3055 else {
3056 GV* iogv;
a0d0e21e 3057
af09ea45 3058 /* this isn't a reference */
5c144d81 3059 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
b464bac0 3060 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
081fc587 3061 if (he) {
5e6396ae 3062 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
081fc587
AB
3063 goto fetch;
3064 }
3065 }
3066
a0d0e21e 3067 if (!SvOK(sv) ||
05f5af9a 3068 !(packname) ||
f776e3cd 3069 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
a0d0e21e
LW
3070 !(ob=(SV*)GvIO(iogv)))
3071 {
af09ea45 3072 /* this isn't the name of a filehandle either */
1c846c1f 3073 if (!packname ||
fd400ab9 3074 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 3075 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd
LW
3076 : !isIDFIRST(*packname)
3077 ))
3078 {
f5d5a27c
CS
3079 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3080 SvOK(sv) ? "without a package or object reference"
3081 : "on an undefined value");
834a4ddd 3082 }
af09ea45
IK
3083 /* assume it's a package name */
3084 stash = gv_stashpvn(packname, packlen, FALSE);
0dae17bd
GS
3085 if (!stash)
3086 packsv = sv;
081fc587 3087 else {
5e6396ae 3088 SV* ref = newSViv(PTR2IV(stash));
7e8961ec
AB
3089 hv_store(PL_stashcache, packname, packlen, ref, 0);
3090 }
ac91690f 3091 goto fetch;
a0d0e21e 3092 }
af09ea45 3093 /* it _is_ a filehandle name -- replace with a reference */
3280af22 3094 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
a0d0e21e
LW
3095 }
3096
af09ea45 3097 /* if we got here, ob should be a reference or a glob */
f0d43078
GS
3098 if (!ob || !(SvOBJECT(ob)
3099 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3100 && SvOBJECT(ob))))
3101 {
f5d5a27c
CS
3102 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3103 name);
f0d43078 3104 }
a0d0e21e 3105
56304f61 3106 stash = SvSTASH(ob);
a0d0e21e 3107
ac91690f 3108 fetch:
af09ea45
IK
3109 /* NOTE: stash may be null, hope hv_fetch_ent and
3110 gv_fetchmethod can cope (it seems they can) */
3111
f5d5a27c
CS
3112 /* shortcut for simple names */
3113 if (hashp) {
b464bac0 3114 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
f5d5a27c
CS
3115 if (he) {
3116 gv = (GV*)HeVAL(he);
3117 if (isGV(gv) && GvCV(gv) &&
3118 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3119 return (SV*)GvCV(gv);
3120 }
3121 }
3122
0dae17bd 3123 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
af09ea45 3124
56304f61 3125 if (!gv) {
af09ea45
IK
3126 /* This code tries to figure out just what went wrong with
3127 gv_fetchmethod. It therefore needs to duplicate a lot of
3128 the internals of that function. We can't move it inside
3129 Perl_gv_fetchmethod_autoload(), however, since that would
3130 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3131 don't want that.
3132 */
a9c4fd4e
AL
3133 const char* leaf = name;
3134 const char* sep = Nullch;
3135 const char* p;
56304f61
CS
3136
3137 for (p = name; *p; p++) {
3138 if (*p == '\'')
3139 sep = p, leaf = p + 1;
3140 else if (*p == ':' && *(p + 1) == ':')
3141 sep = p, leaf = p + 2;
3142 }
3143 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
9b9d0b15
NC
3144 /* the method name is unqualified or starts with SUPER:: */
3145 bool need_strlen = 1;
3146 if (sep) {
3147 packname = CopSTASHPV(PL_curcop);
3148 }
3149 else if (stash) {
46c461b5 3150 HEK * const packhek = HvNAME_HEK(stash);
9b9d0b15
NC
3151 if (packhek) {
3152 packname = HEK_KEY(packhek);
3153 packlen = HEK_LEN(packhek);
3154 need_strlen = 0;
3155 } else {
3156 goto croak;
3157 }
3158 }
3159
3160 if (!packname) {
3161 croak:
e27ad1f2
AV
3162 Perl_croak(aTHX_
3163 "Can't use anonymous symbol table for method lookup");
9b9d0b15
NC
3164 }
3165 else if (need_strlen)
e27ad1f2 3166 packlen = strlen(packname);
9b9d0b15 3167
56304f61
CS
3168 }
3169 else {
af09ea45 3170 /* the method name is qualified */
56304f61
CS
3171 packname = name;
3172 packlen = sep - name;
3173 }
af09ea45
IK
3174
3175 /* we're relying on gv_fetchmethod not autovivifying the stash */
3176 if (gv_stashpvn(packname, packlen, FALSE)) {
c1899e02 3177 Perl_croak(aTHX_
af09ea45
IK
3178 "Can't locate object method \"%s\" via package \"%.*s\"",
3179 leaf, (int)packlen, packname);
c1899e02
GS
3180 }
3181 else {
3182 Perl_croak(aTHX_
af09ea45
IK
3183 "Can't locate object method \"%s\" via package \"%.*s\""
3184 " (perhaps you forgot to load \"%.*s\"?)",
3185 leaf, (int)packlen, packname, (int)packlen, packname);
c1899e02 3186 }
56304f61 3187 }
f5d5a27c 3188 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
a0d0e21e 3189}
241d1a3b
NC
3190
3191/*
3192 * Local variables:
3193 * c-indentation-style: bsd
3194 * c-basic-offset: 4
3195 * indent-tabs-mode: t
3196 * End:
3197 *
37442d52
RGS
3198 * ex: set ts=8 sts=4 sw=4 noet:
3199 */