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