This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Added -x option to makerel to produce .xz tarballs
[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{
39644a26 42 dSP;
996c9baa 43 XPUSHs(cSVOP_sv);
a0d0e21e
LW
44 RETURN;
45}
46
47PP(pp_nextstate)
48{
533c011a 49 PL_curcop = (COP*)PL_op;
ff2a62e0 50 PL_sawalias = 0;
a0d0e21e 51 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 52 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 53 FREETMPS;
f410a211 54 PERL_ASYNC_CHECK();
a0d0e21e
LW
55 return NORMAL;
56}
57
58PP(pp_gvsv)
59{
39644a26 60 dSP;
924508f0 61 EXTEND(SP,1);
5d9574c1 62 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
1d7c1841 63 PUSHs(save_scalar(cGVOP_gv));
a0d0e21e 64 else
c69033f2 65 PUSHs(GvSVn(cGVOP_gv));
ff2a62e0
FC
66 if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))
67 PL_sawalias = TRUE;
a0d0e21e
LW
68 RETURN;
69}
70
b1c05ba5
DM
71
72/* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
73
a0d0e21e
LW
74PP(pp_null)
75{
76 return NORMAL;
77}
78
5d8673bc 79/* This is sometimes called directly by pp_coreargs and pp_grepstart. */
a0d0e21e
LW
80PP(pp_pushmark)
81{
3280af22 82 PUSHMARK(PL_stack_sp);
a0d0e21e
LW
83 return NORMAL;
84}
85
86PP(pp_stringify)
87{
20b7effb 88 dSP; dTARGET;
4cc783ef
DD
89 SV * const sv = TOPs;
90 SETs(TARG);
91 sv_copypv(TARG, sv);
92 SvSETMAGIC(TARG);
93 /* no PUTBACK, SETs doesn't inc/dec SP */
94 return NORMAL;
a0d0e21e
LW
95}
96
97PP(pp_gv)
98{
20b7effb 99 dSP;
ad64d0ec 100 XPUSHs(MUTABLE_SV(cGVOP_gv));
ff2a62e0
FC
101 if (isGV(cGVOP_gv)
102 && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
103 PL_sawalias = TRUE;
a0d0e21e
LW
104 RETURN;
105}
106
b1c05ba5
DM
107
108/* also used for: pp_andassign() */
109
a0d0e21e
LW
110PP(pp_and)
111{
f410a211 112 PERL_ASYNC_CHECK();
4cc783ef
DD
113 {
114 /* SP is not used to remove a variable that is saved across the
115 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
116 register or load/store vs direct mem ops macro is introduced, this
117 should be a define block between direct PL_stack_sp and dSP operations,
118 presently, using PL_stack_sp is bias towards CISC cpus */
119 SV * const sv = *PL_stack_sp;
120 if (!SvTRUE_NN(sv))
121 return NORMAL;
122 else {
123 if (PL_op->op_type == OP_AND)
124 --PL_stack_sp;
125 return cLOGOP->op_other;
126 }
a0d0e21e
LW
127 }
128}
129
130PP(pp_sassign)
131{
20b7effb 132 dSP;
3e75a3c4
RU
133 /* sassign keeps its args in the optree traditionally backwards.
134 So we pop them differently.
135 */
136 SV *left = POPs; SV *right = TOPs;
748a9306 137
533c011a 138 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
0bd48802
AL
139 SV * const temp = left;
140 left = right; right = temp;
a0d0e21e 141 }
5d9574c1 142 if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
a0d0e21e 143 TAINT_NOT;
5d9574c1
DM
144 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
145 /* *foo =\&bar */
3e75a3c4 146 SV * const cv = SvRV(right);
e26df76a 147 const U32 cv_type = SvTYPE(cv);
3e75a3c4 148 const bool is_gv = isGV_with_GP(left);
6136c704 149 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
e26df76a
NC
150
151 if (!got_coderef) {
152 assert(SvROK(cv));
153 }
154
3e75a3c4
RU
155 /* Can do the optimisation if left (LVALUE) is not a typeglob,
156 right (RVALUE) is a reference to something, and we're in void
e26df76a 157 context. */
13be902c 158 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
e26df76a 159 /* Is the target symbol table currently empty? */
3e75a3c4 160 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
bb112e5a 161 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
e26df76a
NC
162 /* Good. Create a new proxy constant subroutine in the target.
163 The gv becomes a(nother) reference to the constant. */
164 SV *const value = SvRV(cv);
165
ad64d0ec 166 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
1ccdb730 167 SvPCS_IMPORTED_on(gv);
e26df76a 168 SvRV_set(gv, value);
b37c2d43 169 SvREFCNT_inc_simple_void(value);
3e75a3c4 170 SETs(left);
e26df76a
NC
171 RETURN;
172 }
173 }
174
175 /* Need to fix things up. */
13be902c 176 if (!is_gv) {
e26df76a 177 /* Need to fix GV. */
3e75a3c4 178 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
e26df76a
NC
179 }
180
181 if (!got_coderef) {
182 /* We've been returned a constant rather than a full subroutine,
183 but they expect a subroutine reference to apply. */
53a42478 184 if (SvROK(cv)) {
d343c3ef 185 ENTER_with_name("sassign_coderef");
53a42478
NC
186 SvREFCNT_inc_void(SvRV(cv));
187 /* newCONSTSUB takes a reference count on the passed in SV
188 from us. We set the name to NULL, otherwise we get into
189 all sorts of fun as the reference to our new sub is
190 donated to the GV that we're about to assign to.
191 */
3e75a3c4 192 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
ad64d0ec 193 SvRV(cv))));
fc2b2dca 194 SvREFCNT_dec_NN(cv);
d343c3ef 195 LEAVE_with_name("sassign_coderef");
53a42478
NC
196 } else {
197 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
198 is that
199 First: ops for \&{"BONK"}; return us the constant in the
200 symbol table
201 Second: ops for *{"BONK"} cause that symbol table entry
202 (and our reference to it) to be upgraded from RV
203 to typeblob)
204 Thirdly: We get here. cv is actually PVGV now, and its
205 GvCV() is actually the subroutine we're looking for
206
207 So change the reference so that it points to the subroutine
208 of that typeglob, as that's what they were after all along.
209 */
159b6efe 210 GV *const upgraded = MUTABLE_GV(cv);
53a42478
NC
211 CV *const source = GvCV(upgraded);
212
213 assert(source);
214 assert(CvFLAGS(source) & CVf_CONST);
215
216 SvREFCNT_inc_void(source);
fc2b2dca 217 SvREFCNT_dec_NN(upgraded);
3e75a3c4 218 SvRV_set(right, MUTABLE_SV(source));
53a42478 219 }
e26df76a 220 }
53a42478 221
e26df76a 222 }
8fe85e3f 223 if (
5d9574c1 224 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
3e75a3c4 225 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
8fe85e3f
FC
226 )
227 Perl_warner(aTHX_
228 packWARN(WARN_MISC), "Useless assignment to a temporary"
229 );
3e75a3c4
RU
230 SvSetMagicSV(left, right);
231 SETs(left);
a0d0e21e
LW
232 RETURN;
233}
234
235PP(pp_cond_expr)
236{
20b7effb 237 dSP;
f410a211 238 PERL_ASYNC_CHECK();
a0d0e21e 239 if (SvTRUEx(POPs))
1a67a97c 240 RETURNOP(cLOGOP->op_other);
a0d0e21e 241 else
1a67a97c 242 RETURNOP(cLOGOP->op_next);
a0d0e21e
LW
243}
244
245PP(pp_unstack)
246{
8f3964af 247 PERL_ASYNC_CHECK();
a0d0e21e 248 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 249 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 250 FREETMPS;
eae48c89
Z
251 if (!(PL_op->op_flags & OPf_SPECIAL)) {
252 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
253 LEAVE_SCOPE(oldsave);
254 }
a0d0e21e
LW
255 return NORMAL;
256}
257
a0d0e21e
LW
258PP(pp_concat)
259{
20b7effb 260 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
748a9306
LW
261 {
262 dPOPTOPssrl;
8d6d96c1
HS
263 bool lbyte;
264 STRLEN rlen;
d4c19fe8 265 const char *rpv = NULL;
a6b599c7 266 bool rbyte = FALSE;
a9c4fd4e 267 bool rcopied = FALSE;
8d6d96c1 268
6f1401dc
DM
269 if (TARG == right && right != left) { /* $r = $l.$r */
270 rpv = SvPV_nomg_const(right, rlen);
c75ab21a 271 rbyte = !DO_UTF8(right);
59cd0e26 272 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
349d4f2f 273 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
db79b45b 274 rcopied = TRUE;
8d6d96c1 275 }
7889fe52 276
89734059 277 if (TARG != left) { /* not $l .= $r */
a9c4fd4e 278 STRLEN llen;
6f1401dc 279 const char* const lpv = SvPV_nomg_const(left, llen);
90f5826e 280 lbyte = !DO_UTF8(left);
8d6d96c1
HS
281 sv_setpvn(TARG, lpv, llen);
282 if (!lbyte)
283 SvUTF8_on(TARG);
284 else
285 SvUTF8_off(TARG);
286 }
18ea7bf2
SM
287 else { /* $l .= $r and left == TARG */
288 if (!SvOK(left)) {
89734059 289 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
c75ab21a 290 report_uninit(right);
76f68e9b 291 sv_setpvs(left, "");
c75ab21a 292 }
18ea7bf2
SM
293 else {
294 SvPV_force_nomg_nolen(left);
295 }
583a5589 296 lbyte = !DO_UTF8(left);
90f5826e 297 if (IN_BYTES)
18ea7bf2 298 SvUTF8_off(left);
8d6d96c1 299 }
a12c0f56 300
c75ab21a 301 if (!rcopied) {
6f1401dc 302 if (left == right)
89734059 303 /* $r.$r: do magic twice: tied might return different 2nd time */
6f1401dc
DM
304 SvGETMAGIC(right);
305 rpv = SvPV_nomg_const(right, rlen);
c75ab21a
RH
306 rbyte = !DO_UTF8(right);
307 }
8d6d96c1 308 if (lbyte != rbyte) {
e3393f51
NT
309 /* sv_utf8_upgrade_nomg() may reallocate the stack */
310 PUTBACK;
8d6d96c1
HS
311 if (lbyte)
312 sv_utf8_upgrade_nomg(TARG);
313 else {
db79b45b 314 if (!rcopied)
59cd0e26 315 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
8d6d96c1 316 sv_utf8_upgrade_nomg(right);
6f1401dc 317 rpv = SvPV_nomg_const(right, rlen);
69b47968 318 }
e3393f51 319 SPAGAIN;
a0d0e21e 320 }
8d6d96c1 321 sv_catpvn_nomg(TARG, rpv, rlen);
43ebc500 322
a0d0e21e
LW
323 SETTARG;
324 RETURN;
748a9306 325 }
a0d0e21e
LW
326}
327
d5524600
DM
328/* push the elements of av onto the stack.
329 * XXX Note that padav has similar code but without the mg_get().
330 * I suspect that the mg_get is no longer needed, but while padav
331 * differs, it can't share this function */
332
f9ae8fb6 333STATIC void
d5524600
DM
334S_pushav(pTHX_ AV* const av)
335{
336 dSP;
c70927a6 337 const SSize_t maxarg = AvFILL(av) + 1;
d5524600 338 EXTEND(SP, maxarg);
5d9574c1 339 if (UNLIKELY(SvRMAGICAL(av))) {
c70927a6
FC
340 PADOFFSET i;
341 for (i=0; i < (PADOFFSET)maxarg; i++) {
d5524600
DM
342 SV ** const svp = av_fetch(av, i, FALSE);
343 /* See note in pp_helem, and bug id #27839 */
344 SP[i+1] = svp
345 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
346 : &PL_sv_undef;
347 }
348 }
349 else {
c70927a6
FC
350 PADOFFSET i;
351 for (i=0; i < (PADOFFSET)maxarg; i++) {
ce0d59fd 352 SV * const sv = AvARRAY(av)[i];
5d9574c1 353 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
ce0d59fd 354 }
d5524600
DM
355 }
356 SP += maxarg;
357 PUTBACK;
358}
359
360
a7fd8ef6
DM
361/* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
362
363PP(pp_padrange)
364{
20b7effb 365 dSP;
a7fd8ef6
DM
366 PADOFFSET base = PL_op->op_targ;
367 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
368 int i;
d5524600
DM
369 if (PL_op->op_flags & OPf_SPECIAL) {
370 /* fake the RHS of my ($x,$y,..) = @_ */
371 PUSHMARK(SP);
372 S_pushav(aTHX_ GvAVn(PL_defgv));
373 SPAGAIN;
374 }
375
a7fd8ef6
DM
376 /* note, this is only skipped for compile-time-known void cxt */
377 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
378 EXTEND(SP, count);
379 PUSHMARK(SP);
380 for (i = 0; i <count; i++)
381 *++SP = PAD_SV(base+i);
382 }
383 if (PL_op->op_private & OPpLVAL_INTRO) {
4e09461c
DM
384 SV **svp = &(PAD_SVl(base));
385 const UV payload = (UV)(
386 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
387 | (count << SAVE_TIGHT_SHIFT)
388 | SAVEt_CLEARPADRANGE);
389 assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
390 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
a3444cc5
DM
391 {
392 dSS_ADD;
393 SS_ADD_UV(payload);
394 SS_ADD_END(1);
395 }
4e09461c 396
a7fd8ef6 397 for (i = 0; i <count; i++)
4e09461c 398 SvPADSTALE_off(*svp++); /* mark lexical as active */
a7fd8ef6
DM
399 }
400 RETURN;
401}
402
403
a0d0e21e
LW
404PP(pp_padsv)
405{
20b7effb 406 dSP;
6c28b496
DD
407 EXTEND(SP, 1);
408 {
409 OP * const op = PL_op;
410 /* access PL_curpad once */
411 SV ** const padentry = &(PAD_SVl(op->op_targ));
412 {
413 dTARG;
414 TARG = *padentry;
415 PUSHs(TARG);
416 PUTBACK; /* no pop/push after this, TOPs ok */
8ec5e241 417 }
6c28b496
DD
418 if (op->op_flags & OPf_MOD) {
419 if (op->op_private & OPpLVAL_INTRO)
420 if (!(op->op_private & OPpPAD_STATE))
421 save_clearsv(padentry);
422 if (op->op_private & OPpDEREF) {
8f90a16d
FC
423 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
424 than TARG reduces the scope of TARG, so it does not
425 span the call to save_clearsv, resulting in smaller
426 machine code. */
6c28b496
DD
427 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
428 }
429 }
430 return op->op_next;
4633a7c4 431 }
a0d0e21e
LW
432}
433
434PP(pp_readline)
435{
30901a8a
FC
436 dSP;
437 if (TOPs) {
438 SvGETMAGIC(TOPs);
fc99edcf 439 tryAMAGICunTARGETlist(iter_amg, 0);
30901a8a
FC
440 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
441 }
442 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
6e592b3a
BM
443 if (!isGV_with_GP(PL_last_in_gv)) {
444 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
159b6efe 445 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
8efb3254 446 else {
f5284f61 447 dSP;
ad64d0ec 448 XPUSHs(MUTABLE_SV(PL_last_in_gv));
f5284f61 449 PUTBACK;
897d3989 450 Perl_pp_rv2gv(aTHX);
159b6efe 451 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
f5284f61
IZ
452 }
453 }
a0d0e21e
LW
454 return do_readline();
455}
456
457PP(pp_eq)
458{
20b7effb 459 dSP;
33efebe6
DM
460 SV *left, *right;
461
a42d0242 462 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
463 right = POPs;
464 left = TOPs;
465 SETs(boolSV(
466 (SvIOK_notUV(left) && SvIOK_notUV(right))
467 ? (SvIVX(left) == SvIVX(right))
468 : ( do_ncmp(left, right) == 0)
469 ));
470 RETURN;
a0d0e21e
LW
471}
472
b1c05ba5
DM
473
474/* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
475
a0d0e21e
LW
476PP(pp_preinc)
477{
20b7effb 478 dSP;
17058fe0
FC
479 const bool inc =
480 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
5d9574c1 481 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
cb077ed2 482 Perl_croak_no_modify();
5d9574c1 483 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
17058fe0 484 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
55497cff 485 {
17058fe0 486 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
55497cff 487 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 488 }
28e5dec8 489 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
17058fe0
FC
490 if (inc) sv_inc(TOPs);
491 else sv_dec(TOPs);
a0d0e21e
LW
492 SvSETMAGIC(TOPs);
493 return NORMAL;
494}
495
b1c05ba5
DM
496
497/* also used for: pp_orassign() */
498
a0d0e21e
LW
499PP(pp_or)
500{
20b7effb 501 dSP;
f410a211 502 PERL_ASYNC_CHECK();
a0d0e21e
LW
503 if (SvTRUE(TOPs))
504 RETURN;
505 else {
c960fc3b
SP
506 if (PL_op->op_type == OP_OR)
507 --SP;
a0d0e21e
LW
508 RETURNOP(cLOGOP->op_other);
509 }
510}
511
b1c05ba5
DM
512
513/* also used for: pp_dor() pp_dorassign() */
514
25a55bd7 515PP(pp_defined)
c963b151 516{
20b7effb 517 dSP;
eb578fdb 518 SV* sv;
6136c704 519 bool defined;
25a55bd7 520 const int op_type = PL_op->op_type;
ea5195b7 521 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
c963b151 522
6136c704 523 if (is_dor) {
f410a211 524 PERL_ASYNC_CHECK();
25a55bd7 525 sv = TOPs;
5d9574c1 526 if (UNLIKELY(!sv || !SvANY(sv))) {
2bd49cfc
NC
527 if (op_type == OP_DOR)
528 --SP;
25a55bd7
SP
529 RETURNOP(cLOGOP->op_other);
530 }
b7c44293
RGS
531 }
532 else {
533 /* OP_DEFINED */
25a55bd7 534 sv = POPs;
5d9574c1 535 if (UNLIKELY(!sv || !SvANY(sv)))
25a55bd7 536 RETPUSHNO;
b7c44293 537 }
25a55bd7 538
6136c704 539 defined = FALSE;
c963b151
BD
540 switch (SvTYPE(sv)) {
541 case SVt_PVAV:
542 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 543 defined = TRUE;
c963b151
BD
544 break;
545 case SVt_PVHV:
546 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 547 defined = TRUE;
c963b151
BD
548 break;
549 case SVt_PVCV:
550 if (CvROOT(sv) || CvXSUB(sv))
25a55bd7 551 defined = TRUE;
c963b151
BD
552 break;
553 default:
5b295bef 554 SvGETMAGIC(sv);
c963b151 555 if (SvOK(sv))
25a55bd7 556 defined = TRUE;
6136c704 557 break;
c963b151 558 }
6136c704
AL
559
560 if (is_dor) {
c960fc3b
SP
561 if(defined)
562 RETURN;
563 if(op_type == OP_DOR)
564 --SP;
25a55bd7 565 RETURNOP(cLOGOP->op_other);
25a55bd7 566 }
d9aa96a4
SP
567 /* assuming OP_DEFINED */
568 if(defined)
569 RETPUSHYES;
570 RETPUSHNO;
c963b151
BD
571}
572
a0d0e21e
LW
573PP(pp_add)
574{
20b7effb 575 dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
576 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
577 svr = TOPs;
578 svl = TOPm1s;
579
800401ee 580 useleft = USE_LEFT(svl);
28e5dec8
JH
581#ifdef PERL_PRESERVE_IVUV
582 /* We must see if we can perform the addition with integers if possible,
583 as the integer code detects overflow while the NV code doesn't.
584 If either argument hasn't had a numeric conversion yet attempt to get
585 the IV. It's important to do this now, rather than just assuming that
586 it's not IOK as a PV of "9223372036854775806" may not take well to NV
587 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
588 integer in case the second argument is IV=9223372036854775806
589 We can (now) rely on sv_2iv to do the right thing, only setting the
590 public IOK flag if the value in the NV (or PV) slot is truly integer.
591
592 A side effect is that this also aggressively prefers integer maths over
7dca457a
NC
593 fp maths for integer values.
594
a00b5bd3 595 How to detect overflow?
7dca457a
NC
596
597 C 99 section 6.2.6.1 says
598
599 The range of nonnegative values of a signed integer type is a subrange
600 of the corresponding unsigned integer type, and the representation of
601 the same value in each type is the same. A computation involving
602 unsigned operands can never overflow, because a result that cannot be
603 represented by the resulting unsigned integer type is reduced modulo
604 the number that is one greater than the largest value that can be
605 represented by the resulting type.
606
607 (the 9th paragraph)
608
609 which I read as "unsigned ints wrap."
610
611 signed integer overflow seems to be classed as "exception condition"
612
613 If an exceptional condition occurs during the evaluation of an
614 expression (that is, if the result is not mathematically defined or not
615 in the range of representable values for its type), the behavior is
616 undefined.
617
618 (6.5, the 5th paragraph)
619
620 I had assumed that on 2s complement machines signed arithmetic would
621 wrap, hence coded pp_add and pp_subtract on the assumption that
622 everything perl builds on would be happy. After much wailing and
623 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
624 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
625 unsigned code below is actually shorter than the old code. :-)
626 */
627
01f91bf2 628 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
629 /* Unless the left argument is integer in range we are going to have to
630 use NV maths. Hence only attempt to coerce the right argument if
631 we know the left is integer. */
eb578fdb 632 UV auv = 0;
9c5ffd7c 633 bool auvok = FALSE;
7dca457a
NC
634 bool a_valid = 0;
635
28e5dec8 636 if (!useleft) {
7dca457a
NC
637 auv = 0;
638 a_valid = auvok = 1;
639 /* left operand is undef, treat as zero. + 0 is identity,
640 Could SETi or SETu right now, but space optimise by not adding
641 lots of code to speed up what is probably a rarish case. */
642 } else {
643 /* Left operand is defined, so is it IV? */
01f91bf2 644 if (SvIV_please_nomg(svl)) {
800401ee
JH
645 if ((auvok = SvUOK(svl)))
646 auv = SvUVX(svl);
7dca457a 647 else {
eb578fdb 648 const IV aiv = SvIVX(svl);
7dca457a
NC
649 if (aiv >= 0) {
650 auv = aiv;
651 auvok = 1; /* Now acting as a sign flag. */
652 } else { /* 2s complement assumption for IV_MIN */
653 auv = (UV)-aiv;
654 }
655 }
656 a_valid = 1;
28e5dec8
JH
657 }
658 }
7dca457a
NC
659 if (a_valid) {
660 bool result_good = 0;
661 UV result;
eb578fdb 662 UV buv;
800401ee 663 bool buvok = SvUOK(svr);
a00b5bd3 664
7dca457a 665 if (buvok)
800401ee 666 buv = SvUVX(svr);
7dca457a 667 else {
eb578fdb 668 const IV biv = SvIVX(svr);
7dca457a
NC
669 if (biv >= 0) {
670 buv = biv;
671 buvok = 1;
672 } else
673 buv = (UV)-biv;
674 }
675 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 676 else "IV" now, independent of how it came in.
7dca457a
NC
677 if a, b represents positive, A, B negative, a maps to -A etc
678 a + b => (a + b)
679 A + b => -(a - b)
680 a + B => (a - b)
681 A + B => -(a + b)
682 all UV maths. negate result if A negative.
683 add if signs same, subtract if signs differ. */
684
685 if (auvok ^ buvok) {
686 /* Signs differ. */
687 if (auv >= buv) {
688 result = auv - buv;
689 /* Must get smaller */
690 if (result <= auv)
691 result_good = 1;
692 } else {
693 result = buv - auv;
694 if (result <= buv) {
695 /* result really should be -(auv-buv). as its negation
696 of true value, need to swap our result flag */
697 auvok = !auvok;
698 result_good = 1;
28e5dec8
JH
699 }
700 }
7dca457a
NC
701 } else {
702 /* Signs same */
703 result = auv + buv;
704 if (result >= auv)
705 result_good = 1;
706 }
707 if (result_good) {
708 SP--;
709 if (auvok)
28e5dec8 710 SETu( result );
7dca457a
NC
711 else {
712 /* Negate result */
713 if (result <= (UV)IV_MIN)
714 SETi( -(IV)result );
715 else {
716 /* result valid, but out of range for IV. */
717 SETn( -(NV)result );
28e5dec8
JH
718 }
719 }
7dca457a
NC
720 RETURN;
721 } /* Overflow, drop through to NVs. */
28e5dec8
JH
722 }
723 }
724#endif
a0d0e21e 725 {
6f1401dc 726 NV value = SvNV_nomg(svr);
4efa5a16 727 (void)POPs;
28e5dec8
JH
728 if (!useleft) {
729 /* left operand is undef, treat as zero. + 0.0 is identity. */
730 SETn(value);
731 RETURN;
732 }
6f1401dc 733 SETn( value + SvNV_nomg(svl) );
28e5dec8 734 RETURN;
a0d0e21e
LW
735 }
736}
737
b1c05ba5
DM
738
739/* also used for: pp_aelemfast_lex() */
740
a0d0e21e
LW
741PP(pp_aelemfast)
742{
20b7effb 743 dSP;
93bad3fd 744 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
8f878375 745 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
a3b680e6 746 const U32 lval = PL_op->op_flags & OPf_MOD;
b024352e 747 SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
3280af22 748 SV *sv = (svp ? *svp : &PL_sv_undef);
b024352e
DM
749
750 if (UNLIKELY(!svp && lval))
751 DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
752
6ff81951 753 EXTEND(SP, 1);
39cf747a 754 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 755 mg_get(sv);
be6c24e0 756 PUSHs(sv);
a0d0e21e
LW
757 RETURN;
758}
759
760PP(pp_join)
761{
20b7effb 762 dSP; dMARK; dTARGET;
a0d0e21e
LW
763 MARK++;
764 do_join(TARG, *MARK, MARK, SP);
765 SP = MARK;
766 SETs(TARG);
767 RETURN;
768}
769
770PP(pp_pushre)
771{
20b7effb 772 dSP;
44a8e56a
PP
773#ifdef DEBUGGING
774 /*
775 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
776 * will be enough to hold an OP*.
777 */
c4420975 778 SV* const sv = sv_newmortal();
44a8e56a
PP
779 sv_upgrade(sv, SVt_PVLV);
780 LvTYPE(sv) = '/';
533c011a 781 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
44a8e56a
PP
782 XPUSHs(sv);
783#else
ad64d0ec 784 XPUSHs(MUTABLE_SV(PL_op));
44a8e56a 785#endif
a0d0e21e
LW
786 RETURN;
787}
788
789/* Oversized hot code. */
790
b1c05ba5
DM
791/* also used for: pp_say() */
792
a0d0e21e
LW
793PP(pp_print)
794{
20b7effb 795 dSP; dMARK; dORIGMARK;
eb578fdb 796 PerlIO *fp;
236988e4 797 MAGIC *mg;
159b6efe
NC
798 GV * const gv
799 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 800 IO *io = GvIO(gv);
5b468f54 801
9c9f25b8 802 if (io
ad64d0ec 803 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 804 {
01bb7c6d 805 had_magic:
68dc0745 806 if (MARK == ORIGMARK) {
1c846c1f 807 /* If using default handle then we need to make space to
a60c0954
NIS
808 * pass object as 1st arg, so move other args up ...
809 */
4352c267 810 MEXTEND(SP, 1);
68dc0745
PP
811 ++MARK;
812 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
813 ++SP;
814 }
3e0cb5de 815 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
94bc412f
NC
816 mg,
817 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
818 | (PL_op->op_type == OP_SAY
819 ? TIED_METHOD_SAY : 0)), sp - mark);
236988e4 820 }
9c9f25b8 821 if (!io) {
68b590d9 822 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
ad64d0ec 823 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 824 goto had_magic;
51087808 825 report_evil_fh(gv);
93189314 826 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
827 goto just_say_no;
828 }
829 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
830 if (IoIFP(io))
831 report_wrongway_fh(gv, '<');
51087808 832 else
7716c5c5 833 report_evil_fh(gv);
93189314 834 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
835 goto just_say_no;
836 }
837 else {
e23d9e2f 838 SV * const ofs = GvSV(PL_ofsgv); /* $, */
a0d0e21e 839 MARK++;
e23d9e2f 840 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
a0d0e21e
LW
841 while (MARK <= SP) {
842 if (!do_print(*MARK, fp))
843 break;
844 MARK++;
845 if (MARK <= SP) {
e23d9e2f
CS
846 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
847 if (!do_print(GvSV(PL_ofsgv), fp)) {
a0d0e21e
LW
848 MARK--;
849 break;
850 }
851 }
852 }
853 }
854 else {
855 while (MARK <= SP) {
856 if (!do_print(*MARK, fp))
857 break;
858 MARK++;
859 }
860 }
861 if (MARK <= SP)
862 goto just_say_no;
863 else {
cfc4a7da
GA
864 if (PL_op->op_type == OP_SAY) {
865 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
866 goto just_say_no;
867 }
868 else if (PL_ors_sv && SvOK(PL_ors_sv))
7889fe52 869 if (!do_print(PL_ors_sv, fp)) /* $\ */
a0d0e21e
LW
870 goto just_say_no;
871
872 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 873 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
874 goto just_say_no;
875 }
876 }
877 SP = ORIGMARK;
e52fd6f4 878 XPUSHs(&PL_sv_yes);
a0d0e21e
LW
879 RETURN;
880
881 just_say_no:
882 SP = ORIGMARK;
e52fd6f4 883 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
884 RETURN;
885}
886
b1c05ba5
DM
887
888/* also used for: pp_rv2hv() */
889
a0d0e21e
LW
890PP(pp_rv2av)
891{
20b7effb 892 dSP; dTOPss;
cde874ca 893 const I32 gimme = GIMME_V;
17ab7946
NC
894 static const char an_array[] = "an ARRAY";
895 static const char a_hash[] = "a HASH";
896 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
d83b45b8 897 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 898
9026059d 899 SvGETMAGIC(sv);
a0d0e21e 900 if (SvROK(sv)) {
5d9574c1 901 if (UNLIKELY(SvAMAGIC(sv))) {
93d7320b 902 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
93d7320b 903 }
17ab7946 904 sv = SvRV(sv);
5d9574c1 905 if (UNLIKELY(SvTYPE(sv) != type))
dcbac5bb 906 /* diag_listed_as: Not an ARRAY reference */
17ab7946 907 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
5d9574c1
DM
908 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
909 && PL_op->op_private & OPpLVAL_INTRO))
3da99855 910 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e 911 }
5d9574c1 912 else if (UNLIKELY(SvTYPE(sv) != type)) {
67955e0c 913 GV *gv;
1c846c1f 914
6e592b3a 915 if (!isGV_with_GP(sv)) {
dc3c76f8
NC
916 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
917 type, &sp);
918 if (!gv)
919 RETURN;
35cd451c
GS
920 }
921 else {
159b6efe 922 gv = MUTABLE_GV(sv);
a0d0e21e 923 }
ad64d0ec 924 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 925 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 926 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
9f527363
FC
927 }
928 if (PL_op->op_flags & OPf_REF) {
17ab7946 929 SETs(sv);
a0d0e21e 930 RETURN;
9f527363 931 }
5d9574c1 932 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
40c94d11
FC
933 const I32 flags = is_lvalue_sub();
934 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 935 if (gimme != G_ARRAY)
042560a6 936 goto croak_cant_return;
17ab7946 937 SETs(sv);
78f9721b 938 RETURN;
40c94d11 939 }
a0d0e21e
LW
940 }
941
17ab7946 942 if (is_pp_rv2av) {
502c6561 943 AV *const av = MUTABLE_AV(sv);
486ec47a 944 /* The guts of pp_rv2av, with no intending change to preserve history
17ab7946
NC
945 (until such time as we get tools that can do blame annotation across
946 whitespace changes. */
96913b52 947 if (gimme == G_ARRAY) {
d5524600
DM
948 SP--;
949 PUTBACK;
950 S_pushav(aTHX_ av);
951 SPAGAIN;
1c846c1f 952 }
96913b52
VP
953 else if (gimme == G_SCALAR) {
954 dTARGET;
c70927a6 955 const SSize_t maxarg = AvFILL(av) + 1;
96913b52 956 SETi(maxarg);
93965878 957 }
17ab7946
NC
958 } else {
959 /* The guts of pp_rv2hv */
96913b52
VP
960 if (gimme == G_ARRAY) { /* array wanted */
961 *PL_stack_sp = sv;
981b7185 962 return Perl_do_kv(aTHX);
96913b52 963 }
c8fe3bdf 964 else if ((PL_op->op_private & OPpTRUEBOOL
adc42c31 965 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
c8fe3bdf
FC
966 && block_gimme() == G_VOID ))
967 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
968 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
96913b52 969 else if (gimme == G_SCALAR) {
1a8bdda9 970 dTARG;
96913b52 971 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
96913b52
VP
972 SETTARG;
973 }
17ab7946 974 }
be85d344 975 RETURN;
042560a6
NC
976
977 croak_cant_return:
978 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
979 is_pp_rv2av ? "array" : "hash");
77e217c6 980 RETURN;
a0d0e21e
LW
981}
982
10c8fecd 983STATIC void
fb8f4cf8 984S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
10c8fecd 985{
7918f24d
NC
986 PERL_ARGS_ASSERT_DO_ODDBALL;
987
fb8f4cf8 988 if (*oddkey) {
6d822dc4 989 if (ckWARN(WARN_MISC)) {
a3b680e6 990 const char *err;
fb8f4cf8
RZ
991 if (oddkey == firstkey &&
992 SvROK(*oddkey) &&
993 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
994 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
10c8fecd 995 {
a3b680e6 996 err = "Reference found where even-sized list expected";
10c8fecd
GS
997 }
998 else
a3b680e6 999 err = "Odd number of elements in hash assignment";
f1f66076 1000 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
10c8fecd 1001 }
6d822dc4 1002
10c8fecd
GS
1003 }
1004}
1005
a0d0e21e
LW
1006PP(pp_aassign)
1007{
27da23d5 1008 dVAR; dSP;
3280af22
NIS
1009 SV **lastlelem = PL_stack_sp;
1010 SV **lastrelem = PL_stack_base + POPMARK;
1011 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
1012 SV **firstlelem = lastrelem + 1;
1013
eb578fdb
KW
1014 SV **relem;
1015 SV **lelem;
a0d0e21e 1016
eb578fdb
KW
1017 SV *sv;
1018 AV *ary;
a0d0e21e 1019
54310121 1020 I32 gimme;
a0d0e21e 1021 HV *hash;
c70927a6 1022 SSize_t i;
a0d0e21e 1023 int magic;
88e2091b 1024 U32 lval = 0;
5637b936 1025
3280af22 1026 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
ca65944e 1027 gimme = GIMME_V;
88e2091b
RZ
1028 if (gimme == G_ARRAY)
1029 lval = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e
LW
1030
1031 /* If there's a common identifier on both sides we have to take
1032 * special care that assigning the identifier on the left doesn't
1033 * clobber a value on the right that's used later in the list.
acdea6f0 1034 * Don't bother if LHS is just an empty hash or array.
a0d0e21e 1035 */
acdea6f0 1036
ff2a62e0 1037 if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
acdea6f0
DM
1038 && (
1039 firstlelem != lastlelem
1040 || ! ((sv = *firstlelem))
1041 || SvMAGICAL(sv)
1042 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1043 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1b95d04f 1044 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
acdea6f0
DM
1045 )
1046 ) {
cc5e57d2 1047 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd 1048 for (relem = firstrelem; relem <= lastrelem; relem++) {
5d9574c1 1049 if (LIKELY((sv = *relem))) {
a1f49e72 1050 TAINT_NOT; /* Each item is independent */
61e5f455
NC
1051
1052 /* Dear TODO test in t/op/sort.t, I love you.
1053 (It's relying on a panic, not a "semi-panic" from newSVsv()
1054 and then an assertion failure below.) */
5d9574c1 1055 if (UNLIKELY(SvIS_FREED(sv))) {
61e5f455
NC
1056 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1057 (void*)sv);
1058 }
2203fb5a
FC
1059 /* Not newSVsv(), as it does not allow copy-on-write,
1060 resulting in wasteful copies. We need a second copy of
1061 a temp here, hence the SV_NOSTEAL. */
1062 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1063 |SV_NOSTEAL);
a1f49e72 1064 }
10c8fecd 1065 }
a0d0e21e
LW
1066 }
1067
1068 relem = firstrelem;
1069 lelem = firstlelem;
4608196e
RGS
1070 ary = NULL;
1071 hash = NULL;
10c8fecd 1072
5d9574c1 1073 while (LIKELY(lelem <= lastlelem)) {
bbce6d69 1074 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e
LW
1075 sv = *lelem++;
1076 switch (SvTYPE(sv)) {
1077 case SVt_PVAV:
60edcf09 1078 ary = MUTABLE_AV(sv);
748a9306 1079 magic = SvMAGICAL(ary) != 0;
60edcf09
FC
1080 ENTER;
1081 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1082 av_clear(ary);
7e42bd57 1083 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
1084 i = 0;
1085 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 1086 SV **didstore;
5d9574c1 1087 if (LIKELY(*relem))
ce0d59fd 1088 SvGETMAGIC(*relem); /* before newSV, in case it dies */
18024492
FC
1089 sv = newSV(0);
1090 sv_setsv_nomg(sv, *relem);
a0d0e21e 1091 *(relem++) = sv;
5117ca91
GS
1092 didstore = av_store(ary,i++,sv);
1093 if (magic) {
18024492
FC
1094 if (!didstore)
1095 sv_2mortal(sv);
8ef24240 1096 if (SvSMAGICAL(sv))
fb73857a 1097 mg_set(sv);
5117ca91 1098 }
bbce6d69 1099 TAINT_NOT;
a0d0e21e 1100 }
5d9574c1 1101 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
ad64d0ec 1102 SvSETMAGIC(MUTABLE_SV(ary));
60edcf09 1103 LEAVE;
a0d0e21e 1104 break;
10c8fecd 1105 case SVt_PVHV: { /* normal hash */
a0d0e21e 1106 SV *tmpstr;
1c4ea384
RZ
1107 int odd;
1108 int duplicates = 0;
45960564 1109 SV** topelem = relem;
1c4ea384 1110 SV **firsthashrelem = relem;
a0d0e21e 1111
60edcf09 1112 hash = MUTABLE_HV(sv);
748a9306 1113 magic = SvMAGICAL(hash) != 0;
1c4ea384
RZ
1114
1115 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
5d9574c1 1116 if (UNLIKELY(odd)) {
fb8f4cf8 1117 do_oddball(lastrelem, firsthashrelem);
1d2b3927
HS
1118 /* we have firstlelem to reuse, it's not needed anymore
1119 */
1c4ea384
RZ
1120 *(lastrelem+1) = &PL_sv_undef;
1121 }
1122
60edcf09
FC
1123 ENTER;
1124 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1125 hv_clear(hash);
5d9574c1 1126 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
5117ca91 1127 HE *didstore;
1c4ea384 1128 assert(*relem);
632b9d6f
FC
1129 /* Copy the key if aassign is called in lvalue context,
1130 to avoid having the next op modify our rhs. Copy
1131 it also if it is gmagical, lest it make the
1132 hv_store_ent call below croak, leaking the value. */
1133 sv = lval || SvGMAGICAL(*relem)
1134 ? sv_mortalcopy(*relem)
1135 : *relem;
45960564 1136 relem++;
1c4ea384 1137 assert(*relem);
632b9d6f
FC
1138 SvGETMAGIC(*relem);
1139 tmpstr = newSV(0);
1140 sv_setsv_nomg(tmpstr,*relem++); /* value */
a88bf2bc 1141 if (gimme == G_ARRAY) {
45960564
DM
1142 if (hv_exists_ent(hash, sv, 0))
1143 /* key overwrites an existing entry */
1144 duplicates += 2;
a88bf2bc 1145 else {
45960564 1146 /* copy element back: possibly to an earlier
1d2b3927
HS
1147 * stack location if we encountered dups earlier,
1148 * possibly to a later stack location if odd */
45960564
DM
1149 *topelem++ = sv;
1150 *topelem++ = tmpstr;
1151 }
1152 }
5117ca91 1153 didstore = hv_store_ent(hash,sv,tmpstr,0);
632b9d6f
FC
1154 if (magic) {
1155 if (!didstore) sv_2mortal(tmpstr);
1156 SvSETMAGIC(tmpstr);
1157 }
bbce6d69 1158 TAINT_NOT;
8e07c86e 1159 }
60edcf09 1160 LEAVE;
1c4ea384
RZ
1161 if (duplicates && gimme == G_ARRAY) {
1162 /* at this point we have removed the duplicate key/value
1163 * pairs from the stack, but the remaining values may be
1164 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1165 * the (a 2), but the stack now probably contains
1166 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1167 * obliterates the earlier key. So refresh all values. */
1168 lastrelem -= duplicates;
1169 relem = firsthashrelem;
1170 while (relem < lastrelem+odd) {
1171 HE *he;
1172 he = hv_fetch_ent(hash, *relem++, 0, 0);
1173 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1174 }
1175 }
1176 if (odd && gimme == G_ARRAY) lastrelem++;
a0d0e21e
LW
1177 }
1178 break;
1179 default:
6fc92669
GS
1180 if (SvIMMORTAL(sv)) {
1181 if (relem <= lastrelem)
1182 relem++;
1183 break;
a0d0e21e
LW
1184 }
1185 if (relem <= lastrelem) {
5d9574c1 1186 if (UNLIKELY(
1c70fb82
FC
1187 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1188 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
5d9574c1 1189 ))
1c70fb82
FC
1190 Perl_warner(aTHX_
1191 packWARN(WARN_MISC),
1192 "Useless assignment to a temporary"
1193 );
a0d0e21e
LW
1194 sv_setsv(sv, *relem);
1195 *(relem++) = sv;
1196 }
1197 else
3280af22 1198 sv_setsv(sv, &PL_sv_undef);
8ef24240 1199 SvSETMAGIC(sv);
a0d0e21e
LW
1200 break;
1201 }
1202 }
5d9574c1 1203 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
985213f2 1204 /* Will be used to set PL_tainting below */
dfff4baf
BF
1205 Uid_t tmp_uid = PerlProc_getuid();
1206 Uid_t tmp_euid = PerlProc_geteuid();
1207 Gid_t tmp_gid = PerlProc_getgid();
1208 Gid_t tmp_egid = PerlProc_getegid();
985213f2 1209
b469f1e0 1210 /* XXX $> et al currently silently ignore failures */
3280af22 1211 if (PL_delaymagic & DM_UID) {
a0d0e21e 1212#ifdef HAS_SETRESUID
b469f1e0
JH
1213 PERL_UNUSED_RESULT(
1214 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1215 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1216 (Uid_t)-1));
56febc5e
AD
1217#else
1218# ifdef HAS_SETREUID
b469f1e0
JH
1219 PERL_UNUSED_RESULT(
1220 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1221 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
56febc5e
AD
1222# else
1223# ifdef HAS_SETRUID
b28d0864 1224 if ((PL_delaymagic & DM_UID) == DM_RUID) {
b469f1e0 1225 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
b28d0864 1226 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1227 }
56febc5e
AD
1228# endif /* HAS_SETRUID */
1229# ifdef HAS_SETEUID
b28d0864 1230 if ((PL_delaymagic & DM_UID) == DM_EUID) {
b469f1e0 1231 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
b28d0864 1232 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1233 }
56febc5e 1234# endif /* HAS_SETEUID */
b28d0864 1235 if (PL_delaymagic & DM_UID) {
985213f2 1236 if (PL_delaymagic_uid != PL_delaymagic_euid)
cea2e8a9 1237 DIE(aTHX_ "No setreuid available");
b469f1e0 1238 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
a0d0e21e 1239 }
56febc5e
AD
1240# endif /* HAS_SETREUID */
1241#endif /* HAS_SETRESUID */
04783dc7 1242
985213f2
AB
1243 tmp_uid = PerlProc_getuid();
1244 tmp_euid = PerlProc_geteuid();
a0d0e21e 1245 }
b469f1e0 1246 /* XXX $> et al currently silently ignore failures */
3280af22 1247 if (PL_delaymagic & DM_GID) {
a0d0e21e 1248#ifdef HAS_SETRESGID
b469f1e0
JH
1249 PERL_UNUSED_RESULT(
1250 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1251 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1252 (Gid_t)-1));
56febc5e
AD
1253#else
1254# ifdef HAS_SETREGID
b469f1e0
JH
1255 PERL_UNUSED_RESULT(
1256 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1257 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
56febc5e
AD
1258# else
1259# ifdef HAS_SETRGID
b28d0864 1260 if ((PL_delaymagic & DM_GID) == DM_RGID) {
b469f1e0 1261 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
b28d0864 1262 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1263 }
56febc5e
AD
1264# endif /* HAS_SETRGID */
1265# ifdef HAS_SETEGID
b28d0864 1266 if ((PL_delaymagic & DM_GID) == DM_EGID) {
b469f1e0 1267 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
b28d0864 1268 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1269 }
56febc5e 1270# endif /* HAS_SETEGID */
b28d0864 1271 if (PL_delaymagic & DM_GID) {
985213f2 1272 if (PL_delaymagic_gid != PL_delaymagic_egid)
cea2e8a9 1273 DIE(aTHX_ "No setregid available");
b469f1e0 1274 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
a0d0e21e 1275 }
56febc5e
AD
1276# endif /* HAS_SETREGID */
1277#endif /* HAS_SETRESGID */
04783dc7 1278
985213f2
AB
1279 tmp_gid = PerlProc_getgid();
1280 tmp_egid = PerlProc_getegid();
a0d0e21e 1281 }
284167a5 1282 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
9a9b5ec9
DM
1283#ifdef NO_TAINT_SUPPORT
1284 PERL_UNUSED_VAR(tmp_uid);
1285 PERL_UNUSED_VAR(tmp_euid);
1286 PERL_UNUSED_VAR(tmp_gid);
1287 PERL_UNUSED_VAR(tmp_egid);
1288#endif
a0d0e21e 1289 }
3280af22 1290 PL_delaymagic = 0;
54310121 1291
54310121
PP
1292 if (gimme == G_VOID)
1293 SP = firstrelem - 1;
1294 else if (gimme == G_SCALAR) {
1295 dTARGET;
1296 SP = firstrelem;
231cbeb2 1297 SETi(lastrelem - firstrelem + 1);
54310121
PP
1298 }
1299 else {
1c4ea384 1300 if (ary || hash)
1d2b3927
HS
1301 /* note that in this case *firstlelem may have been overwritten
1302 by sv_undef in the odd hash case */
a0d0e21e 1303 SP = lastrelem;
1c4ea384 1304 else {
a0d0e21e 1305 SP = firstrelem + (lastlelem - firstlelem);
1c4ea384
RZ
1306 lelem = firstlelem + (relem - firstrelem);
1307 while (relem <= SP)
1308 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1309 }
a0d0e21e 1310 }
08aeb9f7 1311
54310121 1312 RETURN;
a0d0e21e
LW
1313}
1314
8782bef2
GB
1315PP(pp_qr)
1316{
20b7effb 1317 dSP;
eb578fdb 1318 PMOP * const pm = cPMOP;
fe578d7f 1319 REGEXP * rx = PM_GETRE(pm);
10599a69 1320 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
c4420975 1321 SV * const rv = sv_newmortal();
d63c20f2
DM
1322 CV **cvp;
1323 CV *cv;
288b8c02
NC
1324
1325 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
1326 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1327 loathe to use it here, but it seems to be the right fix. Or close.
1328 The key part appears to be that it's essential for pp_qr to return a new
1329 object (SV), which implies that there needs to be an effective way to
1330 generate a new SV from the existing SV that is pre-compiled in the
1331 optree. */
1332 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
1333 SvROK_on(rv);
1334
8d919b0a 1335 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
5d9574c1 1336 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
d63c20f2 1337 *cvp = cv_clone(cv);
fc2b2dca 1338 SvREFCNT_dec_NN(cv);
d63c20f2
DM
1339 }
1340
288b8c02 1341 if (pkg) {
f815daf2 1342 HV *const stash = gv_stashsv(pkg, GV_ADD);
fc2b2dca 1343 SvREFCNT_dec_NN(pkg);
288b8c02
NC
1344 (void)sv_bless(rv, stash);
1345 }
1346
5d9574c1 1347 if (UNLIKELY(RX_ISTAINTED(rx))) {
e08e52cf 1348 SvTAINTED_on(rv);
9274aefd
DM
1349 SvTAINTED_on(SvRV(rv));
1350 }
c8c13c22 1351 XPUSHs(rv);
1352 RETURN;
8782bef2
GB
1353}
1354
a0d0e21e
LW
1355PP(pp_match)
1356{
20b7effb 1357 dSP; dTARG;
eb578fdb 1358 PMOP *pm = cPMOP;
d65afb4b 1359 PMOP *dynpm = pm;
eb578fdb 1360 const char *s;
5c144d81 1361 const char *strend;
99a90e59 1362 SSize_t curpos = 0; /* initial pos() or current $+[0] */
a0d0e21e 1363 I32 global;
7fadf4a7 1364 U8 r_flags = 0;
5c144d81 1365 const char *truebase; /* Start of string */
eb578fdb 1366 REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1367 bool rxtainted;
a3b680e6 1368 const I32 gimme = GIMME;
a0d0e21e 1369 STRLEN len;
a3b680e6 1370 const I32 oldsave = PL_savestack_ix;
e60df1fa 1371 I32 had_zerolen = 0;
b1422d62 1372 MAGIC *mg = NULL;
a0d0e21e 1373
533c011a 1374 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1375 TARG = POPs;
59f00321
RGS
1376 else if (PL_op->op_private & OPpTARGET_MY)
1377 GETTARGET;
a0d0e21e 1378 else {
54b9620d 1379 TARG = DEFSV;
a0d0e21e
LW
1380 EXTEND(SP,1);
1381 }
d9f424b2 1382
c277df42 1383 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
1384 /* Skip get-magic if this is a qr// clone, because regcomp has
1385 already done it. */
f1d31338 1386 truebase = ReANY(rx)->mother_re
69dc4b30
FC
1387 ? SvPV_nomg_const(TARG, len)
1388 : SvPV_const(TARG, len);
f1d31338 1389 if (!truebase)
2269b42e 1390 DIE(aTHX_ "panic: pp_match");
f1d31338 1391 strend = truebase + len;
284167a5
SM
1392 rxtainted = (RX_ISTAINTED(rx) ||
1393 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1394 TAINT_NOT;
a0d0e21e 1395
6c864ec2 1396 /* We need to know this in case we fail out early - pos() must be reset */
de0df3c0
MH
1397 global = dynpm->op_pmflags & PMf_GLOBAL;
1398
d65afb4b 1399 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
1400 if (
1401#ifdef USE_ITHREADS
1402 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1403#else
1404 pm->op_pmflags & PMf_USED
1405#endif
1406 ) {
e5dc5375 1407 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
de0df3c0 1408 goto nope;
a0d0e21e
LW
1409 }
1410
7e313637
FC
1411 /* empty pattern special-cased to use last successful pattern if
1412 possible, except for qr// */
8d919b0a 1413 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
7e313637 1414 && PL_curpm) {
3280af22 1415 pm = PL_curpm;
aaa362c4 1416 rx = PM_GETRE(pm);
a0d0e21e 1417 }
d65afb4b 1418
389ecb56 1419 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
75d43e96
FC
1420 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1421 UVuf" < %"IVdf")\n",
1422 (UV)len, (IV)RX_MINLEN(rx)));
de0df3c0 1423 goto nope;
e5dc5375 1424 }
c277df42 1425
8ef97b0e 1426 /* get pos() if //g */
de0df3c0 1427 if (global) {
b1422d62 1428 mg = mg_find_mglob(TARG);
8ef97b0e 1429 if (mg && mg->mg_len >= 0) {
25fdce4a 1430 curpos = MgBYTEPOS(mg, TARG, truebase, len);
8ef97b0e
DM
1431 /* last time pos() was set, it was zero-length match */
1432 if (mg->mg_flags & MGf_MINMATCH)
1433 had_zerolen = 1;
1434 }
a0d0e21e 1435 }
8ef97b0e 1436
6e240d0b 1437#ifdef PERL_SAWAMPERSAND
a41aa44d 1438 if ( RX_NPARENS(rx)
6502e081 1439 || PL_sawampersand
6502e081 1440 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 1441 || (dynpm->op_pmflags & PMf_KEEPCOPY)
6e240d0b
FC
1442 )
1443#endif
1444 {
6502e081
DM
1445 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1446 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1447 * only on the first iteration. Therefore we need to copy $' as well
1448 * as $&, to make the rest of the string available for captures in
1449 * subsequent iterations */
1450 if (! (global && gimme == G_ARRAY))
1451 r_flags |= REXEC_COPY_SKIP_POST;
1452 };
5b0e71e9
DM
1453#ifdef PERL_SAWAMPERSAND
1454 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1455 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1456 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1457#endif
22e551b9 1458
f1d31338
DM
1459 s = truebase;
1460
d7be1480 1461 play_it_again:
985afbc1 1462 if (global)
03c83e26 1463 s = truebase + curpos;
f722798b 1464
77da2310 1465 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
03c83e26 1466 had_zerolen, TARG, NULL, r_flags))
03b6c93d 1467 goto nope;
77da2310
NC
1468
1469 PL_curpm = pm;
985afbc1 1470 if (dynpm->op_pmflags & PMf_ONCE)
c737faaf 1471#ifdef USE_ITHREADS
77da2310 1472 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 1473#else
77da2310 1474 dynpm->op_pmflags |= PMf_USED;
c737faaf 1475#endif
a0d0e21e 1476
72311751
GS
1477 if (rxtainted)
1478 RX_MATCH_TAINTED_on(rx);
1479 TAINT_IF(RX_MATCH_TAINTED(rx));
35c2ccc3
DM
1480
1481 /* update pos */
1482
1483 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
b1422d62 1484 if (!mg)
35c2ccc3 1485 mg = sv_magicext_mglob(TARG);
25fdce4a 1486 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
adf51885
DM
1487 if (RX_ZERO_LEN(rx))
1488 mg->mg_flags |= MGf_MINMATCH;
1489 else
1490 mg->mg_flags &= ~MGf_MINMATCH;
35c2ccc3
DM
1491 }
1492
bf9dff51
DM
1493 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1494 LEAVE_SCOPE(oldsave);
1495 RETPUSHYES;
1496 }
1497
88ab22af
DM
1498 /* push captures on stack */
1499
bf9dff51 1500 {
07bc277f 1501 const I32 nparens = RX_NPARENS(rx);
a3b680e6 1502 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 1503
c277df42 1504 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1505 EXTEND(SP, nparens + i);
1506 EXTEND_MORTAL(nparens + i);
1507 for (i = !i; i <= nparens; i++) {
a0d0e21e 1508 PUSHs(sv_newmortal());
5d9574c1
DM
1509 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1510 && RX_OFFS(rx)[i].end != -1 ))
1511 {
07bc277f 1512 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
f1d31338 1513 const char * const s = RX_OFFS(rx)[i].start + truebase;
5d9574c1
DM
1514 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1515 || len < 0 || len > strend - s))
5637ef5b
NC
1516 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1517 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1518 (long) i, (long) RX_OFFS(rx)[i].start,
1519 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
a0d0e21e 1520 sv_setpvn(*SP, s, len);
cce850e4 1521 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1522 SvUTF8_on(*SP);
a0d0e21e
LW
1523 }
1524 }
1525 if (global) {
0e0b3e82 1526 curpos = (UV)RX_OFFS(rx)[0].end;
03c83e26 1527 had_zerolen = RX_ZERO_LEN(rx);
c277df42 1528 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1529 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1530 goto play_it_again;
1531 }
4633a7c4 1532 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1533 RETURN;
1534 }
88ab22af 1535 /* NOTREACHED */
a0d0e21e
LW
1536
1537nope:
d65afb4b 1538 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
b1422d62
DM
1539 if (!mg)
1540 mg = mg_find_mglob(TARG);
1541 if (mg)
1542 mg->mg_len = -1;
a0d0e21e 1543 }
4633a7c4 1544 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1545 if (gimme == G_ARRAY)
1546 RETURN;
1547 RETPUSHNO;
1548}
1549
1550OP *
864dbfa3 1551Perl_do_readline(pTHX)
a0d0e21e 1552{
20b7effb 1553 dSP; dTARGETSTACKED;
eb578fdb 1554 SV *sv;
a0d0e21e
LW
1555 STRLEN tmplen = 0;
1556 STRLEN offset;
760ac839 1557 PerlIO *fp;
eb578fdb
KW
1558 IO * const io = GvIO(PL_last_in_gv);
1559 const I32 type = PL_op->op_type;
a3b680e6 1560 const I32 gimme = GIMME_V;
a0d0e21e 1561
6136c704 1562 if (io) {
50db69d8 1563 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 1564 if (mg) {
3e0cb5de 1565 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 1566 if (gimme == G_SCALAR) {
50db69d8
NC
1567 SPAGAIN;
1568 SvSetSV_nosteal(TARG, TOPs);
1569 SETTARG;
6136c704 1570 }
50db69d8 1571 return NORMAL;
0b7c7b4f 1572 }
e79b0511 1573 }
4608196e 1574 fp = NULL;
a0d0e21e
LW
1575 if (io) {
1576 fp = IoIFP(io);
1577 if (!fp) {
1578 if (IoFLAGS(io) & IOf_ARGV) {
1579 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1580 IoLINES(io) = 0;
b9f2b683 1581 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1582 IoFLAGS(io) &= ~IOf_START;
d5eb9a46 1583 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
4bac9ae4 1584 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
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--;
7716c5c5 1601 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 1602 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 1603 }
a0d0e21e
LW
1604 }
1605 if (!fp) {
041457d9 1606 if ((!io || !(IoFLAGS(io) & IOf_START))
de7dabb6
TC
1607 && ckWARN(WARN_CLOSED)
1608 && type != OP_GLOB)
041457d9 1609 {
de7dabb6 1610 report_evil_fh(PL_last_in_gv);
3f4520fe 1611 }
54310121 1612 if (gimme == G_SCALAR) {
79628082 1613 /* undef TARG, and push that undefined value */
ba92458f
AE
1614 if (type != OP_RCATLINE) {
1615 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1616 SvOK_off(TARG);
ba92458f 1617 }
a0d0e21e
LW
1618 PUSHTARG;
1619 }
1620 RETURN;
1621 }
a2008d6d 1622 have_fp:
54310121 1623 if (gimme == G_SCALAR) {
a0d0e21e 1624 sv = TARG;
0f722b55
RGS
1625 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1626 mg_get(sv);
48de12d9
RGS
1627 if (SvROK(sv)) {
1628 if (type == OP_RCATLINE)
5668452f 1629 SvPV_force_nomg_nolen(sv);
48de12d9
RGS
1630 else
1631 sv_unref(sv);
1632 }
f7877b28 1633 else if (isGV_with_GP(sv)) {
5668452f 1634 SvPV_force_nomg_nolen(sv);
f7877b28 1635 }
862a34c6 1636 SvUPGRADE(sv, SVt_PV);
a0d0e21e 1637 tmplen = SvLEN(sv); /* remember if already alloced */
e3918bb7 1638 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
f72e8700
JJ
1639 /* try short-buffering it. Please update t/op/readline.t
1640 * if you change the growth length.
1641 */
1642 Sv_Grow(sv, 80);
1643 }
2b5e58c4
AMS
1644 offset = 0;
1645 if (type == OP_RCATLINE && SvOK(sv)) {
1646 if (!SvPOK(sv)) {
5668452f 1647 SvPV_force_nomg_nolen(sv);
2b5e58c4 1648 }
a0d0e21e 1649 offset = SvCUR(sv);
2b5e58c4 1650 }
a0d0e21e 1651 }
54310121 1652 else {
561b68a9 1653 sv = sv_2mortal(newSV(80));
54310121
PP
1654 offset = 0;
1655 }
fbad3eb5 1656
3887d568
AP
1657 /* This should not be marked tainted if the fp is marked clean */
1658#define MAYBE_TAINT_LINE(io, sv) \
1659 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1660 TAINT; \
1661 SvTAINTED_on(sv); \
1662 }
1663
684bef36 1664/* delay EOF state for a snarfed empty file */
fbad3eb5 1665#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1666 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1667 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1668
a0d0e21e 1669 for (;;) {
09e8efcc 1670 PUTBACK;
fbad3eb5 1671 if (!sv_gets(sv, fp, offset)
2d726892
TF
1672 && (type == OP_GLOB
1673 || SNARF_EOF(gimme, PL_rs, io, sv)
1674 || PerlIO_error(fp)))
fbad3eb5 1675 {
760ac839 1676 PerlIO_clearerr(fp);
a0d0e21e 1677 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1678 fp = nextargv(PL_last_in_gv);
a0d0e21e
LW
1679 if (fp)
1680 continue;
3280af22 1681 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1682 }
1683 else if (type == OP_GLOB) {
a2a5de95
NC
1684 if (!do_close(PL_last_in_gv, FALSE)) {
1685 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1686 "glob failed (child exited with status %d%s)",
1687 (int)(STATUS_CURRENT >> 8),
1688 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1689 }
a0d0e21e 1690 }
54310121 1691 if (gimme == G_SCALAR) {
ba92458f
AE
1692 if (type != OP_RCATLINE) {
1693 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1694 SvOK_off(TARG);
ba92458f 1695 }
09e8efcc 1696 SPAGAIN;
a0d0e21e
LW
1697 PUSHTARG;
1698 }
3887d568 1699 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1700 RETURN;
1701 }
3887d568 1702 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1703 IoLINES(io)++;
b9fee9ba 1704 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1705 SvSETMAGIC(sv);
09e8efcc 1706 SPAGAIN;
a0d0e21e 1707 XPUSHs(sv);
a0d0e21e 1708 if (type == OP_GLOB) {
349d4f2f 1709 const char *t1;
a0d0e21e 1710
3280af22 1711 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 1712 char * const tmps = SvEND(sv) - 1;
aa07b2f6 1713 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 1714 *tmps = '\0';
b162af07 1715 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
1716 }
1717 }
349d4f2f 1718 for (t1 = SvPVX_const(sv); *t1; t1++)
b51c3e77
CB
1719#ifdef __VMS
1720 if (strchr("*%?", *t1))
1721#else
7ad1e72d 1722 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
b51c3e77 1723#endif
a0d0e21e 1724 break;
349d4f2f 1725 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1726 (void)POPs; /* Unmatched wildcard? Chuck it... */
1727 continue;
1728 }
2d79bf7f 1729 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
1730 if (ckWARN(WARN_UTF8)) {
1731 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1732 const STRLEN len = SvCUR(sv) - offset;
1733 const U8 *f;
1734
1735 if (!is_utf8_string_loc(s, len, &f))
1736 /* Emulate :encoding(utf8) warning in the same case. */
1737 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1738 "utf8 \"\\x%02X\" does not map to Unicode",
1739 f < (U8*)SvEND(sv) ? *f : 0);
1740 }
a0d0e21e 1741 }
54310121 1742 if (gimme == G_ARRAY) {
a0d0e21e 1743 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 1744 SvPV_shrink_to_cur(sv);
a0d0e21e 1745 }
561b68a9 1746 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
1747 continue;
1748 }
54310121 1749 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 1750 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
1751 const STRLEN new_len
1752 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 1753 SvPV_renew(sv, new_len);
a0d0e21e
LW
1754 }
1755 RETURN;
1756 }
1757}
1758
a0d0e21e
LW
1759PP(pp_helem)
1760{
20b7effb 1761 dSP;
760ac839 1762 HE* he;
ae77835f 1763 SV **svp;
c445ea15 1764 SV * const keysv = POPs;
85fbaab2 1765 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
1766 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1767 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1768 SV *sv;
92970b93 1769 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 1770 bool preeminent = TRUE;
a0d0e21e 1771
d4c19fe8 1772 if (SvTYPE(hv) != SVt_PVHV)
a0d0e21e 1773 RETPUSHUNDEF;
d4c19fe8 1774
92970b93 1775 if (localizing) {
d4c19fe8
AL
1776 MAGIC *mg;
1777 HV *stash;
d30e492c
VP
1778
1779 /* If we can determine whether the element exist,
1780 * Try to preserve the existenceness of a tied hash
1781 * element by using EXISTS and DELETE if possible.
1782 * Fallback to FETCH and STORE otherwise. */
2c5f48c2 1783 if (SvCANEXISTDELETE(hv))
d30e492c 1784 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 1785 }
d30e492c 1786
5f9d7e2b 1787 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
d4c19fe8 1788 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 1789 if (lval) {
746f6409 1790 if (!svp || !*svp || *svp == &PL_sv_undef) {
68dc0745
PP
1791 SV* lv;
1792 SV* key2;
2d8e6c8d 1793 if (!defer) {
be2597df 1794 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 1795 }
68dc0745
PP
1796 lv = sv_newmortal();
1797 sv_upgrade(lv, SVt_PVLV);
1798 LvTYPE(lv) = 'y';
6136c704 1799 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
fc2b2dca 1800 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
b37c2d43 1801 LvTARG(lv) = SvREFCNT_inc_simple(hv);
68dc0745
PP
1802 LvTARGLEN(lv) = 1;
1803 PUSHs(lv);
1804 RETURN;
1805 }
92970b93 1806 if (localizing) {
bfcb3514 1807 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 1808 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
1809 else if (preeminent)
1810 save_helem_flags(hv, keysv, svp,
1811 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1812 else
1813 SAVEHDELETE(hv, keysv);
5f05dabc 1814 }
9026059d
GG
1815 else if (PL_op->op_private & OPpDEREF) {
1816 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1817 RETURN;
1818 }
a0d0e21e 1819 }
746f6409 1820 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
1821 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1822 * was to make C<local $tied{foo} = $tied{foo}> possible.
1823 * However, it seems no longer to be needed for that purpose, and
1824 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1825 * would loop endlessly since the pos magic is getting set on the
1826 * mortal copy and lost. However, the copy has the effect of
1827 * triggering the get magic, and losing it altogether made things like
1828 * c<$tied{foo};> in void context no longer do get magic, which some
1829 * code relied on. Also, delayed triggering of magic on @+ and friends
1830 * meant the original regex may be out of scope by now. So as a
1831 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1832 * being called too many times). */
39cf747a 1833 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 1834 mg_get(sv);
be6c24e0 1835 PUSHs(sv);
a0d0e21e
LW
1836 RETURN;
1837}
1838
a0d0e21e
LW
1839PP(pp_iter)
1840{
20b7effb 1841 dSP;
eb578fdb 1842 PERL_CONTEXT *cx;
7d6c2cef 1843 SV *oldsv;
1d7c1841 1844 SV **itersvp;
a0d0e21e 1845
924508f0 1846 EXTEND(SP, 1);
a0d0e21e 1847 cx = &cxstack[cxstack_ix];
1d7c1841 1848 itersvp = CxITERVAR(cx);
a48ce6be
DM
1849
1850 switch (CxTYPE(cx)) {
17c91640 1851
b552b52c
DM
1852 case CXt_LOOP_LAZYSV: /* string increment */
1853 {
1854 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1855 SV *end = cx->blk_loop.state_u.lazysv.end;
1856 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1857 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1858 STRLEN maxlen = 0;
1859 const char *max = SvPV_const(end, maxlen);
5d9574c1 1860 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
b552b52c
DM
1861 RETPUSHNO;
1862
1863 oldsv = *itersvp;
5d9574c1 1864 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
b552b52c
DM
1865 /* safe to reuse old SV */
1866 sv_setsv(oldsv, cur);
a48ce6be 1867 }
b552b52c
DM
1868 else
1869 {
1870 /* we need a fresh SV every time so that loop body sees a
1871 * completely new SV for closures/references to work as
1872 * they used to */
1873 *itersvp = newSVsv(cur);
fc2b2dca 1874 SvREFCNT_dec_NN(oldsv);
b552b52c
DM
1875 }
1876 if (strEQ(SvPVX_const(cur), max))
1877 sv_setiv(cur, 0); /* terminate next time */
1878 else
1879 sv_inc(cur);
1880 break;
1881 }
a48ce6be 1882
fcef60b4
DM
1883 case CXt_LOOP_LAZYIV: /* integer increment */
1884 {
1885 IV cur = cx->blk_loop.state_u.lazyiv.cur;
5d9574c1 1886 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
89ea2908 1887 RETPUSHNO;
7f61b687 1888
fcef60b4 1889 oldsv = *itersvp;
3db8f154 1890 /* don't risk potential race */
5d9574c1 1891 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
eaa5c2d6 1892 /* safe to reuse old SV */
fcef60b4 1893 sv_setiv(oldsv, cur);
eaa5c2d6 1894 }
1c846c1f 1895 else
eaa5c2d6
GA
1896 {
1897 /* we need a fresh SV every time so that loop body sees a
1898 * completely new SV for closures/references to work as they
1899 * used to */
fcef60b4 1900 *itersvp = newSViv(cur);
fc2b2dca 1901 SvREFCNT_dec_NN(oldsv);
eaa5c2d6 1902 }
a2309040 1903
5d9574c1 1904 if (UNLIKELY(cur == IV_MAX)) {
cdc1aa42
NC
1905 /* Handle end of range at IV_MAX */
1906 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1907 } else
1908 ++cx->blk_loop.state_u.lazyiv.cur;
a48ce6be 1909 break;
fcef60b4 1910 }
a48ce6be 1911
b552b52c 1912 case CXt_LOOP_FOR: /* iterate array */
7d6c2cef 1913 {
89ea2908 1914
7d6c2cef
DM
1915 AV *av = cx->blk_loop.state_u.ary.ary;
1916 SV *sv;
1917 bool av_is_stack = FALSE;
a8a20bb6 1918 IV ix;
7d6c2cef 1919
de080daa
DM
1920 if (!av) {
1921 av_is_stack = TRUE;
1922 av = PL_curstack;
1923 }
1924 if (PL_op->op_private & OPpITER_REVERSED) {
a8a20bb6 1925 ix = --cx->blk_loop.state_u.ary.ix;
5d9574c1 1926 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
de080daa 1927 RETPUSHNO;
de080daa
DM
1928 }
1929 else {
a8a20bb6 1930 ix = ++cx->blk_loop.state_u.ary.ix;
5d9574c1 1931 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
de080daa 1932 RETPUSHNO;
a8a20bb6 1933 }
de080daa 1934
5d9574c1 1935 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
a8a20bb6
DM
1936 SV * const * const svp = av_fetch(av, ix, FALSE);
1937 sv = svp ? *svp : NULL;
1938 }
1939 else {
1940 sv = AvARRAY(av)[ix];
de080daa 1941 }
ef3e5ea9 1942
5d9574c1
DM
1943 if (LIKELY(sv)) {
1944 if (UNLIKELY(SvIS_FREED(sv))) {
f38aa882
DM
1945 *itersvp = NULL;
1946 Perl_croak(aTHX_ "Use of freed value in iteration");
1947 }
60779a30 1948 if (SvPADTMP(sv)) {
8e079c2a 1949 sv = newSVsv(sv);
60779a30 1950 }
8e079c2a
FC
1951 else {
1952 SvTEMP_off(sv);
1953 SvREFCNT_inc_simple_void_NN(sv);
1954 }
de080daa 1955 }
a600f7e6 1956 else if (!av_is_stack) {
199f858d 1957 sv = newSVavdefelem(av, ix, 0);
de080daa 1958 }
a600f7e6
FC
1959 else
1960 sv = &PL_sv_undef;
a0d0e21e 1961
de080daa
DM
1962 oldsv = *itersvp;
1963 *itersvp = sv;
1964 SvREFCNT_dec(oldsv);
de080daa 1965 break;
7d6c2cef 1966 }
a48ce6be
DM
1967
1968 default:
1969 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1970 }
b552b52c 1971 RETPUSHYES;
a0d0e21e
LW
1972}
1973
ef07e810
DM
1974/*
1975A description of how taint works in pattern matching and substitution.
1976
284167a5
SM
1977This is all conditional on NO_TAINT_SUPPORT not being defined. Under
1978NO_TAINT_SUPPORT, taint-related operations should become no-ops.
1979
4e19c54b 1980While the pattern is being assembled/concatenated and then compiled,
284167a5
SM
1981PL_tainted will get set (via TAINT_set) if any component of the pattern
1982is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
1983the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1738e041
DM
1984TAINT_get). It will also be set if any component of the pattern matches
1985based on locale-dependent behavior.
ef07e810 1986
0ab462a6
DM
1987When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1988the pattern is marked as tainted. This means that subsequent usage, such
284167a5
SM
1989as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
1990on the new pattern too.
ef07e810 1991
272d35c9 1992RXf_TAINTED_SEEN is used post-execution by the get magic code
ef07e810
DM
1993of $1 et al to indicate whether the returned value should be tainted.
1994It is the responsibility of the caller of the pattern (i.e. pp_match,
1995pp_subst etc) to set this flag for any other circumstances where $1 needs
1996to be tainted.
1997
1998The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1999
2000There are three possible sources of taint
2001 * the source string
2002 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2003 * the replacement string (or expression under /e)
2004
2005There are four destinations of taint and they are affected by the sources
2006according to the rules below:
2007
2008 * the return value (not including /r):
2009 tainted by the source string and pattern, but only for the
2010 number-of-iterations case; boolean returns aren't tainted;
2011 * the modified string (or modified copy under /r):
2012 tainted by the source string, pattern, and replacement strings;
2013 * $1 et al:
2014 tainted by the pattern, and under 'use re "taint"', by the source
2015 string too;
2016 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2017 should always be unset before executing subsequent code.
2018
2019The overall action of pp_subst is:
2020
2021 * at the start, set bits in rxtainted indicating the taint status of
2022 the various sources.
2023
2024 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2025 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2026 pattern has subsequently become tainted via locale ops.
2027
2028 * If control is being passed to pp_substcont to execute a /e block,
2029 save rxtainted in the CXt_SUBST block, for future use by
2030 pp_substcont.
2031
2032 * Whenever control is being returned to perl code (either by falling
2033 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2034 use the flag bits in rxtainted to make all the appropriate types of
0ab462a6
DM
2035 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2036 et al will appear tainted.
ef07e810
DM
2037
2038pp_match is just a simpler version of the above.
2039
2040*/
2041
a0d0e21e
LW
2042PP(pp_subst)
2043{
20b7effb 2044 dSP; dTARG;
eb578fdb 2045 PMOP *pm = cPMOP;
a0d0e21e 2046 PMOP *rpm = pm;
eb578fdb 2047 char *s;
a0d0e21e 2048 char *strend;
5c144d81 2049 const char *c;
a0d0e21e
LW
2050 STRLEN clen;
2051 I32 iters = 0;
2052 I32 maxiters;
a0d0e21e 2053 bool once;
ef07e810
DM
2054 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2055 See "how taint works" above */
a0d0e21e 2056 char *orig;
1ed74d04 2057 U8 r_flags;
eb578fdb 2058 REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
2059 STRLEN len;
2060 int force_on_match = 0;
0bcc34c2 2061 const I32 oldsave = PL_savestack_ix;
792b2c16 2062 STRLEN slen;
26a74523 2063 bool doutf8 = FALSE; /* whether replacement is in utf8 */
db2c6cb3 2064#ifdef PERL_ANY_COW
ed252734
NC
2065 bool is_cow;
2066#endif
a0714e2c 2067 SV *nsv = NULL;
b770e143 2068 /* known replacement string? */
eb578fdb 2069 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
a0d0e21e 2070
f410a211
NC
2071 PERL_ASYNC_CHECK();
2072
533c011a 2073 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 2074 TARG = POPs;
59f00321
RGS
2075 else if (PL_op->op_private & OPpTARGET_MY)
2076 GETTARGET;
a0d0e21e 2077 else {
54b9620d 2078 TARG = DEFSV;
a0d0e21e 2079 EXTEND(SP,1);
1c846c1f 2080 }
d9f424b2 2081
64534138 2082 SvGETMAGIC(TARG); /* must come before cow check */
db2c6cb3 2083#ifdef PERL_ANY_COW
ed252734
NC
2084 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2085 because they make integers such as 256 "false". */
2086 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2087#else
765f542d
NC
2088 if (SvIsCOW(TARG))
2089 sv_force_normal_flags(TARG,0);
ed252734 2090#endif
8ca8a454 2091 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
8ca8a454
NC
2092 && (SvREADONLY(TARG)
2093 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2094 || SvTYPE(TARG) > SVt_PVLV)
2095 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
cb077ed2 2096 Perl_croak_no_modify();
8ec5e241
NIS
2097 PUTBACK;
2098
6ac6605d
DM
2099 orig = SvPV_nomg(TARG, len);
2100 /* note we don't (yet) force the var into being a string; if we fail
2101 * to match, we leave as-is; on successful match howeverm, we *will*
2102 * coerce into a string, then repeat the match */
4499db73 2103 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
a0d0e21e 2104 force_on_match = 1;
20be6587
DM
2105
2106 /* only replace once? */
2107 once = !(rpm->op_pmflags & PMf_GLOBAL);
2108
ef07e810 2109 /* See "how taint works" above */
284167a5 2110 if (TAINTING_get) {
20be6587
DM
2111 rxtainted = (
2112 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
284167a5 2113 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
20be6587
DM
2114 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2115 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2116 ? SUBST_TAINT_BOOLRET : 0));
2117 TAINT_NOT;
2118 }
a12c0f56 2119
a0d0e21e 2120 force_it:
6ac6605d
DM
2121 if (!pm || !orig)
2122 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
a0d0e21e 2123
6ac6605d
DM
2124 strend = orig + len;
2125 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
792b2c16
JH
2126 maxiters = 2 * slen + 10; /* We can match twice at each
2127 position, once with zero-length,
2128 second time with non-zero. */
a0d0e21e 2129
6a97c51d 2130 if (!RX_PRELEN(rx) && PL_curpm
8d919b0a 2131 && !ReANY(rx)->mother_re) {
3280af22 2132 pm = PL_curpm;
aaa362c4 2133 rx = PM_GETRE(pm);
a0d0e21e 2134 }
6502e081 2135
6e240d0b 2136#ifdef PERL_SAWAMPERSAND
6502e081
DM
2137 r_flags = ( RX_NPARENS(rx)
2138 || PL_sawampersand
6502e081 2139 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 2140 || (rpm->op_pmflags & PMf_KEEPCOPY)
6502e081
DM
2141 )
2142 ? REXEC_COPY_STR
2143 : 0;
6e240d0b
FC
2144#else
2145 r_flags = REXEC_COPY_STR;
2146#endif
7fba1cd6 2147
0395280b 2148 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
8b64c330 2149 {
5e79dfb9
DM
2150 SPAGAIN;
2151 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2152 LEAVE_SCOPE(oldsave);
2153 RETURN;
2154 }
1754320d
FC
2155 PL_curpm = pm;
2156
71be2cbc 2157 /* known replacement string? */
f272994b 2158 if (dstr) {
8514a05a
JH
2159 /* replacement needing upgrading? */
2160 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2161 nsv = sv_newmortal();
4a176938 2162 SvSetSV(nsv, dstr);
8514a05a
JH
2163 if (PL_encoding)
2164 sv_recode_to_utf8(nsv, PL_encoding);
2165 else
2166 sv_utf8_upgrade(nsv);
5c144d81 2167 c = SvPV_const(nsv, clen);
4a176938
JH
2168 doutf8 = TRUE;
2169 }
2170 else {
5c144d81 2171 c = SvPV_const(dstr, clen);
4a176938 2172 doutf8 = DO_UTF8(dstr);
8514a05a 2173 }
bb933b9b
FC
2174
2175 if (SvTAINTED(dstr))
2176 rxtainted |= SUBST_TAINT_REPL;
f272994b
A
2177 }
2178 else {
6136c704 2179 c = NULL;
f272994b
A
2180 doutf8 = FALSE;
2181 }
2182
71be2cbc 2183 /* can do inplace substitution? */
ed252734 2184 if (c
db2c6cb3 2185#ifdef PERL_ANY_COW
ed252734
NC
2186 && !is_cow
2187#endif
fbfb1899 2188 && (I32)clen <= RX_MINLENRET(rx)
9cefd268
FC
2189 && ( once
2190 || !(r_flags & REXEC_COPY_STR)
2191 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2192 )
dbc200c5 2193 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
8ca8a454
NC
2194 && (!doutf8 || SvUTF8(TARG))
2195 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
8b030b38 2196 {
ec911639 2197
db2c6cb3 2198#ifdef PERL_ANY_COW
ed252734 2199 if (SvIsCOW(TARG)) {
f7a8268c 2200 if (!force_on_match)
ed252734 2201 goto have_a_cow;
f7a8268c 2202 assert(SvVOK(TARG));
ed252734
NC
2203 }
2204#endif
71be2cbc 2205 if (force_on_match) {
6ac6605d
DM
2206 /* redo the first match, this time with the orig var
2207 * forced into being a string */
71be2cbc 2208 force_on_match = 0;
6ac6605d 2209 orig = SvPV_force_nomg(TARG, len);
71be2cbc
PP
2210 goto force_it;
2211 }
39b40493 2212
71be2cbc 2213 if (once) {
c67ab8f2 2214 char *d, *m;
20be6587
DM
2215 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2216 rxtainted |= SUBST_TAINT_PAT;
07bc277f
NC
2217 m = orig + RX_OFFS(rx)[0].start;
2218 d = orig + RX_OFFS(rx)[0].end;
71be2cbc
PP
2219 s = orig;
2220 if (m - s > strend - d) { /* faster to shorten from end */
2ec7214c 2221 I32 i;
71be2cbc
PP
2222 if (clen) {
2223 Copy(c, m, clen, char);
2224 m += clen;
a0d0e21e 2225 }
71be2cbc
PP
2226 i = strend - d;
2227 if (i > 0) {
2228 Move(d, m, i, char);
2229 m += i;
a0d0e21e 2230 }
71be2cbc
PP
2231 *m = '\0';
2232 SvCUR_set(TARG, m - s);
2233 }
2ec7214c
DM
2234 else { /* faster from front */
2235 I32 i = m - s;
71be2cbc 2236 d -= clen;
2ec7214c
DM
2237 if (i > 0)
2238 Move(s, d - i, i, char);
71be2cbc 2239 sv_chop(TARG, d-i);
71be2cbc 2240 if (clen)
c947cd8d 2241 Copy(c, d, clen, char);
71be2cbc 2242 }
8ec5e241 2243 SPAGAIN;
8ca8a454 2244 PUSHs(&PL_sv_yes);
71be2cbc
PP
2245 }
2246 else {
c67ab8f2 2247 char *d, *m;
0395280b 2248 d = s = RX_OFFS(rx)[0].start + orig;
71be2cbc 2249 do {
2b25edcf 2250 I32 i;
5d9574c1 2251 if (UNLIKELY(iters++ > maxiters))
cea2e8a9 2252 DIE(aTHX_ "Substitution loop");
5d9574c1 2253 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
20be6587 2254 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2255 m = RX_OFFS(rx)[0].start + orig;
155aba94 2256 if ((i = m - s)) {
71be2cbc
PP
2257 if (s != d)
2258 Move(s, d, i, char);
2259 d += i;
a0d0e21e 2260 }
71be2cbc
PP
2261 if (clen) {
2262 Copy(c, d, clen, char);
2263 d += clen;
2264 }
07bc277f 2265 s = RX_OFFS(rx)[0].end + orig;
7ce41e5c
FC
2266 } while (CALLREGEXEC(rx, s, strend, orig,
2267 s == m, /* don't match same null twice */
f722798b 2268 TARG, NULL,
d5e7783a 2269 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
71be2cbc 2270 if (s != d) {
2b25edcf 2271 I32 i = strend - s;
aa07b2f6 2272 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 2273 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2274 }
8ec5e241 2275 SPAGAIN;
8ca8a454 2276 mPUSHi((I32)iters);
a0d0e21e
LW
2277 }
2278 }
ff6e92e8 2279 else {
1754320d 2280 bool first;
c67ab8f2 2281 char *m;
1754320d 2282 SV *repl;
a0d0e21e 2283 if (force_on_match) {
6ac6605d
DM
2284 /* redo the first match, this time with the orig var
2285 * forced into being a string */
a0d0e21e 2286 force_on_match = 0;
0c1438a1
NC
2287 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2288 /* I feel that it should be possible to avoid this mortal copy
2289 given that the code below copies into a new destination.
2290 However, I suspect it isn't worth the complexity of
2291 unravelling the C<goto force_it> for the small number of
2292 cases where it would be viable to drop into the copy code. */
2293 TARG = sv_2mortal(newSVsv(TARG));
2294 }
6ac6605d 2295 orig = SvPV_force_nomg(TARG, len);
a0d0e21e
LW
2296 goto force_it;
2297 }
db2c6cb3 2298#ifdef PERL_ANY_COW
ed252734
NC
2299 have_a_cow:
2300#endif
20be6587
DM
2301 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2302 rxtainted |= SUBST_TAINT_PAT;
1754320d 2303 repl = dstr;
0395280b
DM
2304 s = RX_OFFS(rx)[0].start + orig;
2305 dstr = newSVpvn_flags(orig, s-orig,
2306 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
a0d0e21e 2307 if (!c) {
eb578fdb 2308 PERL_CONTEXT *cx;
8ec5e241 2309 SPAGAIN;
0395280b 2310 m = orig;
20be6587
DM
2311 /* note that a whole bunch of local vars are saved here for
2312 * use by pp_substcont: here's a list of them in case you're
2313 * searching for places in this sub that uses a particular var:
2314 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2315 * s m strend rx once */
a0d0e21e 2316 PUSHSUBST(cx);
20e98b0f 2317 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
a0d0e21e 2318 }
1754320d 2319 first = TRUE;
a0d0e21e 2320 do {
5d9574c1 2321 if (UNLIKELY(iters++ > maxiters))
cea2e8a9 2322 DIE(aTHX_ "Substitution loop");
5d9574c1 2323 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
20be6587 2324 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2325 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
c67ab8f2
DM
2326 char *old_s = s;
2327 char *old_orig = orig;
6502e081 2328 assert(RX_SUBOFFSET(rx) == 0);
c67ab8f2 2329
07bc277f 2330 orig = RX_SUBBEG(rx);
c67ab8f2
DM
2331 s = orig + (old_s - old_orig);
2332 strend = s + (strend - old_s);
a0d0e21e 2333 }
07bc277f 2334 m = RX_OFFS(rx)[0].start + orig;
64534138 2335 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
07bc277f 2336 s = RX_OFFS(rx)[0].end + orig;
1754320d
FC
2337 if (first) {
2338 /* replacement already stringified */
2339 if (clen)
64534138 2340 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
1754320d
FC
2341 first = FALSE;
2342 }
2343 else {
1754320d
FC
2344 if (PL_encoding) {
2345 if (!nsv) nsv = sv_newmortal();
2346 sv_copypv(nsv, repl);
2347 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2348 sv_catsv(dstr, nsv);
2349 }
2350 else sv_catsv(dstr, repl);
5d9574c1 2351 if (UNLIKELY(SvTAINTED(repl)))
bb933b9b 2352 rxtainted |= SUBST_TAINT_REPL;
1754320d 2353 }
a0d0e21e
LW
2354 if (once)
2355 break;
f9f4320a 2356 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
d5e7783a
DM
2357 TARG, NULL,
2358 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
64534138 2359 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
748a9306 2360
8ca8a454
NC
2361 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2362 /* From here on down we're using the copy, and leaving the original
2363 untouched. */
2364 TARG = dstr;
2365 SPAGAIN;
2366 PUSHs(dstr);
2367 } else {
db2c6cb3 2368#ifdef PERL_ANY_COW
8ca8a454
NC
2369 /* The match may make the string COW. If so, brilliant, because
2370 that's just saved us one malloc, copy and free - the regexp has
2371 donated the old buffer, and we malloc an entirely new one, rather
2372 than the regexp malloc()ing a buffer and copying our original,
2373 only for us to throw it away here during the substitution. */
2374 if (SvIsCOW(TARG)) {
2375 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2376 } else
ed252734 2377#endif
8ca8a454
NC
2378 {
2379 SvPV_free(TARG);
2380 }
2381 SvPV_set(TARG, SvPVX(dstr));
2382 SvCUR_set(TARG, SvCUR(dstr));
2383 SvLEN_set(TARG, SvLEN(dstr));
64534138 2384 SvFLAGS(TARG) |= SvUTF8(dstr);
8ca8a454 2385 SvPV_set(dstr, NULL);
748a9306 2386
8ca8a454 2387 SPAGAIN;
4f4d7508 2388 mPUSHi((I32)iters);
8ca8a454
NC
2389 }
2390 }
2391
2392 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2393 (void)SvPOK_only_UTF8(TARG);
a0d0e21e 2394 }
20be6587 2395
ef07e810 2396 /* See "how taint works" above */
284167a5 2397 if (TAINTING_get) {
20be6587
DM
2398 if ((rxtainted & SUBST_TAINT_PAT) ||
2399 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2400 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2401 )
2402 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2403
2404 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2405 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2406 )
2407 SvTAINTED_on(TOPs); /* taint return value */
2408 else
2409 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2410
2411 /* needed for mg_set below */
284167a5
SM
2412 TAINT_set(
2413 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2414 );
20be6587
DM
2415 SvTAINT(TARG);
2416 }
2417 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2418 TAINT_NOT;
f1a76097
DM
2419 LEAVE_SCOPE(oldsave);
2420 RETURN;
a0d0e21e
LW
2421}
2422
2423PP(pp_grepwhile)
2424{
20b7effb 2425 dSP;
a0d0e21e
LW
2426
2427 if (SvTRUEx(POPs))
3280af22
NIS
2428 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2429 ++*PL_markstack_ptr;
b2a2a901 2430 FREETMPS;
d343c3ef 2431 LEAVE_with_name("grep_item"); /* exit inner scope */
a0d0e21e
LW
2432
2433 /* All done yet? */
5d9574c1 2434 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
a0d0e21e 2435 I32 items;
c4420975 2436 const I32 gimme = GIMME_V;
a0d0e21e 2437
d343c3ef 2438 LEAVE_with_name("grep"); /* exit outer scope */
a0d0e21e 2439 (void)POPMARK; /* pop src */
3280af22 2440 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2441 (void)POPMARK; /* pop dst */
3280af22 2442 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2443 if (gimme == G_SCALAR) {
7cc47870 2444 if (PL_op->op_private & OPpGREP_LEX) {
c4420975 2445 SV* const sv = sv_newmortal();
7cc47870
RGS
2446 sv_setiv(sv, items);
2447 PUSHs(sv);
2448 }
2449 else {
2450 dTARGET;
2451 XPUSHi(items);
2452 }
a0d0e21e 2453 }
54310121
PP
2454 else if (gimme == G_ARRAY)
2455 SP += items;
a0d0e21e
LW
2456 RETURN;
2457 }
2458 else {
2459 SV *src;
2460
d343c3ef 2461 ENTER_with_name("grep_item"); /* enter inner scope */
1d7c1841 2462 SAVEVPTR(PL_curpm);
a0d0e21e 2463
3280af22 2464 src = PL_stack_base[*PL_markstack_ptr];
60779a30 2465 if (SvPADTMP(src)) {
a0ed822e
FC
2466 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2467 PL_tmps_floor++;
2468 }
a0d0e21e 2469 SvTEMP_off(src);
59f00321
RGS
2470 if (PL_op->op_private & OPpGREP_LEX)
2471 PAD_SVl(PL_op->op_targ) = src;
2472 else
414bf5ae 2473 DEFSV_set(src);
a0d0e21e
LW
2474
2475 RETURNOP(cLOGOP->op_other);
2476 }
2477}
2478
2479PP(pp_leavesub)
2480{
20b7effb 2481 dSP;
a0d0e21e
LW
2482 SV **mark;
2483 SV **newsp;
2484 PMOP *newpm;
2485 I32 gimme;
eb578fdb 2486 PERL_CONTEXT *cx;
b0d9ce38 2487 SV *sv;
a0d0e21e 2488
9850bf21
RH
2489 if (CxMULTICALL(&cxstack[cxstack_ix]))
2490 return 0;
2491
a0d0e21e 2492 POPBLOCK(cx,newpm);
5dd42e15 2493 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2494
a1f49e72 2495 TAINT_NOT;
a0d0e21e
LW
2496 if (gimme == G_SCALAR) {
2497 MARK = newsp + 1;
5d9574c1 2498 if (LIKELY(MARK <= SP)) {
a8bba7fa 2499 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
6f48390a
FC
2500 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2501 && !SvMAGICAL(TOPs)) {
a29cdaf0
IZ
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 2509 *MARK = sv_mortalcopy(sv);
fc2b2dca 2510 SvREFCNT_dec_NN(sv);
a29cdaf0 2511 }
cd06dffe 2512 }
6f48390a
FC
2513 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2514 && !SvMAGICAL(TOPs)) {
767eda44 2515 *MARK = TOPs;
767eda44 2516 }
cd06dffe 2517 else
767eda44 2518 *MARK = sv_mortalcopy(TOPs);
cd06dffe
GS
2519 }
2520 else {
f86702cc 2521 MEXTEND(MARK, 0);
3280af22 2522 *MARK = &PL_sv_undef;
a0d0e21e
LW
2523 }
2524 SP = MARK;
2525 }
54310121 2526 else if (gimme == G_ARRAY) {
f86702cc 2527 for (MARK = newsp + 1; MARK <= SP; MARK++) {
6f48390a
FC
2528 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2529 || SvMAGICAL(*MARK)) {
f86702cc 2530 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2531 TAINT_NOT; /* Each item is independent */
2532 }
f86702cc 2533 }
a0d0e21e 2534 }
f86702cc 2535 PUTBACK;
1c846c1f 2536
a57c6685 2537 LEAVE;
b0d9ce38 2538 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
25375124 2539 cxstack_ix--;
3280af22 2540 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2541
b0d9ce38 2542 LEAVESUB(sv);
f39bc417 2543 return cx->blk_sub.retop;
a0d0e21e
LW
2544}
2545
2546PP(pp_entersub)
2547{
20b7effb 2548 dSP; dPOPss;
a0d0e21e 2549 GV *gv;
eb578fdb
KW
2550 CV *cv;
2551 PERL_CONTEXT *cx;
5d94fbed 2552 I32 gimme;
a9c4fd4e 2553 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e 2554
f5719c02 2555 if (UNLIKELY(!sv))
cea2e8a9 2556 DIE(aTHX_ "Not a CODE reference");
f5719c02
DM
2557 /* This is overwhelmingly the most common case: */
2558 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
313107ce
DM
2559 switch (SvTYPE(sv)) {
2560 case SVt_PVGV:
2561 we_have_a_glob:
2562 if (!(cv = GvCVu((const GV *)sv))) {
2563 HV *stash;
2564 cv = sv_2cv(sv, &stash, &gv, 0);
2565 }
2566 if (!cv) {
2567 ENTER;
2568 SAVETMPS;
2569 goto try_autoload;
2570 }
2571 break;
2572 case SVt_PVLV:
2573 if(isGV_with_GP(sv)) goto we_have_a_glob;
924ba076 2574 /* FALLTHROUGH */
313107ce
DM
2575 default:
2576 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2577 if (hasargs)
2578 SP = PL_stack_base + POPMARK;
2579 else
2580 (void)POPMARK;
2581 RETURN;
2582 }
2583 SvGETMAGIC(sv);
2584 if (SvROK(sv)) {
2585 if (SvAMAGIC(sv)) {
2586 sv = amagic_deref_call(sv, to_cv_amg);
2587 /* Don't SPAGAIN here. */
2588 }
2589 }
2590 else {
2591 const char *sym;
2592 STRLEN len;
2593 if (!SvOK(sv))
2594 DIE(aTHX_ PL_no_usym, "a subroutine");
2595 sym = SvPV_nomg_const(sv, len);
2596 if (PL_op->op_private & HINT_STRICT_REFS)
2597 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2598 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2599 break;
2600 }
2601 cv = MUTABLE_CV(SvRV(sv));
2602 if (SvTYPE(cv) == SVt_PVCV)
2603 break;
924ba076 2604 /* FALLTHROUGH */
313107ce
DM
2605 case SVt_PVHV:
2606 case SVt_PVAV:
2607 DIE(aTHX_ "Not a CODE reference");
2608 /* This is the second most common case: */
2609 case SVt_PVCV:
2610 cv = MUTABLE_CV(sv);
2611 break;
2612 }
f5719c02 2613 }
a0d0e21e 2614
a57c6685 2615 ENTER;
a0d0e21e
LW
2616
2617 retry:
f5719c02 2618 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
541ed3a9 2619 DIE(aTHX_ "Closure prototype called");
f5719c02 2620 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
2f349aa0
NC
2621 GV* autogv;
2622 SV* sub_name;
2623
2624 /* anonymous or undef'd function leaves us no recourse */
ae77754a
FC
2625 if (CvLEXICAL(cv) && CvHASGV(cv))
2626 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
ecf05a58 2627 SVfARG(cv_name(cv, NULL, 0)));
ae77754a 2628 if (CvANON(cv) || !CvHASGV(cv)) {
2f349aa0 2629 DIE(aTHX_ "Undefined subroutine called");
7d2057d8 2630 }
2f349aa0
NC
2631
2632 /* autoloaded stub? */
ae77754a 2633 if (cv != GvCV(gv = CvGV(cv))) {
2f349aa0
NC
2634 cv = GvCV(gv);
2635 }
2636 /* should call AUTOLOAD now? */
2637 else {
7e623da3 2638try_autoload:
d1089224
BF
2639 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2640 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2f349aa0
NC
2641 {
2642 cv = GvCV(autogv);
2643 }
2f349aa0 2644 else {
c220e1a1 2645 sorry:
2f349aa0 2646 sub_name = sv_newmortal();
6136c704 2647 gv_efullname3(sub_name, gv, NULL);
be2597df 2648 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2f349aa0
NC
2649 }
2650 }
2651 if (!cv)
c220e1a1 2652 goto sorry;
2f349aa0 2653 goto retry;
a0d0e21e
LW
2654 }
2655
f5719c02
DM
2656 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
2657 && !CvNODEBUG(cv)))
2658 {
005a8a35 2659 Perl_get_db_sub(aTHX_ &sv, cv);
a9ef256d
NC
2660 if (CvISXSUB(cv))
2661 PL_curcopdb = PL_curcop;
1ad62f64 2662 if (CvLVALUE(cv)) {
2663 /* check for lsub that handles lvalue subroutines */
07b605e5 2664 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
1ad62f64 2665 /* if lsub not found then fall back to DB::sub */
2666 if (!cv) cv = GvCV(PL_DBsub);
2667 } else {
2668 cv = GvCV(PL_DBsub);
2669 }
a9ef256d 2670
ccafdc96
RGS
2671 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2672 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2673 }
a0d0e21e 2674
f5719c02
DM
2675 gimme = GIMME_V;
2676
aed2304a 2677 if (!(CvISXSUB(cv))) {
f1025168 2678 /* This path taken at least 75% of the time */
a0d0e21e 2679 dMARK;
b70d5558 2680 PADLIST * const padlist = CvPADLIST(cv);
3689ad62 2681 I32 depth;
f5719c02 2682
a0d0e21e
LW
2683 PUSHBLOCK(cx, CXt_SUB, MARK);
2684 PUSHSUB(cx);
f39bc417 2685 cx->blk_sub.retop = PL_op->op_next;
3689ad62 2686 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3a76ca88 2687 PERL_STACK_OVERFLOW_CHECK();
3689ad62 2688 pad_push(padlist, depth);
a0d0e21e 2689 }
3a76ca88 2690 SAVECOMPPAD();
3689ad62 2691 PAD_SET_CUR_NOSAVE(padlist, depth);
f5719c02 2692 if (LIKELY(hasargs)) {
10533ace 2693 AV *const av = MUTABLE_AV(PAD_SVl(0));
bdf02c57
DM
2694 SSize_t items;
2695 AV **defavp;
2696
f5719c02 2697 if (UNLIKELY(AvREAL(av))) {
221373f0
GS
2698 /* @_ is normally not REAL--this should only ever
2699 * happen when DB::sub() calls things that modify @_ */
2700 av_clear(av);
2701 AvREAL_off(av);
2702 AvREIFY_on(av);
2703 }
bdf02c57
DM
2704 defavp = &GvAV(PL_defgv);
2705 cx->blk_sub.savearray = *defavp;
2706 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
dd2155a4 2707 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2708 cx->blk_sub.argarray = av;
bdf02c57 2709 items = SP - MARK;
a0d0e21e 2710
f5719c02 2711 if (UNLIKELY(items - 1 > AvMAX(av))) {
77d27ef6
SF
2712 SV **ary = AvALLOC(av);
2713 AvMAX(av) = items - 1;
2714 Renew(ary, items, SV*);
2715 AvALLOC(av) = ary;
2716 AvARRAY(av) = ary;
2717 }
2718
bdf02c57 2719 Copy(MARK+1,AvARRAY(av),items,SV*);
93965878 2720 AvFILLp(av) = items - 1;
1c846c1f 2721
b479c9f2 2722 MARK = AvARRAY(av);
a0d0e21e
LW
2723 while (items--) {
2724 if (*MARK)
b479c9f2 2725 {
60779a30 2726 if (SvPADTMP(*MARK)) {
b479c9f2 2727 *MARK = sv_mortalcopy(*MARK);
60779a30 2728 }
a0d0e21e 2729 SvTEMP_off(*MARK);
b479c9f2 2730 }
a0d0e21e
LW
2731 MARK++;
2732 }
2733 }
b479c9f2 2734 SAVETMPS;
f5719c02
DM
2735 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2736 !CvLVALUE(cv)))
da1dff94 2737 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
4a925ff6
GS
2738 /* warning must come *after* we fully set up the context
2739 * stuff so that __WARN__ handlers can safely dounwind()
2740 * if they want to
2741 */
3689ad62 2742 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
f5719c02
DM
2743 && ckWARN(WARN_RECURSION)
2744 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
4a925ff6 2745 sub_crush_depth(cv);
a0d0e21e
LW
2746 RETURNOP(CvSTART(cv));
2747 }
f1025168 2748 else {
de935cc9 2749 SSize_t markix = TOPMARK;
f1025168 2750
b479c9f2 2751 SAVETMPS;
3a76ca88 2752 PUTBACK;
f1025168 2753
f5719c02 2754 if (UNLIKELY(((PL_op->op_private
4587c532
FC
2755 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2756 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
f5719c02 2757 !CvLVALUE(cv)))
4587c532
FC
2758 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2759
f5719c02 2760 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3a76ca88
RGS
2761 /* Need to copy @_ to stack. Alternative may be to
2762 * switch stack to @_, and copy return values
2763 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2764 AV * const av = GvAV(PL_defgv);
ad39f3a2 2765 const SSize_t items = AvFILL(av) + 1;
3a76ca88
RGS
2766
2767 if (items) {
dd2a7f90 2768 SSize_t i = 0;
ad39f3a2 2769 const bool m = cBOOL(SvRMAGICAL(av));
3a76ca88
RGS
2770 /* Mark is at the end of the stack. */
2771 EXTEND(SP, items);
dd2a7f90 2772 for (; i < items; ++i)
ad39f3a2
FC
2773 {
2774 SV *sv;
2775 if (m) {
2776 SV ** const svp = av_fetch(av, i, 0);
2777 sv = svp ? *svp : NULL;
2778 }
2779 else sv = AvARRAY(av)[i];
2780 if (sv) SP[i+1] = sv;
dd2a7f90 2781 else {
199f858d 2782 SP[i+1] = newSVavdefelem(av, i, 1);
dd2a7f90 2783 }
ad39f3a2 2784 }
3a76ca88
RGS
2785 SP += items;
2786 PUTBACK ;
2787 }
2788 }
3455055f
FC
2789 else {
2790 SV **mark = PL_stack_base + markix;
de935cc9 2791 SSize_t items = SP - mark;
3455055f
FC
2792 while (items--) {
2793 mark++;
60779a30 2794 if (*mark && SvPADTMP(*mark)) {
3455055f 2795 *mark = sv_mortalcopy(*mark);
60779a30 2796 }
3455055f
FC
2797 }
2798 }
3a76ca88 2799 /* We assume first XSUB in &DB::sub is the called one. */
f5719c02 2800 if (UNLIKELY(PL_curcopdb)) {
3a76ca88
RGS
2801 SAVEVPTR(PL_curcop);
2802 PL_curcop = PL_curcopdb;
2803 PL_curcopdb = NULL;
2804 }
2805 /* Do we need to open block here? XXXX */
72df79cf 2806
2807 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2808 assert(CvXSUB(cv));
16c91539 2809 CvXSUB(cv)(aTHX_ cv);
3a76ca88
RGS
2810
2811 /* Enforce some sanity in scalar context. */
89a18b40
DM
2812 if (gimme == G_SCALAR) {
2813 SV **svp = PL_stack_base + markix + 1;
2814 if (svp != PL_stack_sp) {
2815 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
2816 PL_stack_sp = svp;
2817 }
3a76ca88 2818 }
a57c6685 2819 LEAVE;
f1025168
NC
2820 return NORMAL;
2821 }
a0d0e21e
LW
2822}
2823
44a8e56a 2824void
864dbfa3 2825Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 2826{
7918f24d
NC
2827 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2828
44a8e56a 2829 if (CvANON(cv))
9014280d 2830 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 2831 else {
35c1215d 2832 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
ecf05a58 2833 SVfARG(cv_name(cv,NULL,0)));
44a8e56a
PP
2834 }
2835}
2836
a0d0e21e
LW
2837PP(pp_aelem)
2838{
20b7effb 2839 dSP;
a0d0e21e 2840 SV** svp;
a3b680e6 2841 SV* const elemsv = POPs;
d804643f 2842 IV elem = SvIV(elemsv);
502c6561 2843 AV *const av = MUTABLE_AV(POPs);
e1ec3a88 2844 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
bbfdc870 2845 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4ad10a0b
VP
2846 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2847 bool preeminent = TRUE;
be6c24e0 2848 SV *sv;
a0d0e21e 2849
5d9574c1 2850 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
95b63a38
JH
2851 Perl_warner(aTHX_ packWARN(WARN_MISC),
2852 "Use of reference \"%"SVf"\" as array index",
be2597df 2853 SVfARG(elemsv));
5d9574c1 2854 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
a0d0e21e 2855 RETPUSHUNDEF;
4ad10a0b 2856
5d9574c1 2857 if (UNLIKELY(localizing)) {
4ad10a0b
VP
2858 MAGIC *mg;
2859 HV *stash;
2860
2861 /* If we can determine whether the element exist,
2862 * Try to preserve the existenceness of a tied array
2863 * element by using EXISTS and DELETE if possible.
2864 * Fallback to FETCH and STORE otherwise. */
2865 if (SvCANEXISTDELETE(av))
2866 preeminent = av_exists(av, elem);
2867 }
2868
68dc0745 2869 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2870 if (lval) {
2b573ace 2871#ifdef PERL_MALLOC_WRAP
2b573ace 2872 if (SvUOK(elemsv)) {
a9c4fd4e 2873 const UV uv = SvUV(elemsv);
2b573ace
JH
2874 elem = uv > IV_MAX ? IV_MAX : uv;
2875 }
2876 else if (SvNOK(elemsv))
2877 elem = (IV)SvNV(elemsv);
a3b680e6
AL
2878 if (elem > 0) {
2879 static const char oom_array_extend[] =
2880 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 2881 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 2882 }
2b573ace 2883#endif
ce0d59fd 2884 if (!svp || !*svp) {
bbfdc870 2885 IV len;
68dc0745 2886 if (!defer)
cea2e8a9 2887 DIE(aTHX_ PL_no_aelem, elem);
b9f2b683 2888 len = av_tindex(av);
199f858d 2889 mPUSHs(newSVavdefelem(av,
bbfdc870
FC
2890 /* Resolve a negative index now, unless it points before the
2891 beginning of the array, in which case record it for error
2892 reporting in magic_setdefelem. */
199f858d
FC
2893 elem < 0 && len + elem >= 0 ? len + elem : elem,
2894 1));
68dc0745
PP
2895 RETURN;
2896 }
5d9574c1 2897 if (UNLIKELY(localizing)) {
4ad10a0b
VP
2898 if (preeminent)
2899 save_aelem(av, elem, svp);
2900 else
2901 SAVEADELETE(av, elem);
2902 }
9026059d
GG
2903 else if (PL_op->op_private & OPpDEREF) {
2904 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2905 RETURN;
2906 }
a0d0e21e 2907 }
3280af22 2908 sv = (svp ? *svp : &PL_sv_undef);
39cf747a 2909 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 2910 mg_get(sv);
be6c24e0 2911 PUSHs(sv);
a0d0e21e
LW
2912 RETURN;
2913}
2914
9026059d 2915SV*
864dbfa3 2916Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 2917{
7918f24d
NC
2918 PERL_ARGS_ASSERT_VIVIFY_REF;
2919
5b295bef 2920 SvGETMAGIC(sv);
02a9e968
CS
2921 if (!SvOK(sv)) {
2922 if (SvREADONLY(sv))
cb077ed2 2923 Perl_croak_no_modify();
43230e26 2924 prepare_SV_for_RV(sv);
68dc0745 2925 switch (to_what) {
5f05dabc 2926 case OPpDEREF_SV:
561b68a9 2927 SvRV_set(sv, newSV(0));
5f05dabc
PP
2928 break;
2929 case OPpDEREF_AV:
ad64d0ec 2930 SvRV_set(sv, MUTABLE_SV(newAV()));
5f05dabc
PP
2931 break;
2932 case OPpDEREF_HV:
ad64d0ec 2933 SvRV_set(sv, MUTABLE_SV(newHV()));
5f05dabc
PP
2934 break;
2935 }
02a9e968
CS
2936 SvROK_on(sv);
2937 SvSETMAGIC(sv);
7e482323 2938 SvGETMAGIC(sv);
02a9e968 2939 }
9026059d
GG
2940 if (SvGMAGICAL(sv)) {
2941 /* copy the sv without magic to prevent magic from being
2942 executed twice */
2943 SV* msv = sv_newmortal();
2944 sv_setsv_nomg(msv, sv);
2945 return msv;
2946 }
2947 return sv;
02a9e968
CS
2948}
2949
a0d0e21e
LW
2950PP(pp_method)
2951{
20b7effb 2952 dSP;
890ce7af 2953 SV* const sv = TOPs;
f5d5a27c
CS
2954
2955 if (SvROK(sv)) {
890ce7af 2956 SV* const rsv = SvRV(sv);
f5d5a27c
CS
2957 if (SvTYPE(rsv) == SVt_PVCV) {
2958 SETs(rsv);
2959 RETURN;
2960 }
2961 }
2962
4608196e 2963 SETs(method_common(sv, NULL));
f5d5a27c
CS
2964 RETURN;
2965}
2966
2967PP(pp_method_named)
2968{
20b7effb 2969 dSP;
890ce7af 2970 SV* const sv = cSVOP_sv;
c158a4fd 2971 U32 hash = SvSHARED_HASH(sv);
f5d5a27c
CS
2972
2973 XPUSHs(method_common(sv, &hash));
2974 RETURN;
2975}
2976
2977STATIC SV *
2978S_method_common(pTHX_ SV* meth, U32* hashp)
2979{
a0d0e21e
LW
2980 SV* ob;
2981 GV* gv;
56304f61 2982 HV* stash;
a0714e2c 2983 SV *packsv = NULL;
f226e9be
FC
2984 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2985 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2986 "package or object reference", SVfARG(meth)),
2987 (SV *)NULL)
2988 : *(PL_stack_base + TOPMARK + 1);
f5d5a27c 2989
7918f24d
NC
2990 PERL_ARGS_ASSERT_METHOD_COMMON;
2991
5d9574c1 2992 if (UNLIKELY(!sv))
7156e69a 2993 undefined:
a214957f
VP
2994 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2995 SVfARG(meth));
4f1b7578 2996
5b295bef 2997 SvGETMAGIC(sv);
a0d0e21e 2998 if (SvROK(sv))
ad64d0ec 2999 ob = MUTABLE_SV(SvRV(sv));
7156e69a 3000 else if (!SvOK(sv)) goto undefined;
a77c16f7
FC
3001 else if (isGV_with_GP(sv)) {
3002 if (!GvIO(sv))
3003 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3004 "without a package or object reference",
3005 SVfARG(meth));
3006 ob = sv;
3007 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3008 assert(!LvTARGLEN(ob));
3009 ob = LvTARG(ob);
3010 assert(ob);
3011 }
3012 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3013 }
a0d0e21e 3014 else {
89269094 3015 /* this isn't a reference */
a0d0e21e 3016 GV* iogv;
f937af42 3017 STRLEN packlen;
89269094 3018 const char * const packname = SvPV_nomg_const(sv, packlen);
d283e876 3019 const U32 packname_utf8 = SvUTF8(sv);
3020 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3021 if (stash) goto fetch;
081fc587 3022
89269094 3023 if (!(iogv = gv_fetchpvn_flags(
d283e876 3024 packname, packlen, packname_utf8, SVt_PVIO
da6b625f 3025 )) ||
ad64d0ec 3026 !(ob=MUTABLE_SV(GvIO(iogv))))
a0d0e21e 3027 {
af09ea45 3028 /* this isn't the name of a filehandle either */
89269094 3029 if (!packlen)
834a4ddd 3030 {
7156e69a
FC
3031 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3032 "without a package or object reference",
3033 SVfARG(meth));
834a4ddd 3034 }
af09ea45 3035 /* assume it's a package name */
d283e876 3036 stash = gv_stashpvn(packname, packlen, packname_utf8);
3037 if (!stash) packsv = sv;
ac91690f 3038 goto fetch;
a0d0e21e 3039 }
af09ea45 3040 /* it _is_ a filehandle name -- replace with a reference */
ad64d0ec 3041 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
a0d0e21e
LW
3042 }
3043
1f3ffe4c 3044 /* if we got here, ob should be an object or a glob */
f0d43078 3045 if (!ob || !(SvOBJECT(ob)
a77c16f7 3046 || (isGV_with_GP(ob)
159b6efe 3047 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
f0d43078
GS
3048 && SvOBJECT(ob))))
3049 {
b375e37b
BF
3050 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3051 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3052 ? newSVpvs_flags("DOES", SVs_TEMP)
3053 : meth));
f0d43078 3054 }
a0d0e21e 3055
56304f61 3056 stash = SvSTASH(ob);
a0d0e21e 3057
ac91690f 3058 fetch:
af09ea45
IK
3059 /* NOTE: stash may be null, hope hv_fetch_ent and
3060 gv_fetchmethod can cope (it seems they can) */
3061
f5d5a27c
CS
3062 /* shortcut for simple names */
3063 if (hashp) {
b464bac0 3064 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
f5d5a27c 3065 if (he) {
159b6efe 3066 gv = MUTABLE_GV(HeVAL(he));
316ebaf2 3067 assert(stash);
f5d5a27c 3068 if (isGV(gv) && GvCV(gv) &&
e1a479c5 3069 (!GvCVGEN(gv) || GvCVGEN(gv)
dd69841b 3070 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
ad64d0ec 3071 return MUTABLE_SV(GvCV(gv));
f5d5a27c
CS
3072 }
3073 }
3074
316ebaf2 3075 assert(stash || packsv);
f937af42 3076 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
316ebaf2 3077 meth, GV_AUTOLOAD | GV_CROAK);
256d1bb2 3078 assert(gv);
9b9d0b15 3079
ad64d0ec 3080 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
a0d0e21e 3081}
241d1a3b
NC
3082
3083/*
3084 * Local variables:
3085 * c-indentation-style: bsd
3086 * c-basic-offset: 4
14d04a33 3087 * indent-tabs-mode: nil
241d1a3b
NC
3088 * End:
3089 *
14d04a33 3090 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3091 */