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