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