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