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