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
Introduce macro PERL_MAX_SUB_DEPTH
[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. */
6e449a3a 46 mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
0282be92
RGS		 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);
59cd0e26 251 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
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 289 if (!rcopied)
59cd0e26 290 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
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;
3a28f3fb
MS		 734 if( PL_op->op_type == OP_SAY ) {
735 /* local $\ = "\n" */
084e50c2 736 SAVEGENERICSV(PL_ors_sv);
3a28f3fb
MS		 737 PL_ors_sv = newSVpvs("\n");
738 }
864dbfa3 739 call_method("PRINT", G_SCALAR);
236988e4 740 LEAVE;
741 SPAGAIN;
68dc0745 742 MARK = ORIGMARK + 1;
743 *MARK = *SP;
744 SP = MARK;
236988e4 745 RETURN;
746 }
a0d0e21e 747 if (!(io = GvIO(gv))) {
5b468f54
AMS		 748 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
749 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 750 goto had_magic;
2dd78f96
JH		 751 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
752 report_evil_fh(gv, io, PL_op->op_type);
93189314 753 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW		 754 goto just_say_no;
755 }
756 else if (!(fp = IoOFP(io))) {
599cee73 757 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
4c80c0b2
NC		 758 if (IoIFP(io))
759 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
2dd78f96 760 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
bc37a18f 761 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 762 }
93189314 763 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW		 764 goto just_say_no;
765 }
766 else {
767 MARK++;
7889fe52 768 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
a0d0e21e
LW		 769 while (MARK <= SP) {
770 if (!do_print(*MARK, fp))
771 break;
772 MARK++;
773 if (MARK <= SP) {
7889fe52 774 if (!do_print(PL_ofs_sv, fp)) { /* $, */
a0d0e21e
LW		 775 MARK--;
776 break;
777 }
778 }
779 }
780 }
781 else {
782 while (MARK <= SP) {
783 if (!do_print(*MARK, fp))
784 break;
785 MARK++;
786 }
787 }
788 if (MARK <= SP)
789 goto just_say_no;
790 else {
cfc4a7da
GA		 791 if (PL_op->op_type == OP_SAY) {
792 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
793 goto just_say_no;
794 }
795 else if (PL_ors_sv && SvOK(PL_ors_sv))
7889fe52 796 if (!do_print(PL_ors_sv, fp)) /* $\ */
a0d0e21e
LW		 797 goto just_say_no;
798
799 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 800 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 801 goto just_say_no;
802 }
803 }
804 SP = ORIGMARK;
e52fd6f4 805 XPUSHs(&PL_sv_yes);
a0d0e21e
LW		 806 RETURN;
807
808 just_say_no:
809 SP = ORIGMARK;
e52fd6f4 810 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 811 RETURN;
812}
813
814PP(pp_rv2av)
815{
97aff369 816 dVAR; dSP; dTOPss;
cde874ca 817 const I32 gimme = GIMME_V;
17ab7946
NC		 818 static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
819 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
820 static const char an_array[] = "an ARRAY";
821 static const char a_hash[] = "a HASH";
822 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
d83b45b8 823 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e
LW		 824
825 if (SvROK(sv)) {
826 wasref:
17ab7946 827 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
f5284f61 828
17ab7946
NC		 829 sv = SvRV(sv);
830 if (SvTYPE(sv) != type)
831 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
533c011a 832 if (PL_op->op_flags & OPf_REF) {
17ab7946 833 SETs(sv);
a0d0e21e
LW		 834 RETURN;
835 }
78f9721b 836 else if (LVRET) {
cde874ca 837 if (gimme != G_ARRAY)
17ab7946
NC		 838 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
839 : return_hash_to_lvalue_scalar);
840 SETs(sv);
78f9721b
SM		 841 RETURN;
842 }
82d03984
RGS		 843 else if (PL_op->op_flags & OPf_MOD
844 && PL_op->op_private & OPpLVAL_INTRO)
845 Perl_croak(aTHX_ PL_no_localize_ref);
a0d0e21e
LW		 846 }
847 else {
17ab7946 848 if (SvTYPE(sv) == type) {
533c011a 849 if (PL_op->op_flags & OPf_REF) {
17ab7946 850 SETs(sv);
a0d0e21e
LW		 851 RETURN;
852 }
78f9721b 853 else if (LVRET) {
cde874ca 854 if (gimme != G_ARRAY)
17ab7946
NC		 855 Perl_croak(aTHX_
856 is_pp_rv2av ? return_array_to_lvalue_scalar
857 : return_hash_to_lvalue_scalar);
858 SETs(sv);
78f9721b
SM		 859 RETURN;
860 }
a0d0e21e
LW		 861 }
862 else {
67955e0c 863 GV *gv;
1c846c1f 864
a0d0e21e
LW		 865 if (SvTYPE(sv) != SVt_PVGV) {
866 if (SvGMAGICAL(sv)) {
867 mg_get(sv);
868 if (SvROK(sv))
869 goto wasref;
870 }
dc3c76f8
NC		 871 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
872 type, &sp);
873 if (!gv)
874 RETURN;
35cd451c
GS		 875 }
876 else {
67955e0c 877 gv = (GV*)sv;
a0d0e21e 878 }
17ab7946 879 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
533c011a 880 if (PL_op->op_private & OPpLVAL_INTRO)
17ab7946 881 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
533c011a 882 if (PL_op->op_flags & OPf_REF) {
17ab7946 883 SETs(sv);
a0d0e21e
LW		 884 RETURN;
885 }
78f9721b 886 else if (LVRET) {
cde874ca 887 if (gimme != G_ARRAY)
17ab7946
NC		 888 Perl_croak(aTHX_
889 is_pp_rv2av ? return_array_to_lvalue_scalar
890 : return_hash_to_lvalue_scalar);
891 SETs(sv);
78f9721b
SM		 892 RETURN;
893 }
a0d0e21e
LW		 894 }
895 }
896
17ab7946
NC		 897 if (is_pp_rv2av) {
898 AV *const av = (AV*)sv;
899 /* The guts of pp_rv2av, with no intenting change to preserve history
900 (until such time as we get tools that can do blame annotation across
901 whitespace changes. */
cde874ca 902 if (gimme == G_ARRAY) {
a3b680e6 903 const I32 maxarg = AvFILL(av) + 1;
c2444246 904 (void)POPs; /* XXXX May be optimized away? */
1c846c1f 905 EXTEND(SP, maxarg);
93965878 906 if (SvRMAGICAL(av)) {
1c846c1f 907 U32 i;
eb160463 908 for (i=0; i < (U32)maxarg; i++) {
0bcc34c2 909 SV ** const svp = av_fetch(av, i, FALSE);
547d1dd8
HS		 910 /* See note in pp_helem, and bug id #27839 */
911 SP[i+1] = svp
912 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
913 : &PL_sv_undef;
93965878 914 }
1c846c1f 915 }
93965878
NIS		 916 else {
917 Copy(AvARRAY(av), SP+1, maxarg, SV*);
918 }
a0d0e21e
LW		 919 SP += maxarg;
920 }
cde874ca 921 else if (gimme == G_SCALAR) {
a0d0e21e 922 dTARGET;
a3b680e6 923 const I32 maxarg = AvFILL(av) + 1;
f5284f61 924 SETi(maxarg);
a0d0e21e 925 }
17ab7946
NC		 926 } else {
927 /* The guts of pp_rv2hv */
be85d344 928 if (gimme == G_ARRAY) { /* array wanted */
17ab7946 929 *PL_stack_sp = sv;
cea2e8a9 930 return do_kv();
a0d0e21e 931 }
be85d344 932 else if (gimme == G_SCALAR) {
a0d0e21e 933 dTARGET;
17ab7946 934 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
5e17dd7d 935 SPAGAIN;
a0d0e21e 936 SETTARG;
a0d0e21e 937 }
17ab7946 938 }
be85d344 939 RETURN;
a0d0e21e
LW		 940}
941
10c8fecd
GS		 942STATIC void
943S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
944{
97aff369 945 dVAR;
10c8fecd
GS		 946 if (*relem) {
947 SV *tmpstr;
b464bac0 948 const HE *didstore;
6d822dc4
MS		 949
950 if (ckWARN(WARN_MISC)) {
a3b680e6 951 const char *err;
10c8fecd
GS		 952 if (relem == firstrelem &&
953 SvROK(*relem) &&
954 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
955 SvTYPE(SvRV(*relem)) == SVt_PVHV))
956 {
a3b680e6 957 err = "Reference found where even-sized list expected";
10c8fecd
GS		 958 }
959 else
a3b680e6
AL		 960 err = "Odd number of elements in hash assignment";
961 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
10c8fecd 962 }
6d822dc4 963
561b68a9 964 tmpstr = newSV(0);
6d822dc4
MS		 965 didstore = hv_store_ent(hash,*relem,tmpstr,0);
966 if (SvMAGICAL(hash)) {
967 if (SvSMAGICAL(tmpstr))
968 mg_set(tmpstr);
969 if (!didstore)
970 sv_2mortal(tmpstr);
971 }
972 TAINT_NOT;
10c8fecd
GS		 973 }
974}
975
a0d0e21e
LW		 976PP(pp_aassign)
977{
27da23d5 978 dVAR; dSP;
3280af22
NIS		 979 SV **lastlelem = PL_stack_sp;
980 SV **lastrelem = PL_stack_base + POPMARK;
981 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW		 982 SV **firstlelem = lastrelem + 1;
983
984 register SV **relem;
985 register SV **lelem;
986
987 register SV *sv;
988 register AV *ary;
989
54310121 990 I32 gimme;
a0d0e21e
LW		 991 HV *hash;
992 I32 i;
993 int magic;
ca65944e 994 int duplicates = 0;
cbbf8932 995 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
5637b936 996
3280af22 997 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
ca65944e 998 gimme = GIMME_V;
a0d0e21e
LW		 999
1000 /* If there's a common identifier on both sides we have to take
1001 * special care that assigning the identifier on the left doesn't
1002 * clobber a value on the right that's used later in the list.
1003 */
10c8fecd 1004 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
cc5e57d2 1005 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd 1006 for (relem = firstrelem; relem <= lastrelem; relem++) {
155aba94 1007 if ((sv = *relem)) {
a1f49e72 1008 TAINT_NOT; /* Each item is independent */
10c8fecd 1009 *relem = sv_mortalcopy(sv);
a1f49e72 1010 }
10c8fecd 1011 }
a0d0e21e
LW		 1012 }
1013
1014 relem = firstrelem;
1015 lelem = firstlelem;
4608196e
RGS		 1016 ary = NULL;
1017 hash = NULL;
10c8fecd 1018
a0d0e21e 1019 while (lelem <= lastlelem) {
bbce6d69 1020 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e
LW		 1021 sv = *lelem++;
1022 switch (SvTYPE(sv)) {
1023 case SVt_PVAV:
1024 ary = (AV*)sv;
748a9306 1025 magic = SvMAGICAL(ary) != 0;
a0d0e21e 1026 av_clear(ary);
7e42bd57 1027 av_extend(ary, lastrelem - relem);
a0d0e21e
LW		 1028 i = 0;
1029 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 1030 SV **didstore;
a0d0e21e 1031 assert(*relem);
f2b990bf 1032 sv = newSVsv(*relem);
a0d0e21e 1033 *(relem++) = sv;
5117ca91
GS		 1034 didstore = av_store(ary,i++,sv);
1035 if (magic) {
fb73857a 1036 if (SvSMAGICAL(sv))
1037 mg_set(sv);
5117ca91 1038 if (!didstore)
8127e0e3 1039 sv_2mortal(sv);
5117ca91 1040 }
bbce6d69 1041 TAINT_NOT;
a0d0e21e 1042 }
934dcd01
RD		 1043 if (PL_delaymagic & DM_ARRAY)
1044 SvSETMAGIC((SV*)ary);
a0d0e21e 1045 break;
10c8fecd 1046 case SVt_PVHV: { /* normal hash */
a0d0e21e
LW		 1047 SV *tmpstr;
1048
1049 hash = (HV*)sv;
748a9306 1050 magic = SvMAGICAL(hash) != 0;
a0d0e21e 1051 hv_clear(hash);
ca65944e 1052 firsthashrelem = relem;
a0d0e21e
LW		 1053
1054 while (relem < lastrelem) { /* gobble up all the rest */
5117ca91 1055 HE *didstore;
6136c704
AL		 1056 sv = *relem ? *relem : &PL_sv_no;
1057 relem++;
561b68a9 1058 tmpstr = newSV(0);
a0d0e21e
LW		 1059 if (*relem)
1060 sv_setsv(tmpstr,*relem); /* value */
1061 *(relem++) = tmpstr;
ca65944e
RGS		 1062 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1063 /* key overwrites an existing entry */
1064 duplicates += 2;
5117ca91
GS		 1065 didstore = hv_store_ent(hash,sv,tmpstr,0);
1066 if (magic) {
fb73857a 1067 if (SvSMAGICAL(tmpstr))
1068 mg_set(tmpstr);
5117ca91 1069 if (!didstore)
8127e0e3 1070 sv_2mortal(tmpstr);
5117ca91 1071 }
bbce6d69 1072 TAINT_NOT;
8e07c86e 1073 }
6a0deba8 1074 if (relem == lastrelem) {
10c8fecd 1075 do_oddball(hash, relem, firstrelem);
6a0deba8 1076 relem++;
1930e939 1077 }
a0d0e21e
LW		 1078 }
1079 break;
1080 default:
6fc92669
GS		 1081 if (SvIMMORTAL(sv)) {
1082 if (relem <= lastrelem)
1083 relem++;
1084 break;
a0d0e21e
LW		 1085 }
1086 if (relem <= lastrelem) {
1087 sv_setsv(sv, *relem);
1088 *(relem++) = sv;
1089 }
1090 else
3280af22 1091 sv_setsv(sv, &PL_sv_undef);
a0d0e21e
LW		 1092 SvSETMAGIC(sv);
1093 break;
1094 }
1095 }
3280af22
NIS		 1096 if (PL_delaymagic & ~DM_DELAY) {
1097 if (PL_delaymagic & DM_UID) {
a0d0e21e 1098#ifdef HAS_SETRESUID
fb934a90
RD		 1099 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1100 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1101 (Uid_t)-1);
56febc5e
AD		 1102#else
1103# ifdef HAS_SETREUID
fb934a90
RD		 1104 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1105 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
56febc5e
AD		 1106# else
1107# ifdef HAS_SETRUID
b28d0864
NIS		 1108 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1109 (void)setruid(PL_uid);
1110 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1111 }
56febc5e
AD		 1112# endif /* HAS_SETRUID */
1113# ifdef HAS_SETEUID
b28d0864 1114 if ((PL_delaymagic & DM_UID) == DM_EUID) {
fb934a90 1115 (void)seteuid(PL_euid);
b28d0864 1116 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1117 }
56febc5e 1118# endif /* HAS_SETEUID */
b28d0864
NIS		 1119 if (PL_delaymagic & DM_UID) {
1120 if (PL_uid != PL_euid)
cea2e8a9 1121 DIE(aTHX_ "No setreuid available");
b28d0864 1122 (void)PerlProc_setuid(PL_uid);
a0d0e21e 1123 }
56febc5e
AD		 1124# endif /* HAS_SETREUID */
1125#endif /* HAS_SETRESUID */
d8eceb89
JH		 1126 PL_uid = PerlProc_getuid();
1127 PL_euid = PerlProc_geteuid();
a0d0e21e 1128 }
3280af22 1129 if (PL_delaymagic & DM_GID) {
a0d0e21e 1130#ifdef HAS_SETRESGID
fb934a90
RD		 1131 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1132 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1133 (Gid_t)-1);
56febc5e
AD		 1134#else
1135# ifdef HAS_SETREGID
fb934a90
RD		 1136 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1137 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
56febc5e
AD		 1138# else
1139# ifdef HAS_SETRGID
b28d0864
NIS		 1140 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1141 (void)setrgid(PL_gid);
1142 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1143 }
56febc5e
AD		 1144# endif /* HAS_SETRGID */
1145# ifdef HAS_SETEGID
b28d0864 1146 if ((PL_delaymagic & DM_GID) == DM_EGID) {
fb934a90 1147 (void)setegid(PL_egid);
b28d0864 1148 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1149 }
56febc5e 1150# endif /* HAS_SETEGID */
b28d0864
NIS		 1151 if (PL_delaymagic & DM_GID) {
1152 if (PL_gid != PL_egid)
cea2e8a9 1153 DIE(aTHX_ "No setregid available");
b28d0864 1154 (void)PerlProc_setgid(PL_gid);
a0d0e21e 1155 }
56febc5e
AD		 1156# endif /* HAS_SETREGID */
1157#endif /* HAS_SETRESGID */
d8eceb89
JH		 1158 PL_gid = PerlProc_getgid();
1159 PL_egid = PerlProc_getegid();
a0d0e21e 1160 }
3280af22 1161 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
a0d0e21e 1162 }
3280af22 1163 PL_delaymagic = 0;
54310121 1164
54310121 1165 if (gimme == G_VOID)
1166 SP = firstrelem - 1;
1167 else if (gimme == G_SCALAR) {
1168 dTARGET;
1169 SP = firstrelem;
ca65944e 1170 SETi(lastrelem - firstrelem + 1 - duplicates);
54310121 1171 }
1172 else {
ca65944e 1173 if (ary)
a0d0e21e 1174 SP = lastrelem;
ca65944e
RGS		 1175 else if (hash) {
1176 if (duplicates) {
1177 /* Removes from the stack the entries which ended up as
1178 * duplicated keys in the hash (fix for [perl #24380]) */
1179 Move(firsthashrelem + duplicates,
1180 firsthashrelem, duplicates, SV**);
1181 lastrelem -= duplicates;
1182 }
1183 SP = lastrelem;
1184 }
a0d0e21e
LW		 1185 else
1186 SP = firstrelem + (lastlelem - firstlelem);
0c8c7a05 1187 lelem = firstlelem + (relem - firstrelem);
5f05dabc 1188 while (relem <= SP)
3280af22 1189 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
a0d0e21e 1190 }
08aeb9f7 1191
54310121 1192 RETURN;
a0d0e21e
LW		 1193}
1194
8782bef2
GB		 1195PP(pp_qr)
1196{
97aff369 1197 dVAR; dSP;
c4420975 1198 register PMOP * const pm = cPMOP;
fe578d7f 1199 REGEXP * rx = PM_GETRE(pm);
10599a69 1200 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
c4420975 1201 SV * const rv = sv_newmortal();
288b8c02 1202
10599a69
NC		 1203 if (!rx) {
1204 /* FIXME ORANGE.
1205 This can go if/when regexps are stored directly in PL_regex_pad
1206 rather than via references. do_clean_objs finds and frees them
1207 when they are stored as references. */
1208 XPUSHs(rv);
1209 RETURN;
1210 }
1211
288b8c02
NC		 1212 SvUPGRADE(rv, SVt_IV);
1213 /* This RV is about to own a reference to the regexp. (In addition to the
1214 reference already owned by the PMOP. */
1215 ReREFCNT_inc(rx);
d2f13c59 1216 SvRV_set(rv, (SV*) rx);
288b8c02
NC		 1217 SvROK_on(rv);
1218
1219 if (pkg) {
1220 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1221 (void)sv_bless(rv, stash);
1222 }
1223
07bc277f 1224 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
e08e52cf 1225 SvTAINTED_on(rv);
c8c13c22
JB		 1226 XPUSHs(rv);
1227 RETURN;
8782bef2
GB		 1228}
1229
a0d0e21e
LW		 1230PP(pp_match)
1231{
97aff369 1232 dVAR; dSP; dTARG;
a0d0e21e 1233 register PMOP *pm = cPMOP;
d65afb4b 1234 PMOP *dynpm = pm;
0d46e09a
SP		 1235 register const char *t;
1236 register const char *s;
5c144d81 1237 const char *strend;
a0d0e21e 1238 I32 global;
f722798b 1239 I32 r_flags = REXEC_CHECKED;
5c144d81 1240 const char *truebase; /* Start of string */
aaa362c4 1241 register REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1242 bool rxtainted;
a3b680e6 1243 const I32 gimme = GIMME;
a0d0e21e 1244 STRLEN len;
748a9306 1245 I32 minmatch = 0;
a3b680e6 1246 const I32 oldsave = PL_savestack_ix;
f86702cc 1247 I32 update_minmatch = 1;
e60df1fa 1248 I32 had_zerolen = 0;
58e23c8d 1249 U32 gpos = 0;
a0d0e21e 1250
533c011a 1251 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1252 TARG = POPs;
59f00321
RGS		 1253 else if (PL_op->op_private & OPpTARGET_MY)
1254 GETTARGET;
a0d0e21e 1255 else {
54b9620d 1256 TARG = DEFSV;
a0d0e21e
LW		 1257 EXTEND(SP,1);
1258 }
d9f424b2 1259
c277df42 1260 PUTBACK; /* EVAL blocks need stack_sp. */
5c144d81 1261 s = SvPV_const(TARG, len);
a0d0e21e 1262 if (!s)
2269b42e 1263 DIE(aTHX_ "panic: pp_match");
890ce7af 1264 strend = s + len;
07bc277f 1265 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
3280af22 1266 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1267 TAINT_NOT;
a0d0e21e 1268
a30b2f1f 1269 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 1270
d65afb4b 1271 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO		 1272 if (
1273#ifdef USE_ITHREADS
1274 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1275#else
1276 pm->op_pmflags & PMf_USED
1277#endif
1278 ) {
c277df42 1279 failure:
a0d0e21e
LW		 1280 if (gimme == G_ARRAY)
1281 RETURN;
1282 RETPUSHNO;
1283 }
1284
c737faaf
YO		 1285
1286
d65afb4b 1287 /* empty pattern special-cased to use last successful pattern if possible */
220fc49f 1288 if (!RX_PRELEN(rx) && PL_curpm) {
3280af22 1289 pm = PL_curpm;
aaa362c4 1290 rx = PM_GETRE(pm);
a0d0e21e 1291 }
d65afb4b 1292
07bc277f 1293 if (RX_MINLEN(rx) > (I32)len)
d65afb4b 1294 goto failure;
c277df42 1295
a0d0e21e 1296 truebase = t = s;
ad94a511
IZ		 1297
1298 /* XXXX What part of this is needed with true \G-support? */
d65afb4b 1299 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
07bc277f 1300 RX_OFFS(rx)[0].start = -1;
a0d0e21e 1301 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
c445ea15 1302 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
565764a8 1303 if (mg && mg->mg_len >= 0) {
07bc277f
NC		 1304 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1305 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1306 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
0ef3e39e 1307 r_flags |= REXEC_IGNOREPOS;
07bc277f
NC		 1308 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1309 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
58e23c8d
YO		 1310 gpos = mg->mg_len;
1311 else
07bc277f
NC		 1312 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1313 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
f86702cc 1314 update_minmatch = 0;
748a9306 1315 }
a0d0e21e
LW		 1316 }
1317 }
a229a030 1318 /* XXX: comment out !global get safe $1 vars after a
62e7980d 1319 match, BUT be aware that this leads to dramatic slowdowns on
a229a030
YO		 1320 /g matches against large strings. So far a solution to this problem
1321 appears to be quite tricky.
1322 Test for the unsafe vars are TODO for now. */
07bc277f 1323 if (( !global && RX_NPARENS(rx))
cde0cee5 1324 || SvTEMP(TARG) || PL_sawampersand ||
07bc277f 1325 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
14977893 1326 r_flags |= REXEC_COPY_STR;
1c846c1f 1327 if (SvSCREAM(TARG))
22e551b9
IZ		 1328 r_flags |= REXEC_SCREAM;
1329
a0d0e21e 1330play_it_again:
07bc277f
NC		 1331 if (global && RX_OFFS(rx)[0].start != -1) {
1332 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1333 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
a0d0e21e 1334 goto nope;
f86702cc 1335 if (update_minmatch++)
e60df1fa 1336 minmatch = had_zerolen;
a0d0e21e 1337 }
07bc277f 1338 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
3c8556c3 1339 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
5c144d81
NC		 1340 /* FIXME - can PL_bostr be made const char *? */
1341 PL_bostr = (char *)truebase;
f9f4320a 1342 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
f722798b
IZ		 1343
1344 if (!s)
1345 goto nope;
07bc277f 1346 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
14977893 1347 && !PL_sawampersand
07bc277f
NC		 1348 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1349 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1350 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
05b4157f
GS		 1351 && (r_flags & REXEC_SCREAM)))
1352 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
f722798b 1353 goto yup;
a0d0e21e 1354 }
1f36f092
RB		 1355 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1356 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
bbce6d69 1357 {
3280af22 1358 PL_curpm = pm;
c737faaf
YO		 1359 if (dynpm->op_pmflags & PMf_ONCE) {
1360#ifdef USE_ITHREADS
1361 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1362#else
1363 dynpm->op_pmflags |= PMf_USED;
1364#endif
1365 }
a0d0e21e
LW		 1366 goto gotcha;
1367 }
1368 else
1369 goto ret_no;
1370 /*NOTREACHED*/
1371
1372 gotcha:
72311751
GS		 1373 if (rxtainted)
1374 RX_MATCH_TAINTED_on(rx);
1375 TAINT_IF(RX_MATCH_TAINTED(rx));
a0d0e21e 1376 if (gimme == G_ARRAY) {
07bc277f 1377 const I32 nparens = RX_NPARENS(rx);
a3b680e6 1378 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 1379
c277df42 1380 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH		 1381 EXTEND(SP, nparens + i);
1382 EXTEND_MORTAL(nparens + i);
1383 for (i = !i; i <= nparens; i++) {
a0d0e21e 1384 PUSHs(sv_newmortal());
07bc277f
NC		 1385 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1386 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1387 s = RX_OFFS(rx)[i].start + truebase;
1388 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
290deeac
A		 1389 len < 0 || len > strend - s)
1390 DIE(aTHX_ "panic: pp_match start/end pointers");
a0d0e21e 1391 sv_setpvn(*SP, s, len);
cce850e4 1392 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1393 SvUTF8_on(*SP);
a0d0e21e
LW		 1394 }
1395 }
1396 if (global) {
d65afb4b 1397 if (dynpm->op_pmflags & PMf_CONTINUE) {
6136c704 1398 MAGIC* mg = NULL;
0af80b60
HS		 1399 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1400 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1401 if (!mg) {
d83f0a82
NC		 1402#ifdef PERL_OLD_COPY_ON_WRITE
1403 if (SvIsCOW(TARG))
1404 sv_force_normal_flags(TARG, 0);
1405#endif
1406 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1407 &PL_vtbl_mglob, NULL, 0);
0af80b60 1408 }
07bc277f
NC		 1409 if (RX_OFFS(rx)[0].start != -1) {
1410 mg->mg_len = RX_OFFS(rx)[0].end;
1411 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
0af80b60
HS		 1412 mg->mg_flags |= MGf_MINMATCH;
1413 else
1414 mg->mg_flags &= ~MGf_MINMATCH;
1415 }
1416 }
07bc277f
NC		 1417 had_zerolen = (RX_OFFS(rx)[0].start != -1
1418 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1419 == (UV)RX_OFFS(rx)[0].end));
c277df42 1420 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1421 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW		 1422 goto play_it_again;
1423 }
ffc61ed2 1424 else if (!nparens)
bde848c5 1425 XPUSHs(&PL_sv_yes);
4633a7c4 1426 LEAVE_SCOPE(oldsave);
a0d0e21e
LW		 1427 RETURN;
1428 }
1429 else {
1430 if (global) {
cbbf8932 1431 MAGIC* mg;
a0d0e21e 1432 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
14befaf4 1433 mg = mg_find(TARG, PERL_MAGIC_regex_global);
cbbf8932
AL		 1434 else
1435 mg = NULL;
a0d0e21e 1436 if (!mg) {
d83f0a82
NC		 1437#ifdef PERL_OLD_COPY_ON_WRITE
1438 if (SvIsCOW(TARG))
1439 sv_force_normal_flags(TARG, 0);
1440#endif
1441 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1442 &PL_vtbl_mglob, NULL, 0);
a0d0e21e 1443 }
07bc277f
NC		 1444 if (RX_OFFS(rx)[0].start != -1) {
1445 mg->mg_len = RX_OFFS(rx)[0].end;
1446 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
748a9306
LW		 1447 mg->mg_flags |= MGf_MINMATCH;
1448 else
1449 mg->mg_flags &= ~MGf_MINMATCH;
1450 }
a0d0e21e 1451 }
4633a7c4 1452 LEAVE_SCOPE(oldsave);
a0d0e21e
LW		 1453 RETPUSHYES;
1454 }
1455
f722798b 1456yup: /* Confirmed by INTUIT */
72311751
GS		 1457 if (rxtainted)
1458 RX_MATCH_TAINTED_on(rx);
1459 TAINT_IF(RX_MATCH_TAINTED(rx));
3280af22 1460 PL_curpm = pm;
c737faaf
YO		 1461 if (dynpm->op_pmflags & PMf_ONCE) {
1462#ifdef USE_ITHREADS
1463 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1464#else
1465 dynpm->op_pmflags |= PMf_USED;
1466#endif
1467 }
cf93c79d 1468 if (RX_MATCH_COPIED(rx))
07bc277f 1469 Safefree(RX_SUBBEG(rx));
cf93c79d 1470 RX_MATCH_COPIED_off(rx);
07bc277f 1471 RX_SUBBEG(rx) = NULL;
a0d0e21e 1472 if (global) {
5c144d81 1473 /* FIXME - should rx->subbeg be const char *? */
07bc277f
NC		 1474 RX_SUBBEG(rx) = (char *) truebase;
1475 RX_OFFS(rx)[0].start = s - truebase;
a30b2f1f 1476 if (RX_MATCH_UTF8(rx)) {
07bc277f
NC		 1477 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1478 RX_OFFS(rx)[0].end = t - truebase;
60aeb6fd
NIS		 1479 }
1480 else {
07bc277f 1481 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
60aeb6fd 1482 }
07bc277f 1483 RX_SUBLEN(rx) = strend - truebase;
a0d0e21e 1484 goto gotcha;
1c846c1f 1485 }
07bc277f 1486 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
14977893 1487 I32 off;
f8c7b90f 1488#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 1489 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1490 if (DEBUG_C_TEST) {
1491 PerlIO_printf(Perl_debug_log,
1492 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
6c9570dc 1493 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
ed252734
NC		 1494 (int)(t-truebase));
1495 }
bdd9a1b1
NC		 1496 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1497 RX_SUBBEG(rx)
1498 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1499 assert (SvPOKp(RX_SAVED_COPY(rx)));
ed252734
NC		 1500 } else
1501#endif
1502 {
14977893 1503
07bc277f 1504 RX_SUBBEG(rx) = savepvn(t, strend - t);
f8c7b90f 1505#ifdef PERL_OLD_COPY_ON_WRITE
bdd9a1b1 1506 RX_SAVED_COPY(rx) = NULL;
ed252734
NC		 1507#endif
1508 }
07bc277f 1509 RX_SUBLEN(rx) = strend - t;
14977893 1510 RX_MATCH_COPIED_on(rx);
07bc277f
NC		 1511 off = RX_OFFS(rx)[0].start = s - t;
1512 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
14977893
JH		 1513 }
1514 else { /* startp/endp are used by @- @+. */
07bc277f
NC		 1515 RX_OFFS(rx)[0].start = s - truebase;
1516 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
14977893 1517 }
07bc277f 1518 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
cde0cee5 1519 -dmq */
07bc277f 1520 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
4633a7c4 1521 LEAVE_SCOPE(oldsave);
a0d0e21e
LW		 1522 RETPUSHYES;
1523
1524nope:
a0d0e21e 1525ret_no:
d65afb4b 1526 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e 1527 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
6136c704 1528 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1529 if (mg)
565764a8 1530 mg->mg_len = -1;
a0d0e21e
LW		 1531 }
1532 }
4633a7c4 1533 LEAVE_SCOPE(oldsave);
a0d0e21e
LW		 1534 if (gimme == G_ARRAY)
1535 RETURN;
1536 RETPUSHNO;
1537}
1538
1539OP *
864dbfa3 1540Perl_do_readline(pTHX)
a0d0e21e 1541{
27da23d5 1542 dVAR; dSP; dTARGETSTACKED;
a0d0e21e
LW		 1543 register SV *sv;
1544 STRLEN tmplen = 0;
1545 STRLEN offset;
760ac839 1546 PerlIO *fp;
a3b680e6
AL		 1547 register IO * const io = GvIO(PL_last_in_gv);
1548 register const I32 type = PL_op->op_type;
1549 const I32 gimme = GIMME_V;
a0d0e21e 1550
6136c704
AL		 1551 if (io) {
1552 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1553 if (mg) {
1554 PUSHMARK(SP);
1555 XPUSHs(SvTIED_obj((SV*)io, mg));
1556 PUTBACK;
1557 ENTER;
1558 call_method("READLINE", gimme);
1559 LEAVE;
1560 SPAGAIN;
1561 if (gimme == G_SCALAR) {
1562 SV* const result = POPs;
1563 SvSetSV_nosteal(TARG, result);
1564 PUSHTARG;
1565 }
1566 RETURN;
0b7c7b4f 1567 }
e79b0511 1568 }
4608196e 1569 fp = NULL;
a0d0e21e
LW		 1570 if (io) {
1571 fp = IoIFP(io);
1572 if (!fp) {
1573 if (IoFLAGS(io) & IOf_ARGV) {
1574 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1575 IoLINES(io) = 0;
3280af22 1576 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1577 IoFLAGS(io) &= ~IOf_START;
4608196e 1578 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
c69033f2 1579 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
3280af22 1580 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS		 1581 fp = IoIFP(io);
1582 goto have_fp;
a0d0e21e
LW		 1583 }
1584 }
3280af22 1585 fp = nextargv(PL_last_in_gv);
a0d0e21e 1586 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1587 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW		 1588 }
1589 }
0d44d22b
NC		 1590 else if (type == OP_GLOB)
1591 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW		 1592 }
1593 else if (type == OP_GLOB)
1594 SP--;
a00b5bd3 1595 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
4c80c0b2 1596 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
a00b5bd3 1597 }
a0d0e21e
LW		 1598 }
1599 if (!fp) {
041457d9
DM		 1600 if ((!io || !(IoFLAGS(io) & IOf_START))
1601 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1602 {
3f4520fe 1603 if (type == OP_GLOB)
9014280d 1604 Perl_warner(aTHX_ packWARN(WARN_GLOB),
af8c498a
GS		 1605 "glob failed (can't start child: %s)",
1606 Strerror(errno));
69282e91 1607 else
bc37a18f 1608 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
3f4520fe 1609 }
54310121 1610 if (gimme == G_SCALAR) {
79628082 1611 /* undef TARG, and push that undefined value */
ba92458f
AE		 1612 if (type != OP_RCATLINE) {
1613 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1614 SvOK_off(TARG);
ba92458f 1615 }
a0d0e21e
LW		 1616 PUSHTARG;
1617 }
1618 RETURN;
1619 }
a2008d6d 1620 have_fp:
54310121 1621 if (gimme == G_SCALAR) {
a0d0e21e 1622 sv = TARG;
0f722b55
RGS		 1623 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1624 mg_get(sv);
48de12d9
RGS		 1625 if (SvROK(sv)) {
1626 if (type == OP_RCATLINE)
1627 SvPV_force_nolen(sv);
1628 else
1629 sv_unref(sv);
1630 }
f7877b28
NC		 1631 else if (isGV_with_GP(sv)) {
1632 SvPV_force_nolen(sv);
1633 }
862a34c6 1634 SvUPGRADE(sv, SVt_PV);
a0d0e21e 1635 tmplen = SvLEN(sv); /* remember if already alloced */
bc44a8a2 1636 if (!tmplen && !SvREADONLY(sv))
a0d0e21e 1637 Sv_Grow(sv, 80); /* try short-buffering it */
2b5e58c4
AMS		 1638 offset = 0;
1639 if (type == OP_RCATLINE && SvOK(sv)) {
1640 if (!SvPOK(sv)) {
8b6b16e7 1641 SvPV_force_nolen(sv);
2b5e58c4 1642 }
a0d0e21e 1643 offset = SvCUR(sv);
2b5e58c4 1644 }
a0d0e21e 1645 }
54310121 1646 else {
561b68a9 1647 sv = sv_2mortal(newSV(80));
54310121 1648 offset = 0;
1649 }
fbad3eb5 1650
3887d568
AP		 1651 /* This should not be marked tainted if the fp is marked clean */
1652#define MAYBE_TAINT_LINE(io, sv) \
1653 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1654 TAINT; \
1655 SvTAINTED_on(sv); \
1656 }
1657
684bef36 1658/* delay EOF state for a snarfed empty file */
fbad3eb5 1659#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1660 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1661 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1662
a0d0e21e 1663 for (;;) {
09e8efcc 1664 PUTBACK;
fbad3eb5 1665 if (!sv_gets(sv, fp, offset)
2d726892
TF		 1666 && (type == OP_GLOB
1667 || SNARF_EOF(gimme, PL_rs, io, sv)
1668 || PerlIO_error(fp)))
fbad3eb5 1669 {
760ac839 1670 PerlIO_clearerr(fp);
a0d0e21e 1671 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1672 fp = nextargv(PL_last_in_gv);
a0d0e21e
LW		 1673 if (fp)
1674 continue;
3280af22 1675 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW		 1676 }
1677 else if (type == OP_GLOB) {
e476b1b5 1678 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
9014280d 1679 Perl_warner(aTHX_ packWARN(WARN_GLOB),
4eb79ab5 1680 "glob failed (child exited with status %d%s)",
894356b3 1681 (int)(STATUS_CURRENT >> 8),
cf494569 1682 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1683 }
a0d0e21e 1684 }
54310121 1685 if (gimme == G_SCALAR) {
ba92458f
AE		 1686 if (type != OP_RCATLINE) {
1687 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1688 SvOK_off(TARG);
ba92458f 1689 }
09e8efcc 1690 SPAGAIN;
a0d0e21e
LW		 1691 PUSHTARG;
1692 }
3887d568 1693 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW		 1694 RETURN;
1695 }
3887d568 1696 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1697 IoLINES(io)++;
b9fee9ba 1698 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1699 SvSETMAGIC(sv);
09e8efcc 1700 SPAGAIN;
a0d0e21e 1701 XPUSHs(sv);
a0d0e21e 1702 if (type == OP_GLOB) {
349d4f2f 1703 const char *t1;
a0d0e21e 1704
3280af22 1705 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 1706 char * const tmps = SvEND(sv) - 1;
aa07b2f6 1707 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 1708 *tmps = '\0';
b162af07 1709 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd 1710 }
1711 }
349d4f2f
NC		 1712 for (t1 = SvPVX_const(sv); *t1; t1++)
1713 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1714 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
a0d0e21e 1715 break;
349d4f2f 1716 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
a0d0e21e
LW		 1717 (void)POPs; /* Unmatched wildcard? Chuck it... */
1718 continue;
1719 }
2d79bf7f 1720 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL		 1721 if (ckWARN(WARN_UTF8)) {
1722 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1723 const STRLEN len = SvCUR(sv) - offset;
1724 const U8 *f;
1725
1726 if (!is_utf8_string_loc(s, len, &f))
1727 /* Emulate :encoding(utf8) warning in the same case. */
1728 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1729 "utf8 \"\\x%02X\" does not map to Unicode",
1730 f < (U8*)SvEND(sv) ? *f : 0);
1731 }
a0d0e21e 1732 }
54310121 1733 if (gimme == G_ARRAY) {
a0d0e21e 1734 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 1735 SvPV_shrink_to_cur(sv);
a0d0e21e 1736 }
561b68a9 1737 sv = sv_2mortal(newSV(80));
a0d0e21e
LW		 1738 continue;
1739 }
54310121 1740 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 1741 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC		 1742 const STRLEN new_len
1743 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 1744 SvPV_renew(sv, new_len);
a0d0e21e
LW		 1745 }
1746 RETURN;
1747 }
1748}
1749
1750PP(pp_enter)
1751{
27da23d5 1752 dVAR; dSP;
c09156bb 1753 register PERL_CONTEXT *cx;
533c011a 1754 I32 gimme = OP_GIMME(PL_op, -1);
a0d0e21e 1755
54310121 1756 if (gimme == -1) {
1757 if (cxstack_ix >= 0)
1758 gimme = cxstack[cxstack_ix].blk_gimme;
1759 else
1760 gimme = G_SCALAR;
1761 }
a0d0e21e
LW		 1762
1763 ENTER;
1764
1765 SAVETMPS;
924508f0 1766 PUSHBLOCK(cx, CXt_BLOCK, SP);
a0d0e21e
LW		 1767
1768 RETURN;
1769}
1770
1771PP(pp_helem)
1772{
97aff369 1773 dVAR; dSP;
760ac839 1774 HE* he;
ae77835f 1775 SV **svp;
c445ea15
AL		 1776 SV * const keysv = POPs;
1777 HV * const hv = (HV*)POPs;
a3b680e6
AL		 1778 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1779 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1780 SV *sv;
c158a4fd 1781 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
9c5ffd7c 1782 I32 preeminent = 0;
a0d0e21e 1783
d4c19fe8 1784 if (SvTYPE(hv) != SVt_PVHV)
a0d0e21e 1785 RETPUSHUNDEF;
d4c19fe8
AL		 1786
1787 if (PL_op->op_private & OPpLVAL_INTRO) {
1788 MAGIC *mg;
1789 HV *stash;
1790 /* does the element we're localizing already exist? */
1791 preeminent = /* can we determine whether it exists? */
1792 ( !SvRMAGICAL(hv)
1793 || mg_find((SV*)hv, PERL_MAGIC_env)
1794 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1795 /* Try to preserve the existenceness of a tied hash
1796 * element by using EXISTS and DELETE if possible.
1797 * Fallback to FETCH and STORE otherwise */
1798 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1799 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1800 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1801 )
1802 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1803 }
1804 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1805 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 1806 if (lval) {
3280af22 1807 if (!svp || *svp == &PL_sv_undef) {
68dc0745 1808 SV* lv;
1809 SV* key2;
2d8e6c8d 1810 if (!defer) {
be2597df 1811 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 1812 }
68dc0745 1813 lv = sv_newmortal();
1814 sv_upgrade(lv, SVt_PVLV);
1815 LvTYPE(lv) = 'y';
6136c704 1816 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
68dc0745 1817 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
b37c2d43 1818 LvTARG(lv) = SvREFCNT_inc_simple(hv);
68dc0745 1819 LvTARGLEN(lv) = 1;
1820 PUSHs(lv);
1821 RETURN;
1822 }
533c011a 1823 if (PL_op->op_private & OPpLVAL_INTRO) {
bfcb3514 1824 if (HvNAME_get(hv) && isGV(*svp))
533c011a 1825 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1f5346dc
SC		 1826 else {
1827 if (!preeminent) {
1828 STRLEN keylen;
e62f0680 1829 const char * const key = SvPV_const(keysv, keylen);
7d654f43 1830 SAVEDELETE(hv, savepvn(key,keylen),
bb7a0f54 1831 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
bfc4de9f 1832 } else
1f5346dc
SC		 1833 save_helem(hv, keysv, svp);
1834 }
5f05dabc 1835 }
533c011a
NIS		 1836 else if (PL_op->op_private & OPpDEREF)
1837 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 1838 }
3280af22 1839 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS		 1840 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1841 * Pushing the magical RHS on to the stack is useless, since
1842 * that magic is soon destined to be misled by the local(),
1843 * and thus the later pp_sassign() will fail to mg_get() the
1844 * old value. This should also cure problems with delayed
1845 * mg_get()s. GSAR 98-07-03 */
1846 if (!lval && SvGMAGICAL(sv))
1847 sv = sv_mortalcopy(sv);
1848 PUSHs(sv);
a0d0e21e
LW		 1849 RETURN;
1850}
1851
1852PP(pp_leave)
1853{
27da23d5 1854 dVAR; dSP;
c09156bb 1855 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1856 SV **newsp;
1857 PMOP *newpm;
1858 I32 gimme;
1859
533c011a 1860 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1861 cx = &cxstack[cxstack_ix];
3280af22 1862 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
a0d0e21e
LW		 1863 }
1864
1865 POPBLOCK(cx,newpm);
1866
533c011a 1867 gimme = OP_GIMME(PL_op, -1);
54310121 1868 if (gimme == -1) {
1869 if (cxstack_ix >= 0)
1870 gimme = cxstack[cxstack_ix].blk_gimme;
1871 else
1872 gimme = G_SCALAR;
1873 }
a0d0e21e 1874
a1f49e72 1875 TAINT_NOT;
54310121 1876 if (gimme == G_VOID)
1877 SP = newsp;
1878 else if (gimme == G_SCALAR) {
a3b680e6 1879 register SV **mark;
54310121 1880 MARK = newsp + 1;
09256e2f 1881 if (MARK <= SP) {
54310121 1882 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1883 *MARK = TOPs;
1884 else
1885 *MARK = sv_mortalcopy(TOPs);
09256e2f 1886 } else {
54310121 1887 MEXTEND(mark,0);
3280af22 1888 *MARK = &PL_sv_undef;
a0d0e21e 1889 }
54310121 1890 SP = MARK;
a0d0e21e 1891 }
54310121 1892 else if (gimme == G_ARRAY) {
a1f49e72 1893 /* in case LEAVE wipes old return values */
a3b680e6 1894 register SV **mark;
a1f49e72
CS		 1895 for (mark = newsp + 1; mark <= SP; mark++) {
1896 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 1897 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 1898 TAINT_NOT; /* Each item is independent */
1899 }
1900 }
a0d0e21e 1901 }
3280af22 1902 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 1903
1904 LEAVE;
1905
1906 RETURN;
1907}
1908
1909PP(pp_iter)
1910{
97aff369 1911 dVAR; dSP;
c09156bb 1912 register PERL_CONTEXT *cx;
dc09a129 1913 SV *sv, *oldsv;
4633a7c4 1914 AV* av;
1d7c1841 1915 SV **itersvp;
a0d0e21e 1916
924508f0 1917 EXTEND(SP, 1);
a0d0e21e 1918 cx = &cxstack[cxstack_ix];
6b35e009 1919 if (CxTYPE(cx) != CXt_LOOP)
cea2e8a9 1920 DIE(aTHX_ "panic: pp_iter");
a0d0e21e 1921
1d7c1841 1922 itersvp = CxITERVAR(cx);
4633a7c4 1923 av = cx->blk_loop.iterary;
89ea2908
GA		 1924 if (SvTYPE(av) != SVt_PVAV) {
1925 /* iterate ($min .. $max) */
1926 if (cx->blk_loop.iterlval) {
1927 /* string increment */
1928 register SV* cur = cx->blk_loop.iterlval;
4fe3f0fa 1929 STRLEN maxlen = 0;
10edeb5d
JH		 1930 const char *max =
1931 SvOK((SV*)av) ?
1932 SvPV_const((SV*)av, maxlen) : (const char *)"";
89ea2908 1933 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1d7c1841 1934 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1935 /* safe to reuse old SV */
1d7c1841 1936 sv_setsv(*itersvp, cur);
eaa5c2d6 1937 }
1c846c1f 1938 else
eaa5c2d6
GA		 1939 {
1940 /* we need a fresh SV every time so that loop body sees a
1941 * completely new SV for closures/references to work as
1942 * they used to */
dc09a129 1943 oldsv = *itersvp;
1d7c1841 1944 *itersvp = newSVsv(cur);
dc09a129 1945 SvREFCNT_dec(oldsv);
eaa5c2d6 1946 }
aa07b2f6 1947 if (strEQ(SvPVX_const(cur), max))
89ea2908
GA		 1948 sv_setiv(cur, 0); /* terminate next time */
1949 else
1950 sv_inc(cur);
1951 RETPUSHYES;
1952 }
1953 RETPUSHNO;
1954 }
1955 /* integer increment */
1956 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1957 RETPUSHNO;
7f61b687 1958
3db8f154 1959 /* don't risk potential race */
1d7c1841 1960 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1961 /* safe to reuse old SV */
1d7c1841 1962 sv_setiv(*itersvp, cx->blk_loop.iterix++);
eaa5c2d6 1963 }
1c846c1f 1964 else
eaa5c2d6
GA		 1965 {
1966 /* we need a fresh SV every time so that loop body sees a
1967 * completely new SV for closures/references to work as they
1968 * used to */
dc09a129 1969 oldsv = *itersvp;
1d7c1841 1970 *itersvp = newSViv(cx->blk_loop.iterix++);
dc09a129 1971 SvREFCNT_dec(oldsv);
eaa5c2d6 1972 }
89ea2908
GA		 1973 RETPUSHYES;
1974 }
1975
1976 /* iterate array */
ef3e5ea9
NC		 1977 if (PL_op->op_private & OPpITER_REVERSED) {
1978 /* In reverse, use itermax as the min :-) */
c491ecac 1979 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
ef3e5ea9 1980 RETPUSHNO;
a0d0e21e 1981
ef3e5ea9 1982 if (SvMAGICAL(av) || AvREIFY(av)) {
c445ea15 1983 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
a0714e2c 1984 sv = svp ? *svp : NULL;
ef3e5ea9
NC		 1985 }
1986 else {
6e585ca0 1987 sv = AvARRAY(av)[--cx->blk_loop.iterix];
ef3e5ea9 1988 }
d42935ef
JH		 1989 }
1990 else {
ef3e5ea9
NC		 1991 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1992 AvFILL(av)))
1993 RETPUSHNO;
1994
1995 if (SvMAGICAL(av) || AvREIFY(av)) {
c445ea15 1996 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
a0714e2c 1997 sv = svp ? *svp : NULL;
ef3e5ea9
NC		 1998 }
1999 else {
2000 sv = AvARRAY(av)[++cx->blk_loop.iterix];
2001 }
d42935ef 2002 }
ef3e5ea9 2003
0565a181 2004 if (sv && SvIS_FREED(sv)) {
a0714e2c 2005 *itersvp = NULL;
b6c83531 2006 Perl_croak(aTHX_ "Use of freed value in iteration");
cccede53
DM		 2007 }
2008
d42935ef 2009 if (sv)
a0d0e21e 2010 SvTEMP_off(sv);
a0d0e21e 2011 else
3280af22 2012 sv = &PL_sv_undef;
8b530633 2013 if (av != PL_curstack && sv == &PL_sv_undef) {
5f05dabc 2014 SV *lv = cx->blk_loop.iterlval;
71be2cbc 2015 if (lv && SvREFCNT(lv) > 1) {
2016 SvREFCNT_dec(lv);
a0714e2c 2017 lv = NULL;
71be2cbc 2018 }
5f05dabc 2019 if (lv)
2020 SvREFCNT_dec(LvTARG(lv));
2021 else {
b9f83d2f 2022 lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
5f05dabc 2023 LvTYPE(lv) = 'y';
6136c704 2024 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
5f05dabc 2025 }
b37c2d43 2026 LvTARG(lv) = SvREFCNT_inc_simple(av);
5f05dabc 2027 LvTARGOFF(lv) = cx->blk_loop.iterix;
42718184 2028 LvTARGLEN(lv) = (STRLEN)UV_MAX;
5f05dabc 2029 sv = (SV*)lv;
2030 }
a0d0e21e 2031
dc09a129 2032 oldsv = *itersvp;
b37c2d43 2033 *itersvp = SvREFCNT_inc_simple_NN(sv);
dc09a129
DM		 2034 SvREFCNT_dec(oldsv);
2035
a0d0e21e
LW		 2036 RETPUSHYES;
2037}
2038
2039PP(pp_subst)
2040{
97aff369 2041 dVAR; dSP; dTARG;
a0d0e21e
LW		 2042 register PMOP *pm = cPMOP;
2043 PMOP *rpm = pm;
a0d0e21e
LW		 2044 register char *s;
2045 char *strend;
2046 register char *m;
5c144d81 2047 const char *c;
a0d0e21e
LW		 2048 register char *d;
2049 STRLEN clen;
2050 I32 iters = 0;
2051 I32 maxiters;
2052 register I32 i;
2053 bool once;
71be2cbc 2054 bool rxtainted;
a0d0e21e 2055 char *orig;
22e551b9 2056 I32 r_flags;
aaa362c4 2057 register REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW		 2058 STRLEN len;
2059 int force_on_match = 0;
0bcc34c2 2060 const I32 oldsave = PL_savestack_ix;
792b2c16 2061 STRLEN slen;
f272994b 2062 bool doutf8 = FALSE;
10300be4 2063 I32 matched;
f8c7b90f 2064#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 2065 bool is_cow;
2066#endif
a0714e2c 2067 SV *nsv = NULL;
a0d0e21e 2068
5cd24f17 2069 /* known replacement string? */
b37c2d43 2070 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
533c011a 2071 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 2072 TARG = POPs;
59f00321
RGS		 2073 else if (PL_op->op_private & OPpTARGET_MY)
2074 GETTARGET;
a0d0e21e 2075 else {
54b9620d 2076 TARG = DEFSV;
a0d0e21e 2077 EXTEND(SP,1);
1c846c1f 2078 }
d9f424b2 2079
f8c7b90f 2080#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 2081 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2082 because they make integers such as 256 "false". */
2083 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2084#else
765f542d
NC		 2085 if (SvIsCOW(TARG))
2086 sv_force_normal_flags(TARG,0);
ed252734
NC		 2087#endif
2088 if (
f8c7b90f 2089#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 2090 !is_cow &&
2091#endif
2092 (SvREADONLY(TARG)
cecf5685
NC		 2093 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2094 || SvTYPE(TARG) > SVt_PVLV)
4ce457a6 2095 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
d470f89e 2096 DIE(aTHX_ PL_no_modify);
8ec5e241
NIS		 2097 PUTBACK;
2098
d5263905 2099 s = SvPV_mutable(TARG, len);
68dc0745 2100 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 2101 force_on_match = 1;
07bc277f 2102 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
3280af22
NIS		 2103 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2104 if (PL_tainted)
b3eb6a9b 2105 rxtainted |= 2;
9212bbba 2106 TAINT_NOT;
a12c0f56 2107
a30b2f1f 2108 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 2109
a0d0e21e
LW		 2110 force_it:
2111 if (!pm || !s)
2269b42e 2112 DIE(aTHX_ "panic: pp_subst");
a0d0e21e
LW		 2113
2114 strend = s + len;
a30b2f1f 2115 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH		 2116 maxiters = 2 * slen + 10; /* We can match twice at each
2117 position, once with zero-length,
2118 second time with non-zero. */
a0d0e21e 2119
220fc49f 2120 if (!RX_PRELEN(rx) && PL_curpm) {
3280af22 2121 pm = PL_curpm;
aaa362c4 2122 rx = PM_GETRE(pm);
a0d0e21e 2123 }
07bc277f
NC		 2124 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2125 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
ed252734 2126 ? REXEC_COPY_STR : 0;
f722798b 2127 if (SvSCREAM(TARG))
22e551b9 2128 r_flags |= REXEC_SCREAM;
7fba1cd6 2129
a0d0e21e 2130 orig = m = s;
07bc277f 2131 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
ee0b7718 2132 PL_bostr = orig;
f9f4320a 2133 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
f722798b
IZ		 2134
2135 if (!s)
2136 goto nope;
2137 /* How to do it in subst? */
07bc277f 2138/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1c846c1f 2139 && !PL_sawampersand
07bc277f
NC		 2140 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2141 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2142 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
f722798b
IZ		 2143 && (r_flags & REXEC_SCREAM))))
2144 goto yup;
2145*/
a0d0e21e 2146 }
71be2cbc 2147
2148 /* only replace once? */
a0d0e21e 2149 once = !(rpm->op_pmflags & PMf_GLOBAL);
10300be4
YO		 2150 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2151 r_flags | REXEC_CHECKED);
71be2cbc 2152 /* known replacement string? */
f272994b 2153 if (dstr) {
8514a05a
JH		 2154 /* replacement needing upgrading? */
2155 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2156 nsv = sv_newmortal();
4a176938 2157 SvSetSV(nsv, dstr);
8514a05a
JH		 2158 if (PL_encoding)
2159 sv_recode_to_utf8(nsv, PL_encoding);
2160 else
2161 sv_utf8_upgrade(nsv);
5c144d81 2162 c = SvPV_const(nsv, clen);
4a176938
JH		 2163 doutf8 = TRUE;
2164 }
2165 else {
5c144d81 2166 c = SvPV_const(dstr, clen);
4a176938 2167 doutf8 = DO_UTF8(dstr);
8514a05a 2168 }
f272994b
A		 2169 }
2170 else {
6136c704 2171 c = NULL;
f272994b
A		 2172 doutf8 = FALSE;
2173 }
2174
71be2cbc 2175 /* can do inplace substitution? */
ed252734 2176 if (c
f8c7b90f 2177#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 2178 && !is_cow
2179#endif
07bc277f
NC		 2180 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2181 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
db79b45b 2182 && (!doutf8 || SvUTF8(TARG))) {
10300be4 2183 if (!matched)
f722798b 2184 {
8ec5e241 2185 SPAGAIN;
3280af22 2186 PUSHs(&PL_sv_no);
71be2cbc 2187 LEAVE_SCOPE(oldsave);
2188 RETURN;
2189 }
f8c7b90f 2190#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 2191 if (SvIsCOW(TARG)) {
2192 assert (!force_on_match);
2193 goto have_a_cow;
2194 }
2195#endif
71be2cbc 2196 if (force_on_match) {
2197 force_on_match = 0;
2198 s = SvPV_force(TARG, len);
2199 goto force_it;
2200 }
71be2cbc 2201 d = s;
3280af22 2202 PL_curpm = pm;
71be2cbc 2203 SvSCREAM_off(TARG); /* disable possible screamer */
2204 if (once) {
48c036b1 2205 rxtainted |= RX_MATCH_TAINTED(rx);
07bc277f
NC		 2206 m = orig + RX_OFFS(rx)[0].start;
2207 d = orig + RX_OFFS(rx)[0].end;
71be2cbc 2208 s = orig;
2209 if (m - s > strend - d) { /* faster to shorten from end */
2210 if (clen) {
2211 Copy(c, m, clen, char);
2212 m += clen;
a0d0e21e 2213 }
71be2cbc 2214 i = strend - d;
2215 if (i > 0) {
2216 Move(d, m, i, char);
2217 m += i;
a0d0e21e 2218 }
71be2cbc 2219 *m = '\0';
2220 SvCUR_set(TARG, m - s);
2221 }
155aba94 2222 else if ((i = m - s)) { /* faster from front */
71be2cbc 2223 d -= clen;
2224 m = d;
0d3c21b0 2225 Move(s, d - i, i, char);
71be2cbc 2226 sv_chop(TARG, d-i);
71be2cbc 2227 if (clen)
2228 Copy(c, m, clen, char);
2229 }
2230 else if (clen) {
2231 d -= clen;
2232 sv_chop(TARG, d);
2233 Copy(c, d, clen, char);
2234 }
2235 else {
2236 sv_chop(TARG, d);
2237 }
48c036b1 2238 TAINT_IF(rxtainted & 1);
8ec5e241 2239 SPAGAIN;
3280af22 2240 PUSHs(&PL_sv_yes);
71be2cbc 2241 }
2242 else {
71be2cbc 2243 do {
2244 if (iters++ > maxiters)
cea2e8a9 2245 DIE(aTHX_ "Substitution loop");
d9f97599 2246 rxtainted |= RX_MATCH_TAINTED(rx);
07bc277f 2247 m = RX_OFFS(rx)[0].start + orig;
155aba94 2248 if ((i = m - s)) {
71be2cbc 2249 if (s != d)
2250 Move(s, d, i, char);
2251 d += i;
a0d0e21e 2252 }
71be2cbc 2253 if (clen) {
2254 Copy(c, d, clen, char);
2255 d += clen;
2256 }
07bc277f 2257 s = RX_OFFS(rx)[0].end + orig;
f9f4320a 2258 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
f722798b
IZ		 2259 TARG, NULL,
2260 /* don't match same null twice */
2261 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc 2262 if (s != d) {
2263 i = strend - s;
aa07b2f6 2264 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 2265 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2266 }
48c036b1 2267 TAINT_IF(rxtainted & 1);
8ec5e241 2268 SPAGAIN;
6e449a3a 2269 mPUSHi((I32)iters);
a0d0e21e 2270 }
80b498e0 2271 (void)SvPOK_only_UTF8(TARG);
48c036b1 2272 TAINT_IF(rxtainted);
8ec5e241
NIS		 2273 if (SvSMAGICAL(TARG)) {
2274 PUTBACK;
2275 mg_set(TARG);
2276 SPAGAIN;
2277 }
9212bbba 2278 SvTAINT(TARG);
aefe6dfc
JH		 2279 if (doutf8)
2280 SvUTF8_on(TARG);
71be2cbc 2281 LEAVE_SCOPE(oldsave);
2282 RETURN;
a0d0e21e 2283 }
71be2cbc 2284
10300be4 2285 if (matched)
f722798b 2286 {
a0d0e21e
LW		 2287 if (force_on_match) {
2288 force_on_match = 0;
2289 s = SvPV_force(TARG, len);
2290 goto force_it;
2291 }
f8c7b90f 2292#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 2293 have_a_cow:
2294#endif
48c036b1 2295 rxtainted |= RX_MATCH_TAINTED(rx);
740cce10 2296 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
cff085c1 2297 SAVEFREESV(dstr);
3280af22 2298 PL_curpm = pm;
a0d0e21e 2299 if (!c) {
c09156bb 2300 register PERL_CONTEXT *cx;
8ec5e241 2301 SPAGAIN;
a0d0e21e 2302 PUSHSUBST(cx);
20e98b0f 2303 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
a0d0e21e 2304 }
cf93c79d 2305 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW		 2306 do {
2307 if (iters++ > maxiters)
cea2e8a9 2308 DIE(aTHX_ "Substitution loop");
d9f97599 2309 rxtainted |= RX_MATCH_TAINTED(rx);
07bc277f 2310 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
a0d0e21e
LW		 2311 m = s;
2312 s = orig;
07bc277f 2313 orig = RX_SUBBEG(rx);
a0d0e21e
LW		 2314 s = orig + (m - s);
2315 strend = s + (strend - m);
2316 }
07bc277f 2317 m = RX_OFFS(rx)[0].start + orig;
db79b45b
JH		 2318 if (doutf8 && !SvUTF8(dstr))
2319 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2320 else
2321 sv_catpvn(dstr, s, m-s);
07bc277f 2322 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e
LW		 2323 if (clen)
2324 sv_catpvn(dstr, c, clen);
2325 if (once)
2326 break;
f9f4320a 2327 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
ffc61ed2 2328 TARG, NULL, r_flags));
db79b45b
JH		 2329 if (doutf8 && !DO_UTF8(TARG))
2330 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
89afcb60
A		 2331 else
2332 sv_catpvn(dstr, s, strend - s);
748a9306 2333
f8c7b90f 2334#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 2335 /* The match may make the string COW. If so, brilliant, because that's
2336 just saved us one malloc, copy and free - the regexp has donated
2337 the old buffer, and we malloc an entirely new one, rather than the
2338 regexp malloc()ing a buffer and copying our original, only for
2339 us to throw it away here during the substitution. */
2340 if (SvIsCOW(TARG)) {
2341 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2342 } else
2343#endif
2344 {
8bd4d4c5 2345 SvPV_free(TARG);
ed252734 2346 }
f880fe2f 2347 SvPV_set(TARG, SvPVX(dstr));
748a9306
LW		 2348 SvCUR_set(TARG, SvCUR(dstr));
2349 SvLEN_set(TARG, SvLEN(dstr));
f272994b 2350 doutf8 |= DO_UTF8(dstr);
6136c704 2351 SvPV_set(dstr, NULL);
748a9306 2352
48c036b1 2353 TAINT_IF(rxtainted & 1);
f878fbec 2354 SPAGAIN;
6e449a3a 2355 mPUSHi((I32)iters);
48c036b1 2356
a0d0e21e 2357 (void)SvPOK_only(TARG);
f272994b 2358 if (doutf8)
60aeb6fd 2359 SvUTF8_on(TARG);
48c036b1 2360 TAINT_IF(rxtainted);
a0d0e21e 2361 SvSETMAGIC(TARG);
9212bbba 2362 SvTAINT(TARG);
4633a7c4 2363 LEAVE_SCOPE(oldsave);
a0d0e21e
LW		 2364 RETURN;
2365 }
5cd24f17 2366 goto ret_no;
a0d0e21e
LW		 2367
2368nope:
1c846c1f 2369ret_no:
8ec5e241 2370 SPAGAIN;
3280af22 2371 PUSHs(&PL_sv_no);
4633a7c4 2372 LEAVE_SCOPE(oldsave);
a0d0e21e
LW		 2373 RETURN;
2374}
2375
2376PP(pp_grepwhile)
2377{
27da23d5 2378 dVAR; dSP;
a0d0e21e
LW		 2379
2380 if (SvTRUEx(POPs))
3280af22
NIS		 2381 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2382 ++*PL_markstack_ptr;
a0d0e21e
LW		 2383 LEAVE; /* exit inner scope */
2384
2385 /* All done yet? */
3280af22 2386 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2387 I32 items;
c4420975 2388 const I32 gimme = GIMME_V;
a0d0e21e
LW		 2389
2390 LEAVE; /* exit outer scope */
2391 (void)POPMARK; /* pop src */
3280af22 2392 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2393 (void)POPMARK; /* pop dst */
3280af22 2394 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2395 if (gimme == G_SCALAR) {
7cc47870 2396 if (PL_op->op_private & OPpGREP_LEX) {
c4420975 2397 SV* const sv = sv_newmortal();
7cc47870
RGS		 2398 sv_setiv(sv, items);
2399 PUSHs(sv);
2400 }
2401 else {
2402 dTARGET;
2403 XPUSHi(items);
2404 }
a0d0e21e 2405 }
54310121 2406 else if (gimme == G_ARRAY)
2407 SP += items;
a0d0e21e
LW		 2408 RETURN;
2409 }
2410 else {
2411 SV *src;
2412
2413 ENTER; /* enter inner scope */
1d7c1841 2414 SAVEVPTR(PL_curpm);
a0d0e21e 2415
3280af22 2416 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2417 SvTEMP_off(src);
59f00321
RGS		 2418 if (PL_op->op_private & OPpGREP_LEX)
2419 PAD_SVl(PL_op->op_targ) = src;
2420 else
2421 DEFSV = src;
a0d0e21e
LW		 2422
2423 RETURNOP(cLOGOP->op_other);
2424 }
2425}
2426
2427PP(pp_leavesub)
2428{
27da23d5 2429 dVAR; dSP;
a0d0e21e
LW		 2430 SV **mark;
2431 SV **newsp;
2432 PMOP *newpm;
2433 I32 gimme;
c09156bb 2434 register PERL_CONTEXT *cx;
b0d9ce38 2435 SV *sv;
a0d0e21e 2436
9850bf21
RH		 2437 if (CxMULTICALL(&cxstack[cxstack_ix]))
2438 return 0;
2439
a0d0e21e 2440 POPBLOCK(cx,newpm);
5dd42e15 2441 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2442
a1f49e72 2443 TAINT_NOT;
a0d0e21e
LW		 2444 if (gimme == G_SCALAR) {
2445 MARK = newsp + 1;
a29cdaf0 2446 if (MARK <= SP) {
a8bba7fa 2447 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 2448 if (SvTEMP(TOPs)) {
2449 *MARK = SvREFCNT_inc(TOPs);
2450 FREETMPS;
2451 sv_2mortal(*MARK);
cd06dffe
GS		 2452 }
2453 else {
959e3673 2454 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2455 FREETMPS;
959e3673
GS		 2456 *MARK = sv_mortalcopy(sv);
2457 SvREFCNT_dec(sv);
a29cdaf0 2458 }
cd06dffe
GS		 2459 }
2460 else
a29cdaf0 2461 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
cd06dffe
GS		 2462 }
2463 else {
f86702cc 2464 MEXTEND(MARK, 0);
3280af22 2465 *MARK = &PL_sv_undef;
a0d0e21e
LW		 2466 }
2467 SP = MARK;
2468 }
54310121 2469 else if (gimme == G_ARRAY) {
f86702cc 2470 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2471 if (!SvTEMP(*MARK)) {
f86702cc 2472 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS		 2473 TAINT_NOT; /* Each item is independent */
2474 }
f86702cc 2475 }
a0d0e21e 2476 }
f86702cc 2477 PUTBACK;
1c846c1f 2478
5dd42e15
DM		 2479 LEAVE;
2480 cxstack_ix--;
b0d9ce38 2481 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2482 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2483
b0d9ce38 2484 LEAVESUB(sv);
f39bc417 2485 return cx->blk_sub.retop;
a0d0e21e
LW		 2486}
2487
cd06dffe
GS		 2488/* This duplicates the above code because the above code must not
2489 * get any slower by more conditions */
2490PP(pp_leavesublv)
2491{
27da23d5 2492 dVAR; dSP;
cd06dffe
GS		 2493 SV **mark;
2494 SV **newsp;
2495 PMOP *newpm;
2496 I32 gimme;
2497 register PERL_CONTEXT *cx;
b0d9ce38 2498 SV *sv;
cd06dffe 2499
9850bf21
RH		 2500 if (CxMULTICALL(&cxstack[cxstack_ix]))
2501 return 0;
2502
cd06dffe 2503 POPBLOCK(cx,newpm);
5dd42e15 2504 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2505
cd06dffe
GS		 2506 TAINT_NOT;
2507
cc8d50a7 2508 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
cd06dffe
GS		 2509 /* We are an argument to a function or grep().
2510 * This kind of lvalueness was legal before lvalue
2511 * subroutines too, so be backward compatible:
2512 * cannot report errors. */
2513
2514 /* Scalar context *is* possible, on the LHS of -> only,
2515 * as in f()->meth(). But this is not an lvalue. */
2516 if (gimme == G_SCALAR)
2517 goto temporise;
2518 if (gimme == G_ARRAY) {
a8bba7fa 2519 if (!CvLVALUE(cx->blk_sub.cv))
cd06dffe
GS		 2520 goto temporise_array;
2521 EXTEND_MORTAL(SP - newsp);
2522 for (mark = newsp + 1; mark <= SP; mark++) {
2523 if (SvTEMP(*mark))
6f207bd3 2524 NOOP;
cd06dffe
GS		 2525 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2526 *mark = sv_mortalcopy(*mark);
2527 else {
2528 /* Can be a localized value subject to deletion. */
2529 PL_tmps_stack[++PL_tmps_ix] = *mark;
b37c2d43 2530 SvREFCNT_inc_void(*mark);
cd06dffe
GS		 2531 }
2532 }
2533 }
2534 }
cc8d50a7 2535 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
cd06dffe
GS		 2536 /* Here we go for robustness, not for speed, so we change all
2537 * the refcounts so the caller gets a live guy. Cannot set
2538 * TEMP, so sv_2mortal is out of question. */
a8bba7fa 2539 if (!CvLVALUE(cx->blk_sub.cv)) {
5dd42e15
DM		 2540 LEAVE;
2541 cxstack_ix--;
b0d9ce38 2542 POPSUB(cx,sv);
d470f89e 2543 PL_curpm = newpm;
b0d9ce38 2544 LEAVESUB(sv);
d470f89e
GS		 2545 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2546 }
cd06dffe
GS		 2547 if (gimme == G_SCALAR) {
2548 MARK = newsp + 1;
2549 EXTEND_MORTAL(1);
2550 if (MARK == SP) {
f9bc45ef
TP		 2551 /* Temporaries are bad unless they happen to be elements
2552 * of a tied hash or array */
2553 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2554 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
5dd42e15
DM		 2555 LEAVE;
2556 cxstack_ix--;
b0d9ce38 2557 POPSUB(cx,sv);
d470f89e 2558 PL_curpm = newpm;
b0d9ce38 2559 LEAVESUB(sv);
e9f19e3c
HS		 2560 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2561 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2562 : "a readonly value" : "a temporary");
d470f89e 2563 }
cd06dffe
GS		 2564 else { /* Can be a localized value
2565 * subject to deletion. */
2566 PL_tmps_stack[++PL_tmps_ix] = *mark;
b37c2d43 2567 SvREFCNT_inc_void(*mark);
cd06dffe
GS		 2568 }
2569 }
d470f89e 2570 else { /* Should not happen? */
5dd42e15
DM		 2571 LEAVE;
2572 cxstack_ix--;
b0d9ce38 2573 POPSUB(cx,sv);
d470f89e 2574 PL_curpm = newpm;
b0d9ce38 2575 LEAVESUB(sv);
d470f89e 2576 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
cd06dffe 2577 (MARK > SP ? "Empty array" : "Array"));
d470f89e 2578 }
cd06dffe
GS		 2579 SP = MARK;
2580 }
2581 else if (gimme == G_ARRAY) {
2582 EXTEND_MORTAL(SP - newsp);
2583 for (mark = newsp + 1; mark <= SP; mark++) {
f206cdda
AMS		 2584 if (*mark != &PL_sv_undef
2585 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
d470f89e
GS		 2586 /* Might be flattened array after $#array = */
2587 PUTBACK;
5dd42e15
DM		 2588 LEAVE;
2589 cxstack_ix--;
b0d9ce38 2590 POPSUB(cx,sv);
d470f89e 2591 PL_curpm = newpm;
b0d9ce38 2592 LEAVESUB(sv);
f206cdda
AMS		 2593 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2594 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2595 }
cd06dffe 2596 else {
cd06dffe
GS		 2597 /* Can be a localized value subject to deletion. */
2598 PL_tmps_stack[++PL_tmps_ix] = *mark;
b37c2d43 2599 SvREFCNT_inc_void(*mark);
cd06dffe
GS		 2600 }
2601 }
2602 }
2603 }
2604 else {
2605 if (gimme == G_SCALAR) {
2606 temporise:
2607 MARK = newsp + 1;
2608 if (MARK <= SP) {
a8bba7fa 2609 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
cd06dffe
GS		 2610 if (SvTEMP(TOPs)) {
2611 *MARK = SvREFCNT_inc(TOPs);
2612 FREETMPS;
2613 sv_2mortal(*MARK);
2614 }
2615 else {
959e3673 2616 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
cd06dffe 2617 FREETMPS;
959e3673
GS		 2618 *MARK = sv_mortalcopy(sv);
2619 SvREFCNT_dec(sv);
cd06dffe
GS		 2620 }
2621 }
2622 else
2623 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2624 }
2625 else {
2626 MEXTEND(MARK, 0);
2627 *MARK = &PL_sv_undef;
2628 }
2629 SP = MARK;
2630 }
2631 else if (gimme == G_ARRAY) {
2632 temporise_array:
2633 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2634 if (!SvTEMP(*MARK)) {
2635 *MARK = sv_mortalcopy(*MARK);
2636 TAINT_NOT; /* Each item is independent */
2637 }
2638 }
2639 }
2640 }
2641 PUTBACK;
1c846c1f 2642
5dd42e15
DM		 2643 LEAVE;
2644 cxstack_ix--;
b0d9ce38 2645 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cd06dffe
GS		 2646 PL_curpm = newpm; /* ... and pop $1 et al */
2647
b0d9ce38 2648 LEAVESUB(sv);
f39bc417 2649 return cx->blk_sub.retop;
cd06dffe
GS		 2650}
2651
a0d0e21e
LW		 2652PP(pp_entersub)
2653{
27da23d5 2654 dVAR; dSP; dPOPss;
a0d0e21e 2655 GV *gv;
a0d0e21e 2656 register CV *cv;
c09156bb 2657 register PERL_CONTEXT *cx;
5d94fbed 2658 I32 gimme;
a9c4fd4e 2659 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW		 2660
2661 if (!sv)
cea2e8a9 2662 DIE(aTHX_ "Not a CODE reference");
a0d0e21e 2663 switch (SvTYPE(sv)) {
f1025168
NC		 2664 /* This is overwhelming the most common case: */
2665 case SVt_PVGV:
f730a42d
NC		 2666 if (!(cv = GvCVu((GV*)sv))) {
2667 HV *stash;
f2c0649b 2668 cv = sv_2cv(sv, &stash, &gv, 0);
f730a42d 2669 }
f1025168
NC		 2670 if (!cv) {
2671 ENTER;
2672 SAVETMPS;
2673 goto try_autoload;
2674 }
2675 break;
a0d0e21e
LW		 2676 default:
2677 if (!SvROK(sv)) {
a9c4fd4e 2678 const char *sym;
780a5241 2679 STRLEN len;
3280af22 2680 if (sv == &PL_sv_yes) { /* unfound import, ignore */
fb73857a 2681 if (hasargs)
3280af22 2682 SP = PL_stack_base + POPMARK;
a0d0e21e 2683 RETURN;
fb73857a 2684 }
15ff848f
CS		 2685 if (SvGMAGICAL(sv)) {
2686 mg_get(sv);
f5f1d18e
AMS		 2687 if (SvROK(sv))
2688 goto got_rv;
780a5241
NC		 2689 if (SvPOKp(sv)) {
2690 sym = SvPVX_const(sv);
2691 len = SvCUR(sv);
2692 } else {
2693 sym = NULL;
2694 len = 0;
2695 }
15ff848f 2696 }
a9c4fd4e 2697 else {
780a5241 2698 sym = SvPV_const(sv, len);
a9c4fd4e 2699 }
15ff848f 2700 if (!sym)
cea2e8a9 2701 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2702 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 2703 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
780a5241 2704 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
a0d0e21e
LW		 2705 break;
2706 }
f5f1d18e 2707 got_rv:
f5284f61 2708 {
823a54a3 2709 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
f5284f61
IZ		 2710 tryAMAGICunDEREF(to_cv);
2711 }
a0d0e21e
LW		 2712 cv = (CV*)SvRV(sv);
2713 if (SvTYPE(cv) == SVt_PVCV)
2714 break;
2715 /* FALL THROUGH */
2716 case SVt_PVHV:
2717 case SVt_PVAV:
cea2e8a9 2718 DIE(aTHX_ "Not a CODE reference");
f1025168 2719 /* This is the second most common case: */
a0d0e21e
LW		 2720 case SVt_PVCV:
2721 cv = (CV*)sv;
2722 break;
a0d0e21e
LW		 2723 }
2724
2725 ENTER;
2726 SAVETMPS;
2727
2728 retry:
a0d0e21e 2729 if (!CvROOT(cv) && !CvXSUB(cv)) {
2f349aa0
NC		 2730 GV* autogv;
2731 SV* sub_name;
2732
2733 /* anonymous or undef'd function leaves us no recourse */
2734 if (CvANON(cv) || !(gv = CvGV(cv)))
2735 DIE(aTHX_ "Undefined subroutine called");
2736
2737 /* autoloaded stub? */
2738 if (cv != GvCV(gv)) {
2739 cv = GvCV(gv);
2740 }
2741 /* should call AUTOLOAD now? */
2742 else {
2743try_autoload:
2744 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2745 FALSE)))
2746 {
2747 cv = GvCV(autogv);
2748 }
2749 /* sorry */
2750 else {
2751 sub_name = sv_newmortal();
6136c704 2752 gv_efullname3(sub_name, gv, NULL);
be2597df 2753 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2f349aa0
NC		 2754 }
2755 }
2756 if (!cv)
2757 DIE(aTHX_ "Not a CODE reference");
2758 goto retry;
a0d0e21e
LW		 2759 }
2760
54310121 2761 gimme = GIMME_V;
67caa1fe 2762 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
005a8a35 2763 Perl_get_db_sub(aTHX_ &sv, cv);
a9ef256d
NC		 2764 if (CvISXSUB(cv))
2765 PL_curcopdb = PL_curcop;
2766 cv = GvCV(PL_DBsub);
2767
ccafdc96
RGS		 2768 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2769 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2770 }
a0d0e21e 2771
aed2304a 2772 if (!(CvISXSUB(cv))) {
f1025168 2773 /* This path taken at least 75% of the time */
a0d0e21e
LW		 2774 dMARK;
2775 register I32 items = SP - MARK;
0bcc34c2 2776 AV* const padlist = CvPADLIST(cv);
a0d0e21e
LW		 2777 PUSHBLOCK(cx, CXt_SUB, MARK);
2778 PUSHSUB(cx);
f39bc417 2779 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 2780 CvDEPTH(cv)++;
6b35e009
GS		 2781 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2782 * that eval'' ops within this sub know the correct lexical space.
a3985cdc
DM		 2783 * Owing the speed considerations, we choose instead to search for
2784 * the cv using find_runcv() when calling doeval().
6b35e009 2785 */
3a76ca88
RGS		 2786 if (CvDEPTH(cv) >= 2) {
2787 PERL_STACK_OVERFLOW_CHECK();
2788 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2789 }
3a76ca88
RGS		 2790 SAVECOMPPAD();
2791 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2792 if (hasargs) {
0bcc34c2 2793 AV* const av = (AV*)PAD_SVl(0);
221373f0
GS		 2794 if (AvREAL(av)) {
2795 /* @_ is normally not REAL--this should only ever
2796 * happen when DB::sub() calls things that modify @_ */
2797 av_clear(av);
2798 AvREAL_off(av);
2799 AvREIFY_on(av);
2800 }
3280af22 2801 cx->blk_sub.savearray = GvAV(PL_defgv);
b37c2d43 2802 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
dd2155a4 2803 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2804 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2805 ++MARK;
2806
2807 if (items > AvMAX(av) + 1) {
504618e9 2808 SV **ary = AvALLOC(av);
a0d0e21e
LW		 2809 if (AvARRAY(av) != ary) {
2810 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 2811 AvARRAY(av) = ary;
a0d0e21e
LW		 2812 }
2813 if (items > AvMAX(av) + 1) {
2814 AvMAX(av) = items - 1;
2815 Renew(ary,items,SV*);
2816 AvALLOC(av) = ary;
9c6bc640 2817 AvARRAY(av) = ary;
a0d0e21e
LW		 2818 }
2819 }
2820 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2821 AvFILLp(av) = items - 1;
1c846c1f 2822
a0d0e21e
LW		 2823 while (items--) {
2824 if (*MARK)
2825 SvTEMP_off(*MARK);
2826 MARK++;
2827 }
2828 }
4a925ff6
GS		 2829 /* warning must come *after* we fully set up the context
2830 * stuff so that __WARN__ handlers can safely dounwind()
2831 * if they want to
2832 */
ccb2c8b8 2833 if (CvDEPTH(cv) == PERL_MAX_SUB_DEPTH && ckWARN(WARN_RECURSION)
4a925ff6
GS		 2834 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2835 sub_crush_depth(cv);
77a005ab 2836#if 0
bf49b057 2837 DEBUG_S(PerlIO_printf(Perl_debug_log,
6c9570dc 2838 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
77a005ab 2839#endif
a0d0e21e
LW		 2840 RETURNOP(CvSTART(cv));
2841 }
f1025168 2842 else {
3a76ca88 2843 I32 markix = TOPMARK;
f1025168 2844
3a76ca88 2845 PUTBACK;
f1025168 2846
3a76ca88
RGS		 2847 if (!hasargs) {
2848 /* Need to copy @_ to stack. Alternative may be to
2849 * switch stack to @_, and copy return values
2850 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2851 AV * const av = GvAV(PL_defgv);
2852 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2853
2854 if (items) {
2855 /* Mark is at the end of the stack. */
2856 EXTEND(SP, items);
2857 Copy(AvARRAY(av), SP + 1, items, SV*);
2858 SP += items;
2859 PUTBACK ;
2860 }
2861 }
2862 /* We assume first XSUB in &DB::sub is the called one. */
2863 if (PL_curcopdb) {
2864 SAVEVPTR(PL_curcop);
2865 PL_curcop = PL_curcopdb;
2866 PL_curcopdb = NULL;
2867 }
2868 /* Do we need to open block here? XXXX */
2869 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2870 (void)(*CvXSUB(cv))(aTHX_ cv);
2871
2872 /* Enforce some sanity in scalar context. */
2873 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2874 if (markix > PL_stack_sp - PL_stack_base)
2875 *(PL_stack_base + markix) = &PL_sv_undef;
2876 else
2877 *(PL_stack_base + markix) = *PL_stack_sp;
2878 PL_stack_sp = PL_stack_base + markix;
2879 }
f1025168
NC		 2880 LEAVE;
2881 return NORMAL;
2882 }
a0d0e21e
LW		 2883}
2884
44a8e56a 2885void
864dbfa3 2886Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 2887{
2888 if (CvANON(cv))
9014280d 2889 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 2890 else {
aec46f14 2891 SV* const tmpstr = sv_newmortal();
6136c704 2892 gv_efullname3(tmpstr, CvGV(cv), NULL);
35c1215d 2893 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
be2597df 2894 SVfARG(tmpstr));
44a8e56a 2895 }
2896}
2897
a0d0e21e
LW		 2898PP(pp_aelem)
2899{
97aff369 2900 dVAR; dSP;
a0d0e21e 2901 SV** svp;
a3b680e6 2902 SV* const elemsv = POPs;
d804643f 2903 IV elem = SvIV(elemsv);
0bcc34c2 2904 AV* const av = (AV*)POPs;
e1ec3a88
AL		 2905 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2906 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
be6c24e0 2907 SV *sv;
a0d0e21e 2908
e35c1634 2909 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
95b63a38
JH		 2910 Perl_warner(aTHX_ packWARN(WARN_MISC),
2911 "Use of reference \"%"SVf"\" as array index",
be2597df 2912 SVfARG(elemsv));
748a9306 2913 if (elem > 0)
fc15ae8f 2914 elem -= CopARYBASE_get(PL_curcop);
a0d0e21e
LW		 2915 if (SvTYPE(av) != SVt_PVAV)
2916 RETPUSHUNDEF;
68dc0745 2917 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2918 if (lval) {
2b573ace 2919#ifdef PERL_MALLOC_WRAP
2b573ace 2920 if (SvUOK(elemsv)) {
a9c4fd4e 2921 const UV uv = SvUV(elemsv);
2b573ace
JH		 2922 elem = uv > IV_MAX ? IV_MAX : uv;
2923 }
2924 else if (SvNOK(elemsv))
2925 elem = (IV)SvNV(elemsv);
a3b680e6
AL		 2926 if (elem > 0) {
2927 static const char oom_array_extend[] =
2928 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 2929 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 2930 }
2b573ace 2931#endif
3280af22 2932 if (!svp || *svp == &PL_sv_undef) {
68dc0745 2933 SV* lv;
2934 if (!defer)
cea2e8a9 2935 DIE(aTHX_ PL_no_aelem, elem);
68dc0745 2936 lv = sv_newmortal();
2937 sv_upgrade(lv, SVt_PVLV);
2938 LvTYPE(lv) = 'y';
a0714e2c 2939 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
b37c2d43 2940 LvTARG(lv) = SvREFCNT_inc_simple(av);
68dc0745 2941 LvTARGOFF(lv) = elem;
2942 LvTARGLEN(lv) = 1;
2943 PUSHs(lv);
2944 RETURN;
2945 }
bfc4de9f 2946 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2947 save_aelem(av, elem, svp);
533c011a
NIS		 2948 else if (PL_op->op_private & OPpDEREF)
2949 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 2950 }
3280af22 2951 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS		 2952 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2953 sv = sv_mortalcopy(sv);
2954 PUSHs(sv);
a0d0e21e
LW		 2955 RETURN;
2956}
2957
02a9e968 2958void
864dbfa3 2959Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 2960{
5b295bef 2961 SvGETMAGIC(sv);
02a9e968
CS		 2962 if (!SvOK(sv)) {
2963 if (SvREADONLY(sv))
cea2e8a9 2964 Perl_croak(aTHX_ PL_no_modify);
43230e26 2965 prepare_SV_for_RV(sv);
68dc0745 2966 switch (to_what) {
5f05dabc 2967 case OPpDEREF_SV:
561b68a9 2968 SvRV_set(sv, newSV(0));
5f05dabc 2969 break;
2970 case OPpDEREF_AV:
b162af07 2971 SvRV_set(sv, (SV*)newAV());
5f05dabc 2972 break;
2973 case OPpDEREF_HV:
b162af07 2974 SvRV_set(sv, (SV*)newHV());
5f05dabc 2975 break;
2976 }
02a9e968
CS		 2977 SvROK_on(sv);
2978 SvSETMAGIC(sv);
2979 }
2980}
2981
a0d0e21e
LW		 2982PP(pp_method)
2983{
97aff369 2984 dVAR; dSP;
890ce7af 2985 SV* const sv = TOPs;
f5d5a27c
CS		 2986
2987 if (SvROK(sv)) {
890ce7af 2988 SV* const rsv = SvRV(sv);
f5d5a27c
CS		 2989 if (SvTYPE(rsv) == SVt_PVCV) {
2990 SETs(rsv);
2991 RETURN;
2992 }
2993 }
2994
4608196e 2995 SETs(method_common(sv, NULL));
f5d5a27c
CS		 2996 RETURN;
2997}
2998
2999PP(pp_method_named)
3000{
97aff369 3001 dVAR; dSP;
890ce7af 3002 SV* const sv = cSVOP_sv;
c158a4fd 3003 U32 hash = SvSHARED_HASH(sv);
f5d5a27c
CS		 3004
3005 XPUSHs(method_common(sv, &hash));
3006 RETURN;
3007}
3008
3009STATIC SV *
3010S_method_common(pTHX_ SV* meth, U32* hashp)
3011{
97aff369 3012 dVAR;
a0d0e21e
LW		 3013 SV* ob;
3014 GV* gv;
56304f61 3015 HV* stash;
f5d5a27c 3016 STRLEN namelen;
6136c704 3017 const char* packname = NULL;
a0714e2c 3018 SV *packsv = NULL;
ac91690f 3019 STRLEN packlen;
46c461b5
AL		 3020 const char * const name = SvPV_const(meth, namelen);
3021 SV * const sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 3022
4f1b7578
SC		 3023 if (!sv)
3024 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3025
5b295bef 3026 SvGETMAGIC(sv);
a0d0e21e 3027 if (SvROK(sv))
16d20bd9 3028 ob = (SV*)SvRV(sv);
a0d0e21e
LW		 3029 else {
3030 GV* iogv;
a0d0e21e 3031
af09ea45 3032 /* this isn't a reference */
5c144d81 3033 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
b464bac0 3034 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
081fc587 3035 if (he) {
5e6396ae 3036 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
081fc587
AB		 3037 goto fetch;
3038 }
3039 }
3040
a0d0e21e 3041 if (!SvOK(sv) ||
05f5af9a 3042 !(packname) ||
f776e3cd 3043 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
a0d0e21e
LW		 3044 !(ob=(SV*)GvIO(iogv)))
3045 {
af09ea45 3046 /* this isn't the name of a filehandle either */
1c846c1f 3047 if (!packname ||
fd400ab9 3048 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 3049 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd
LW		 3050 : !isIDFIRST(*packname)
3051 ))
3052 {
f5d5a27c
CS		 3053 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3054 SvOK(sv) ? "without a package or object reference"
3055 : "on an undefined value");
834a4ddd 3056 }
af09ea45 3057 /* assume it's a package name */
da51bb9b 3058 stash = gv_stashpvn(packname, packlen, 0);
0dae17bd
GS		 3059 if (!stash)
3060 packsv = sv;
081fc587 3061 else {
d4c19fe8 3062 SV* const ref = newSViv(PTR2IV(stash));
04fe65b0 3063 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
7e8961ec 3064 }
ac91690f 3065 goto fetch;
a0d0e21e 3066 }
af09ea45 3067 /* it _is_ a filehandle name -- replace with a reference */
3280af22 3068 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
a0d0e21e
LW		 3069 }
3070
af09ea45 3071 /* if we got here, ob should be a reference or a glob */
f0d43078
GS		 3072 if (!ob || !(SvOBJECT(ob)
3073 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3074 && SvOBJECT(ob))))
3075 {
f5d5a27c 3076 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
59e7186f 3077 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
f5d5a27c 3078 name);
f0d43078 3079 }
a0d0e21e 3080
56304f61 3081 stash = SvSTASH(ob);
a0d0e21e 3082
ac91690f 3083 fetch:
af09ea45
IK		 3084 /* NOTE: stash may be null, hope hv_fetch_ent and
3085 gv_fetchmethod can cope (it seems they can) */
3086
f5d5a27c
CS		 3087 /* shortcut for simple names */
3088 if (hashp) {
b464bac0 3089 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
f5d5a27c
CS		 3090 if (he) {
3091 gv = (GV*)HeVAL(he);
3092 if (isGV(gv) && GvCV(gv) &&
e1a479c5 3093 (!GvCVGEN(gv) || GvCVGEN(gv)
dd69841b 3094 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
f5d5a27c
CS		 3095 return (SV*)GvCV(gv);
3096 }
3097 }
3098
0dae17bd 3099 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
af09ea45 3100
56304f61 3101 if (!gv) {
af09ea45
IK		 3102 /* This code tries to figure out just what went wrong with
3103 gv_fetchmethod. It therefore needs to duplicate a lot of
3104 the internals of that function. We can't move it inside
3105 Perl_gv_fetchmethod_autoload(), however, since that would
3106 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3107 don't want that.
3108 */
a9c4fd4e 3109 const char* leaf = name;
6136c704 3110 const char* sep = NULL;
a9c4fd4e 3111 const char* p;
56304f61
CS		 3112
3113 for (p = name; *p; p++) {
3114 if (*p == '\'')
3115 sep = p, leaf = p + 1;
3116 else if (*p == ':' && *(p + 1) == ':')
3117 sep = p, leaf = p + 2;
3118 }
3119 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
9b9d0b15 3120 /* the method name is unqualified or starts with SUPER:: */
8e3a4a30
NC		 3121#ifndef USE_ITHREADS
3122 if (sep)
3123 stash = CopSTASH(PL_curcop);
3124#else
9b9d0b15
NC		 3125 bool need_strlen = 1;
3126 if (sep) {
3127 packname = CopSTASHPV(PL_curcop);
3128 }
8e3a4a30
NC		 3129 else
3130#endif
3131 if (stash) {
46c461b5 3132 HEK * const packhek = HvNAME_HEK(stash);
9b9d0b15
NC		 3133 if (packhek) {
3134 packname = HEK_KEY(packhek);
3135 packlen = HEK_LEN(packhek);
8e3a4a30 3136#ifdef USE_ITHREADS
9b9d0b15 3137 need_strlen = 0;
8e3a4a30 3138#endif
9b9d0b15
NC		 3139 } else {
3140 goto croak;
3141 }
3142 }
3143
3144 if (!packname) {
3145 croak:
e27ad1f2
AV		 3146 Perl_croak(aTHX_
3147 "Can't use anonymous symbol table for method lookup");
9b9d0b15 3148 }
8e3a4a30
NC		 3149#ifdef USE_ITHREADS
3150 if (need_strlen)
e27ad1f2 3151 packlen = strlen(packname);
8e3a4a30 3152#endif
9b9d0b15 3153
56304f61
CS		 3154 }
3155 else {
af09ea45 3156 /* the method name is qualified */
56304f61
CS		 3157 packname = name;
3158 packlen = sep - name;
3159 }
af09ea45
IK		 3160
3161 /* we're relying on gv_fetchmethod not autovivifying the stash */
da51bb9b 3162 if (gv_stashpvn(packname, packlen, 0)) {
c1899e02 3163 Perl_croak(aTHX_
af09ea45
IK		 3164 "Can't locate object method \"%s\" via package \"%.*s\"",
3165 leaf, (int)packlen, packname);
c1899e02
GS		 3166 }
3167 else {
3168 Perl_croak(aTHX_
af09ea45
IK		 3169 "Can't locate object method \"%s\" via package \"%.*s\""
3170 " (perhaps you forgot to load \"%.*s\"?)",
3171 leaf, (int)packlen, packname, (int)packlen, packname);
c1899e02 3172 }
56304f61 3173 }
f5d5a27c 3174 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
a0d0e21e 3175}
241d1a3b
NC		 3176
3177/*
3178 * Local variables:
3179 * c-indentation-style: bsd
3180 * c-basic-offset: 4
3181 * indent-tabs-mode: t
3182 * End:
3183 *
37442d52
RGS		 3184 * ex: set ts=8 sts=4 sw=4 noet:
3185 */
Unnamed repository; edit this file 'description' to name the repository.