This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add UNOP_AUX OP class
[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);
6d59e610 389 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
4e09461c 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() */
bdaf10a5 889/* also called directly by pp_lvavref */
b1c05ba5 890
a0d0e21e
LW
891PP(pp_rv2av)
892{
20b7effb 893 dSP; dTOPss;
cde874ca 894 const I32 gimme = GIMME_V;
17ab7946
NC
895 static const char an_array[] = "an ARRAY";
896 static const char a_hash[] = "a HASH";
bdaf10a5
FC
897 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
898 || PL_op->op_type == OP_LVAVREF;
d83b45b8 899 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 900
9026059d 901 SvGETMAGIC(sv);
a0d0e21e 902 if (SvROK(sv)) {
5d9574c1 903 if (UNLIKELY(SvAMAGIC(sv))) {
93d7320b 904 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
93d7320b 905 }
17ab7946 906 sv = SvRV(sv);
5d9574c1 907 if (UNLIKELY(SvTYPE(sv) != type))
dcbac5bb 908 /* diag_listed_as: Not an ARRAY reference */
17ab7946 909 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
5d9574c1
DM
910 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
911 && PL_op->op_private & OPpLVAL_INTRO))
3da99855 912 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e 913 }
5d9574c1 914 else if (UNLIKELY(SvTYPE(sv) != type)) {
67955e0c 915 GV *gv;
1c846c1f 916
6e592b3a 917 if (!isGV_with_GP(sv)) {
dc3c76f8
NC
918 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
919 type, &sp);
920 if (!gv)
921 RETURN;
35cd451c
GS
922 }
923 else {
159b6efe 924 gv = MUTABLE_GV(sv);
a0d0e21e 925 }
ad64d0ec 926 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 927 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 928 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
9f527363
FC
929 }
930 if (PL_op->op_flags & OPf_REF) {
17ab7946 931 SETs(sv);
a0d0e21e 932 RETURN;
9f527363 933 }
5d9574c1 934 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
40c94d11
FC
935 const I32 flags = is_lvalue_sub();
936 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 937 if (gimme != G_ARRAY)
042560a6 938 goto croak_cant_return;
17ab7946 939 SETs(sv);
78f9721b 940 RETURN;
40c94d11 941 }
a0d0e21e
LW
942 }
943
17ab7946 944 if (is_pp_rv2av) {
502c6561 945 AV *const av = MUTABLE_AV(sv);
636fe681 946 /* The guts of pp_rv2av */
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)) {
bdaf10a5 1074 bool alias = FALSE;
bbce6d69 1075 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e 1076 sv = *lelem++;
bdaf10a5
FC
1077 if (UNLIKELY(!sv)) {
1078 alias = TRUE;
1079 sv = *lelem++;
1080 ASSUME(SvTYPE(sv) == SVt_PVAV);
1081 }
a0d0e21e
LW
1082 switch (SvTYPE(sv)) {
1083 case SVt_PVAV:
60edcf09 1084 ary = MUTABLE_AV(sv);
748a9306 1085 magic = SvMAGICAL(ary) != 0;
60edcf09
FC
1086 ENTER;
1087 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1088 av_clear(ary);
7e42bd57 1089 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
1090 i = 0;
1091 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 1092 SV **didstore;
5d9574c1 1093 if (LIKELY(*relem))
ce0d59fd 1094 SvGETMAGIC(*relem); /* before newSV, in case it dies */
bdaf10a5
FC
1095 if (LIKELY(!alias)) {
1096 sv = newSV(0);
1097 sv_setsv_nomg(sv, *relem);
1098 *relem = sv;
1099 }
1100 else {
1101 if (!SvROK(*relem))
1102 DIE(aTHX_ "Assigned value is not a reference");
1103 if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1104 /* diag_listed_as: Assigned value is not %s reference */
1105 DIE(aTHX_
1106 "Assigned value is not a SCALAR reference");
1107 if (lval)
1108 *relem = sv_mortalcopy(*relem);
1109 /* XXX else check for weak refs? */
1110 sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1111 }
1112 relem++;
5117ca91
GS
1113 didstore = av_store(ary,i++,sv);
1114 if (magic) {
18024492
FC
1115 if (!didstore)
1116 sv_2mortal(sv);
8ef24240 1117 if (SvSMAGICAL(sv))
fb73857a 1118 mg_set(sv);
5117ca91 1119 }
bbce6d69 1120 TAINT_NOT;
a0d0e21e 1121 }
5d9574c1 1122 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
ad64d0ec 1123 SvSETMAGIC(MUTABLE_SV(ary));
60edcf09 1124 LEAVE;
a0d0e21e 1125 break;
10c8fecd 1126 case SVt_PVHV: { /* normal hash */
a0d0e21e 1127 SV *tmpstr;
1c4ea384
RZ
1128 int odd;
1129 int duplicates = 0;
45960564 1130 SV** topelem = relem;
1c4ea384 1131 SV **firsthashrelem = relem;
a0d0e21e 1132
60edcf09 1133 hash = MUTABLE_HV(sv);
748a9306 1134 magic = SvMAGICAL(hash) != 0;
1c4ea384
RZ
1135
1136 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
5d9574c1 1137 if (UNLIKELY(odd)) {
fb8f4cf8 1138 do_oddball(lastrelem, firsthashrelem);
1d2b3927
HS
1139 /* we have firstlelem to reuse, it's not needed anymore
1140 */
1c4ea384
RZ
1141 *(lastrelem+1) = &PL_sv_undef;
1142 }
1143
60edcf09
FC
1144 ENTER;
1145 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1146 hv_clear(hash);
5d9574c1 1147 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
5117ca91 1148 HE *didstore;
1c4ea384 1149 assert(*relem);
632b9d6f
FC
1150 /* Copy the key if aassign is called in lvalue context,
1151 to avoid having the next op modify our rhs. Copy
1152 it also if it is gmagical, lest it make the
1153 hv_store_ent call below croak, leaking the value. */
1154 sv = lval || SvGMAGICAL(*relem)
1155 ? sv_mortalcopy(*relem)
1156 : *relem;
45960564 1157 relem++;
1c4ea384 1158 assert(*relem);
632b9d6f
FC
1159 SvGETMAGIC(*relem);
1160 tmpstr = newSV(0);
1161 sv_setsv_nomg(tmpstr,*relem++); /* value */
a88bf2bc 1162 if (gimme == G_ARRAY) {
45960564
DM
1163 if (hv_exists_ent(hash, sv, 0))
1164 /* key overwrites an existing entry */
1165 duplicates += 2;
a88bf2bc 1166 else {
45960564 1167 /* copy element back: possibly to an earlier
1d2b3927
HS
1168 * stack location if we encountered dups earlier,
1169 * possibly to a later stack location if odd */
45960564
DM
1170 *topelem++ = sv;
1171 *topelem++ = tmpstr;
1172 }
1173 }
5117ca91 1174 didstore = hv_store_ent(hash,sv,tmpstr,0);
632b9d6f
FC
1175 if (magic) {
1176 if (!didstore) sv_2mortal(tmpstr);
1177 SvSETMAGIC(tmpstr);
1178 }
bbce6d69 1179 TAINT_NOT;
8e07c86e 1180 }
60edcf09 1181 LEAVE;
1c4ea384
RZ
1182 if (duplicates && gimme == G_ARRAY) {
1183 /* at this point we have removed the duplicate key/value
1184 * pairs from the stack, but the remaining values may be
1185 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1186 * the (a 2), but the stack now probably contains
1187 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1188 * obliterates the earlier key. So refresh all values. */
1189 lastrelem -= duplicates;
1190 relem = firsthashrelem;
1191 while (relem < lastrelem+odd) {
1192 HE *he;
1193 he = hv_fetch_ent(hash, *relem++, 0, 0);
1194 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1195 }
1196 }
1197 if (odd && gimme == G_ARRAY) lastrelem++;
a0d0e21e
LW
1198 }
1199 break;
1200 default:
6fc92669
GS
1201 if (SvIMMORTAL(sv)) {
1202 if (relem <= lastrelem)
1203 relem++;
1204 break;
a0d0e21e
LW
1205 }
1206 if (relem <= lastrelem) {
5d9574c1 1207 if (UNLIKELY(
1c70fb82
FC
1208 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1209 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
5d9574c1 1210 ))
1c70fb82
FC
1211 Perl_warner(aTHX_
1212 packWARN(WARN_MISC),
1213 "Useless assignment to a temporary"
1214 );
a0d0e21e
LW
1215 sv_setsv(sv, *relem);
1216 *(relem++) = sv;
1217 }
1218 else
3280af22 1219 sv_setsv(sv, &PL_sv_undef);
8ef24240 1220 SvSETMAGIC(sv);
a0d0e21e
LW
1221 break;
1222 }
1223 }
5d9574c1 1224 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
985213f2 1225 /* Will be used to set PL_tainting below */
dfff4baf
BF
1226 Uid_t tmp_uid = PerlProc_getuid();
1227 Uid_t tmp_euid = PerlProc_geteuid();
1228 Gid_t tmp_gid = PerlProc_getgid();
1229 Gid_t tmp_egid = PerlProc_getegid();
985213f2 1230
b469f1e0 1231 /* XXX $> et al currently silently ignore failures */
3280af22 1232 if (PL_delaymagic & DM_UID) {
a0d0e21e 1233#ifdef HAS_SETRESUID
b469f1e0
JH
1234 PERL_UNUSED_RESULT(
1235 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1236 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1237 (Uid_t)-1));
56febc5e
AD
1238#else
1239# ifdef HAS_SETREUID
b469f1e0
JH
1240 PERL_UNUSED_RESULT(
1241 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1242 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
56febc5e
AD
1243# else
1244# ifdef HAS_SETRUID
b28d0864 1245 if ((PL_delaymagic & DM_UID) == DM_RUID) {
b469f1e0 1246 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
b28d0864 1247 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1248 }
56febc5e
AD
1249# endif /* HAS_SETRUID */
1250# ifdef HAS_SETEUID
b28d0864 1251 if ((PL_delaymagic & DM_UID) == DM_EUID) {
b469f1e0 1252 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
b28d0864 1253 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1254 }
56febc5e 1255# endif /* HAS_SETEUID */
b28d0864 1256 if (PL_delaymagic & DM_UID) {
985213f2 1257 if (PL_delaymagic_uid != PL_delaymagic_euid)
cea2e8a9 1258 DIE(aTHX_ "No setreuid available");
b469f1e0 1259 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
a0d0e21e 1260 }
56febc5e
AD
1261# endif /* HAS_SETREUID */
1262#endif /* HAS_SETRESUID */
04783dc7 1263
985213f2
AB
1264 tmp_uid = PerlProc_getuid();
1265 tmp_euid = PerlProc_geteuid();
a0d0e21e 1266 }
b469f1e0 1267 /* XXX $> et al currently silently ignore failures */
3280af22 1268 if (PL_delaymagic & DM_GID) {
a0d0e21e 1269#ifdef HAS_SETRESGID
b469f1e0
JH
1270 PERL_UNUSED_RESULT(
1271 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1272 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1273 (Gid_t)-1));
56febc5e
AD
1274#else
1275# ifdef HAS_SETREGID
b469f1e0
JH
1276 PERL_UNUSED_RESULT(
1277 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1278 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
56febc5e
AD
1279# else
1280# ifdef HAS_SETRGID
b28d0864 1281 if ((PL_delaymagic & DM_GID) == DM_RGID) {
b469f1e0 1282 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
b28d0864 1283 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1284 }
56febc5e
AD
1285# endif /* HAS_SETRGID */
1286# ifdef HAS_SETEGID
b28d0864 1287 if ((PL_delaymagic & DM_GID) == DM_EGID) {
b469f1e0 1288 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
b28d0864 1289 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1290 }
56febc5e 1291# endif /* HAS_SETEGID */
b28d0864 1292 if (PL_delaymagic & DM_GID) {
985213f2 1293 if (PL_delaymagic_gid != PL_delaymagic_egid)
cea2e8a9 1294 DIE(aTHX_ "No setregid available");
b469f1e0 1295 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
a0d0e21e 1296 }
56febc5e
AD
1297# endif /* HAS_SETREGID */
1298#endif /* HAS_SETRESGID */
04783dc7 1299
985213f2
AB
1300 tmp_gid = PerlProc_getgid();
1301 tmp_egid = PerlProc_getegid();
a0d0e21e 1302 }
284167a5 1303 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
9a9b5ec9
DM
1304#ifdef NO_TAINT_SUPPORT
1305 PERL_UNUSED_VAR(tmp_uid);
1306 PERL_UNUSED_VAR(tmp_euid);
1307 PERL_UNUSED_VAR(tmp_gid);
1308 PERL_UNUSED_VAR(tmp_egid);
1309#endif
a0d0e21e 1310 }
3280af22 1311 PL_delaymagic = 0;
54310121 1312
54310121
PP
1313 if (gimme == G_VOID)
1314 SP = firstrelem - 1;
1315 else if (gimme == G_SCALAR) {
1316 dTARGET;
1317 SP = firstrelem;
231cbeb2 1318 SETi(lastrelem - firstrelem + 1);
54310121
PP
1319 }
1320 else {
1c4ea384 1321 if (ary || hash)
1d2b3927
HS
1322 /* note that in this case *firstlelem may have been overwritten
1323 by sv_undef in the odd hash case */
a0d0e21e 1324 SP = lastrelem;
1c4ea384 1325 else {
a0d0e21e 1326 SP = firstrelem + (lastlelem - firstlelem);
1c4ea384
RZ
1327 lelem = firstlelem + (relem - firstrelem);
1328 while (relem <= SP)
1329 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1330 }
a0d0e21e 1331 }
08aeb9f7 1332
54310121 1333 RETURN;
a0d0e21e
LW
1334}
1335
8782bef2
GB
1336PP(pp_qr)
1337{
20b7effb 1338 dSP;
eb578fdb 1339 PMOP * const pm = cPMOP;
fe578d7f 1340 REGEXP * rx = PM_GETRE(pm);
10599a69 1341 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
c4420975 1342 SV * const rv = sv_newmortal();
d63c20f2
DM
1343 CV **cvp;
1344 CV *cv;
288b8c02
NC
1345
1346 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
1347 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1348 loathe to use it here, but it seems to be the right fix. Or close.
1349 The key part appears to be that it's essential for pp_qr to return a new
1350 object (SV), which implies that there needs to be an effective way to
1351 generate a new SV from the existing SV that is pre-compiled in the
1352 optree. */
1353 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
1354 SvROK_on(rv);
1355
8d919b0a 1356 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
5d9574c1 1357 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
d63c20f2 1358 *cvp = cv_clone(cv);
fc2b2dca 1359 SvREFCNT_dec_NN(cv);
d63c20f2
DM
1360 }
1361
288b8c02 1362 if (pkg) {
f815daf2 1363 HV *const stash = gv_stashsv(pkg, GV_ADD);
fc2b2dca 1364 SvREFCNT_dec_NN(pkg);
288b8c02
NC
1365 (void)sv_bless(rv, stash);
1366 }
1367
5d9574c1 1368 if (UNLIKELY(RX_ISTAINTED(rx))) {
e08e52cf 1369 SvTAINTED_on(rv);
9274aefd
DM
1370 SvTAINTED_on(SvRV(rv));
1371 }
c8c13c22 1372 XPUSHs(rv);
1373 RETURN;
8782bef2
GB
1374}
1375
a0d0e21e
LW
1376PP(pp_match)
1377{
20b7effb 1378 dSP; dTARG;
eb578fdb 1379 PMOP *pm = cPMOP;
d65afb4b 1380 PMOP *dynpm = pm;
eb578fdb 1381 const char *s;
5c144d81 1382 const char *strend;
99a90e59 1383 SSize_t curpos = 0; /* initial pos() or current $+[0] */
a0d0e21e 1384 I32 global;
7fadf4a7 1385 U8 r_flags = 0;
5c144d81 1386 const char *truebase; /* Start of string */
eb578fdb 1387 REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1388 bool rxtainted;
a3b680e6 1389 const I32 gimme = GIMME;
a0d0e21e 1390 STRLEN len;
a3b680e6 1391 const I32 oldsave = PL_savestack_ix;
e60df1fa 1392 I32 had_zerolen = 0;
b1422d62 1393 MAGIC *mg = NULL;
a0d0e21e 1394
533c011a 1395 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1396 TARG = POPs;
6ffceeb7 1397 else if (ARGTARG)
59f00321 1398 GETTARGET;
a0d0e21e 1399 else {
54b9620d 1400 TARG = DEFSV;
a0d0e21e
LW
1401 EXTEND(SP,1);
1402 }
d9f424b2 1403
c277df42 1404 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
1405 /* Skip get-magic if this is a qr// clone, because regcomp has
1406 already done it. */
f1d31338 1407 truebase = ReANY(rx)->mother_re
69dc4b30
FC
1408 ? SvPV_nomg_const(TARG, len)
1409 : SvPV_const(TARG, len);
f1d31338 1410 if (!truebase)
2269b42e 1411 DIE(aTHX_ "panic: pp_match");
f1d31338 1412 strend = truebase + len;
284167a5
SM
1413 rxtainted = (RX_ISTAINTED(rx) ||
1414 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1415 TAINT_NOT;
a0d0e21e 1416
6c864ec2 1417 /* We need to know this in case we fail out early - pos() must be reset */
de0df3c0
MH
1418 global = dynpm->op_pmflags & PMf_GLOBAL;
1419
d65afb4b 1420 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
1421 if (
1422#ifdef USE_ITHREADS
1423 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1424#else
1425 pm->op_pmflags & PMf_USED
1426#endif
1427 ) {
e5dc5375 1428 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
de0df3c0 1429 goto nope;
a0d0e21e
LW
1430 }
1431
7e313637
FC
1432 /* empty pattern special-cased to use last successful pattern if
1433 possible, except for qr// */
8d919b0a 1434 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
7e313637 1435 && PL_curpm) {
3280af22 1436 pm = PL_curpm;
aaa362c4 1437 rx = PM_GETRE(pm);
a0d0e21e 1438 }
d65afb4b 1439
389ecb56 1440 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
75d43e96
FC
1441 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1442 UVuf" < %"IVdf")\n",
1443 (UV)len, (IV)RX_MINLEN(rx)));
de0df3c0 1444 goto nope;
e5dc5375 1445 }
c277df42 1446
8ef97b0e 1447 /* get pos() if //g */
de0df3c0 1448 if (global) {
b1422d62 1449 mg = mg_find_mglob(TARG);
8ef97b0e 1450 if (mg && mg->mg_len >= 0) {
25fdce4a 1451 curpos = MgBYTEPOS(mg, TARG, truebase, len);
8ef97b0e
DM
1452 /* last time pos() was set, it was zero-length match */
1453 if (mg->mg_flags & MGf_MINMATCH)
1454 had_zerolen = 1;
1455 }
a0d0e21e 1456 }
8ef97b0e 1457
6e240d0b 1458#ifdef PERL_SAWAMPERSAND
a41aa44d 1459 if ( RX_NPARENS(rx)
6502e081 1460 || PL_sawampersand
6502e081 1461 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 1462 || (dynpm->op_pmflags & PMf_KEEPCOPY)
6e240d0b
FC
1463 )
1464#endif
1465 {
6502e081
DM
1466 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1467 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1468 * only on the first iteration. Therefore we need to copy $' as well
1469 * as $&, to make the rest of the string available for captures in
1470 * subsequent iterations */
1471 if (! (global && gimme == G_ARRAY))
1472 r_flags |= REXEC_COPY_SKIP_POST;
1473 };
5b0e71e9
DM
1474#ifdef PERL_SAWAMPERSAND
1475 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1476 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1477 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1478#endif
22e551b9 1479
f1d31338
DM
1480 s = truebase;
1481
d7be1480 1482 play_it_again:
985afbc1 1483 if (global)
03c83e26 1484 s = truebase + curpos;
f722798b 1485
77da2310 1486 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
03c83e26 1487 had_zerolen, TARG, NULL, r_flags))
03b6c93d 1488 goto nope;
77da2310
NC
1489
1490 PL_curpm = pm;
985afbc1 1491 if (dynpm->op_pmflags & PMf_ONCE)
c737faaf 1492#ifdef USE_ITHREADS
77da2310 1493 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 1494#else
77da2310 1495 dynpm->op_pmflags |= PMf_USED;
c737faaf 1496#endif
a0d0e21e 1497
72311751
GS
1498 if (rxtainted)
1499 RX_MATCH_TAINTED_on(rx);
1500 TAINT_IF(RX_MATCH_TAINTED(rx));
35c2ccc3
DM
1501
1502 /* update pos */
1503
1504 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
b1422d62 1505 if (!mg)
35c2ccc3 1506 mg = sv_magicext_mglob(TARG);
25fdce4a 1507 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
adf51885
DM
1508 if (RX_ZERO_LEN(rx))
1509 mg->mg_flags |= MGf_MINMATCH;
1510 else
1511 mg->mg_flags &= ~MGf_MINMATCH;
35c2ccc3
DM
1512 }
1513
bf9dff51
DM
1514 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1515 LEAVE_SCOPE(oldsave);
1516 RETPUSHYES;
1517 }
1518
88ab22af
DM
1519 /* push captures on stack */
1520
bf9dff51 1521 {
07bc277f 1522 const I32 nparens = RX_NPARENS(rx);
a3b680e6 1523 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 1524
c277df42 1525 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1526 EXTEND(SP, nparens + i);
1527 EXTEND_MORTAL(nparens + i);
1528 for (i = !i; i <= nparens; i++) {
a0d0e21e 1529 PUSHs(sv_newmortal());
5d9574c1
DM
1530 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1531 && RX_OFFS(rx)[i].end != -1 ))
1532 {
07bc277f 1533 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
f1d31338 1534 const char * const s = RX_OFFS(rx)[i].start + truebase;
5d9574c1
DM
1535 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1536 || len < 0 || len > strend - s))
5637ef5b
NC
1537 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1538 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1539 (long) i, (long) RX_OFFS(rx)[i].start,
1540 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
a0d0e21e 1541 sv_setpvn(*SP, s, len);
cce850e4 1542 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1543 SvUTF8_on(*SP);
a0d0e21e
LW
1544 }
1545 }
1546 if (global) {
0e0b3e82 1547 curpos = (UV)RX_OFFS(rx)[0].end;
03c83e26 1548 had_zerolen = RX_ZERO_LEN(rx);
c277df42 1549 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1550 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1551 goto play_it_again;
1552 }
4633a7c4 1553 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1554 RETURN;
1555 }
e5964223 1556 NOT_REACHED; /* NOTREACHED */
a0d0e21e
LW
1557
1558nope:
d65afb4b 1559 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
b1422d62
DM
1560 if (!mg)
1561 mg = mg_find_mglob(TARG);
1562 if (mg)
1563 mg->mg_len = -1;
a0d0e21e 1564 }
4633a7c4 1565 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1566 if (gimme == G_ARRAY)
1567 RETURN;
1568 RETPUSHNO;
1569}
1570
1571OP *
864dbfa3 1572Perl_do_readline(pTHX)
a0d0e21e 1573{
20b7effb 1574 dSP; dTARGETSTACKED;
eb578fdb 1575 SV *sv;
a0d0e21e
LW
1576 STRLEN tmplen = 0;
1577 STRLEN offset;
760ac839 1578 PerlIO *fp;
eb578fdb
KW
1579 IO * const io = GvIO(PL_last_in_gv);
1580 const I32 type = PL_op->op_type;
a3b680e6 1581 const I32 gimme = GIMME_V;
a0d0e21e 1582
6136c704 1583 if (io) {
50db69d8 1584 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 1585 if (mg) {
3e0cb5de 1586 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 1587 if (gimme == G_SCALAR) {
50db69d8
NC
1588 SPAGAIN;
1589 SvSetSV_nosteal(TARG, TOPs);
1590 SETTARG;
6136c704 1591 }
50db69d8 1592 return NORMAL;
0b7c7b4f 1593 }
e79b0511 1594 }
4608196e 1595 fp = NULL;
a0d0e21e
LW
1596 if (io) {
1597 fp = IoIFP(io);
1598 if (!fp) {
1599 if (IoFLAGS(io) & IOf_ARGV) {
1600 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1601 IoLINES(io) = 0;
b9f2b683 1602 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1603 IoFLAGS(io) &= ~IOf_START;
d5eb9a46 1604 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
4bac9ae4 1605 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
76f68e9b 1606 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3280af22 1607 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1608 fp = IoIFP(io);
1609 goto have_fp;
a0d0e21e
LW
1610 }
1611 }
157fb5a1 1612 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e 1613 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1614 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1615 }
1616 }
0d44d22b
NC
1617 else if (type == OP_GLOB)
1618 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1619 }
1620 else if (type == OP_GLOB)
1621 SP--;
7716c5c5 1622 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 1623 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 1624 }
a0d0e21e
LW
1625 }
1626 if (!fp) {
041457d9 1627 if ((!io || !(IoFLAGS(io) & IOf_START))
de7dabb6
TC
1628 && ckWARN(WARN_CLOSED)
1629 && type != OP_GLOB)
041457d9 1630 {
de7dabb6 1631 report_evil_fh(PL_last_in_gv);
3f4520fe 1632 }
54310121 1633 if (gimme == G_SCALAR) {
79628082 1634 /* undef TARG, and push that undefined value */
ba92458f
AE
1635 if (type != OP_RCATLINE) {
1636 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1637 SvOK_off(TARG);
ba92458f 1638 }
a0d0e21e
LW
1639 PUSHTARG;
1640 }
1641 RETURN;
1642 }
a2008d6d 1643 have_fp:
54310121 1644 if (gimme == G_SCALAR) {
a0d0e21e 1645 sv = TARG;
0f722b55
RGS
1646 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1647 mg_get(sv);
48de12d9
RGS
1648 if (SvROK(sv)) {
1649 if (type == OP_RCATLINE)
5668452f 1650 SvPV_force_nomg_nolen(sv);
48de12d9
RGS
1651 else
1652 sv_unref(sv);
1653 }
f7877b28 1654 else if (isGV_with_GP(sv)) {
5668452f 1655 SvPV_force_nomg_nolen(sv);
f7877b28 1656 }
862a34c6 1657 SvUPGRADE(sv, SVt_PV);
a0d0e21e 1658 tmplen = SvLEN(sv); /* remember if already alloced */
e3918bb7 1659 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
f72e8700
JJ
1660 /* try short-buffering it. Please update t/op/readline.t
1661 * if you change the growth length.
1662 */
1663 Sv_Grow(sv, 80);
1664 }
2b5e58c4
AMS
1665 offset = 0;
1666 if (type == OP_RCATLINE && SvOK(sv)) {
1667 if (!SvPOK(sv)) {
5668452f 1668 SvPV_force_nomg_nolen(sv);
2b5e58c4 1669 }
a0d0e21e 1670 offset = SvCUR(sv);
2b5e58c4 1671 }
a0d0e21e 1672 }
54310121 1673 else {
561b68a9 1674 sv = sv_2mortal(newSV(80));
54310121
PP
1675 offset = 0;
1676 }
fbad3eb5 1677
3887d568
AP
1678 /* This should not be marked tainted if the fp is marked clean */
1679#define MAYBE_TAINT_LINE(io, sv) \
1680 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1681 TAINT; \
1682 SvTAINTED_on(sv); \
1683 }
1684
684bef36 1685/* delay EOF state for a snarfed empty file */
fbad3eb5 1686#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1687 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1688 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1689
a0d0e21e 1690 for (;;) {
09e8efcc 1691 PUTBACK;
fbad3eb5 1692 if (!sv_gets(sv, fp, offset)
2d726892
TF
1693 && (type == OP_GLOB
1694 || SNARF_EOF(gimme, PL_rs, io, sv)
1695 || PerlIO_error(fp)))
fbad3eb5 1696 {
760ac839 1697 PerlIO_clearerr(fp);
a0d0e21e 1698 if (IoFLAGS(io) & IOf_ARGV) {
157fb5a1 1699 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e
LW
1700 if (fp)
1701 continue;
3280af22 1702 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1703 }
1704 else if (type == OP_GLOB) {
a2a5de95
NC
1705 if (!do_close(PL_last_in_gv, FALSE)) {
1706 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1707 "glob failed (child exited with status %d%s)",
1708 (int)(STATUS_CURRENT >> 8),
1709 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1710 }
a0d0e21e 1711 }
54310121 1712 if (gimme == G_SCALAR) {
ba92458f
AE
1713 if (type != OP_RCATLINE) {
1714 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1715 SvOK_off(TARG);
ba92458f 1716 }
09e8efcc 1717 SPAGAIN;
a0d0e21e
LW
1718 PUSHTARG;
1719 }
3887d568 1720 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1721 RETURN;
1722 }
3887d568 1723 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1724 IoLINES(io)++;
b9fee9ba 1725 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1726 SvSETMAGIC(sv);
09e8efcc 1727 SPAGAIN;
a0d0e21e 1728 XPUSHs(sv);
a0d0e21e 1729 if (type == OP_GLOB) {
349d4f2f 1730 const char *t1;
a0d0e21e 1731
3280af22 1732 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 1733 char * const tmps = SvEND(sv) - 1;
aa07b2f6 1734 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 1735 *tmps = '\0';
b162af07 1736 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
1737 }
1738 }
349d4f2f 1739 for (t1 = SvPVX_const(sv); *t1; t1++)
b51c3e77
CB
1740#ifdef __VMS
1741 if (strchr("*%?", *t1))
1742#else
7ad1e72d 1743 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
b51c3e77 1744#endif
a0d0e21e 1745 break;
349d4f2f 1746 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1747 (void)POPs; /* Unmatched wildcard? Chuck it... */
1748 continue;
1749 }
2d79bf7f 1750 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
1751 if (ckWARN(WARN_UTF8)) {
1752 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1753 const STRLEN len = SvCUR(sv) - offset;
1754 const U8 *f;
1755
1756 if (!is_utf8_string_loc(s, len, &f))
1757 /* Emulate :encoding(utf8) warning in the same case. */
1758 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1759 "utf8 \"\\x%02X\" does not map to Unicode",
1760 f < (U8*)SvEND(sv) ? *f : 0);
1761 }
a0d0e21e 1762 }
54310121 1763 if (gimme == G_ARRAY) {
a0d0e21e 1764 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 1765 SvPV_shrink_to_cur(sv);
a0d0e21e 1766 }
561b68a9 1767 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
1768 continue;
1769 }
54310121 1770 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 1771 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
1772 const STRLEN new_len
1773 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 1774 SvPV_renew(sv, new_len);
a0d0e21e
LW
1775 }
1776 RETURN;
1777 }
1778}
1779
a0d0e21e
LW
1780PP(pp_helem)
1781{
20b7effb 1782 dSP;
760ac839 1783 HE* he;
ae77835f 1784 SV **svp;
c445ea15 1785 SV * const keysv = POPs;
85fbaab2 1786 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
1787 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1788 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1789 SV *sv;
92970b93 1790 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 1791 bool preeminent = TRUE;
a0d0e21e 1792
b68eab22
SM
1793 if (SvTYPE(hv) != SVt_PVHV)
1794 RETPUSHUNDEF;
d4c19fe8 1795
92970b93 1796 if (localizing) {
d4c19fe8
AL
1797 MAGIC *mg;
1798 HV *stash;
d30e492c
VP
1799
1800 /* If we can determine whether the element exist,
1801 * Try to preserve the existenceness of a tied hash
1802 * element by using EXISTS and DELETE if possible.
1803 * Fallback to FETCH and STORE otherwise. */
2c5f48c2 1804 if (SvCANEXISTDELETE(hv))
d30e492c 1805 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 1806 }
d30e492c 1807
5f9d7e2b 1808 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
d4c19fe8 1809 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 1810 if (lval) {
746f6409 1811 if (!svp || !*svp || *svp == &PL_sv_undef) {
68dc0745
PP
1812 SV* lv;
1813 SV* key2;
2d8e6c8d 1814 if (!defer) {
be2597df 1815 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 1816 }
68dc0745
PP
1817 lv = sv_newmortal();
1818 sv_upgrade(lv, SVt_PVLV);
1819 LvTYPE(lv) = 'y';
6136c704 1820 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
fc2b2dca 1821 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
b37c2d43 1822 LvTARG(lv) = SvREFCNT_inc_simple(hv);
68dc0745
PP
1823 LvTARGLEN(lv) = 1;
1824 PUSHs(lv);
1825 RETURN;
1826 }
92970b93 1827 if (localizing) {
bfcb3514 1828 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 1829 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
1830 else if (preeminent)
1831 save_helem_flags(hv, keysv, svp,
1832 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1833 else
1834 SAVEHDELETE(hv, keysv);
5f05dabc 1835 }
9026059d
GG
1836 else if (PL_op->op_private & OPpDEREF) {
1837 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1838 RETURN;
1839 }
a0d0e21e 1840 }
746f6409 1841 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
1842 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1843 * was to make C<local $tied{foo} = $tied{foo}> possible.
1844 * However, it seems no longer to be needed for that purpose, and
1845 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1846 * would loop endlessly since the pos magic is getting set on the
1847 * mortal copy and lost. However, the copy has the effect of
1848 * triggering the get magic, and losing it altogether made things like
1849 * c<$tied{foo};> in void context no longer do get magic, which some
1850 * code relied on. Also, delayed triggering of magic on @+ and friends
1851 * meant the original regex may be out of scope by now. So as a
1852 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1853 * being called too many times). */
39cf747a 1854 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 1855 mg_get(sv);
be6c24e0 1856 PUSHs(sv);
a0d0e21e
LW
1857 RETURN;
1858}
1859
a0d0e21e
LW
1860PP(pp_iter)
1861{
20b7effb 1862 dSP;
eb578fdb 1863 PERL_CONTEXT *cx;
7d6c2cef 1864 SV *oldsv;
1d7c1841 1865 SV **itersvp;
a0d0e21e 1866
924508f0 1867 EXTEND(SP, 1);
a0d0e21e 1868 cx = &cxstack[cxstack_ix];
1d7c1841 1869 itersvp = CxITERVAR(cx);
a48ce6be
DM
1870
1871 switch (CxTYPE(cx)) {
17c91640 1872
b552b52c
DM
1873 case CXt_LOOP_LAZYSV: /* string increment */
1874 {
1875 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1876 SV *end = cx->blk_loop.state_u.lazysv.end;
1877 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1878 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1879 STRLEN maxlen = 0;
1880 const char *max = SvPV_const(end, maxlen);
5d9574c1 1881 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
b552b52c
DM
1882 RETPUSHNO;
1883
1884 oldsv = *itersvp;
5d9574c1 1885 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
b552b52c
DM
1886 /* safe to reuse old SV */
1887 sv_setsv(oldsv, cur);
a48ce6be 1888 }
b552b52c
DM
1889 else
1890 {
1891 /* we need a fresh SV every time so that loop body sees a
1892 * completely new SV for closures/references to work as
1893 * they used to */
1894 *itersvp = newSVsv(cur);
fc2b2dca 1895 SvREFCNT_dec_NN(oldsv);
b552b52c
DM
1896 }
1897 if (strEQ(SvPVX_const(cur), max))
1898 sv_setiv(cur, 0); /* terminate next time */
1899 else
1900 sv_inc(cur);
1901 break;
1902 }
a48ce6be 1903
fcef60b4
DM
1904 case CXt_LOOP_LAZYIV: /* integer increment */
1905 {
1906 IV cur = cx->blk_loop.state_u.lazyiv.cur;
5d9574c1 1907 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
89ea2908 1908 RETPUSHNO;
7f61b687 1909
fcef60b4 1910 oldsv = *itersvp;
3db8f154 1911 /* don't risk potential race */
5d9574c1 1912 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
eaa5c2d6 1913 /* safe to reuse old SV */
fcef60b4 1914 sv_setiv(oldsv, cur);
eaa5c2d6 1915 }
1c846c1f 1916 else
eaa5c2d6
GA
1917 {
1918 /* we need a fresh SV every time so that loop body sees a
1919 * completely new SV for closures/references to work as they
1920 * used to */
fcef60b4 1921 *itersvp = newSViv(cur);
fc2b2dca 1922 SvREFCNT_dec_NN(oldsv);
eaa5c2d6 1923 }
a2309040 1924
5d9574c1 1925 if (UNLIKELY(cur == IV_MAX)) {
cdc1aa42
NC
1926 /* Handle end of range at IV_MAX */
1927 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1928 } else
1929 ++cx->blk_loop.state_u.lazyiv.cur;
a48ce6be 1930 break;
fcef60b4 1931 }
a48ce6be 1932
b552b52c 1933 case CXt_LOOP_FOR: /* iterate array */
7d6c2cef 1934 {
89ea2908 1935
7d6c2cef
DM
1936 AV *av = cx->blk_loop.state_u.ary.ary;
1937 SV *sv;
1938 bool av_is_stack = FALSE;
a8a20bb6 1939 IV ix;
7d6c2cef 1940
de080daa
DM
1941 if (!av) {
1942 av_is_stack = TRUE;
1943 av = PL_curstack;
1944 }
1945 if (PL_op->op_private & OPpITER_REVERSED) {
a8a20bb6 1946 ix = --cx->blk_loop.state_u.ary.ix;
5d9574c1 1947 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
de080daa 1948 RETPUSHNO;
de080daa
DM
1949 }
1950 else {
a8a20bb6 1951 ix = ++cx->blk_loop.state_u.ary.ix;
5d9574c1 1952 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
de080daa 1953 RETPUSHNO;
a8a20bb6 1954 }
de080daa 1955
5d9574c1 1956 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
a8a20bb6
DM
1957 SV * const * const svp = av_fetch(av, ix, FALSE);
1958 sv = svp ? *svp : NULL;
1959 }
1960 else {
1961 sv = AvARRAY(av)[ix];
de080daa 1962 }
ef3e5ea9 1963
d39c26a6
FC
1964 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
1965 SvSetMagicSV(*itersvp, sv);
1966 break;
1967 }
1968
5d9574c1
DM
1969 if (LIKELY(sv)) {
1970 if (UNLIKELY(SvIS_FREED(sv))) {
f38aa882
DM
1971 *itersvp = NULL;
1972 Perl_croak(aTHX_ "Use of freed value in iteration");
1973 }
60779a30 1974 if (SvPADTMP(sv)) {
8e079c2a 1975 sv = newSVsv(sv);
60779a30 1976 }
8e079c2a
FC
1977 else {
1978 SvTEMP_off(sv);
1979 SvREFCNT_inc_simple_void_NN(sv);
1980 }
de080daa 1981 }
a600f7e6 1982 else if (!av_is_stack) {
199f858d 1983 sv = newSVavdefelem(av, ix, 0);
de080daa 1984 }
a600f7e6
FC
1985 else
1986 sv = &PL_sv_undef;
a0d0e21e 1987
de080daa
DM
1988 oldsv = *itersvp;
1989 *itersvp = sv;
1990 SvREFCNT_dec(oldsv);
de080daa 1991 break;
7d6c2cef 1992 }
a48ce6be
DM
1993
1994 default:
1995 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1996 }
b552b52c 1997 RETPUSHYES;
a0d0e21e
LW
1998}
1999
ef07e810
DM
2000/*
2001A description of how taint works in pattern matching and substitution.
2002
284167a5
SM
2003This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2004NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2005
4e19c54b 2006While the pattern is being assembled/concatenated and then compiled,
284167a5
SM
2007PL_tainted will get set (via TAINT_set) if any component of the pattern
2008is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
2009the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1738e041
DM
2010TAINT_get). It will also be set if any component of the pattern matches
2011based on locale-dependent behavior.
ef07e810 2012
0ab462a6
DM
2013When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2014the pattern is marked as tainted. This means that subsequent usage, such
284167a5
SM
2015as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2016on the new pattern too.
ef07e810 2017
272d35c9 2018RXf_TAINTED_SEEN is used post-execution by the get magic code
ef07e810
DM
2019of $1 et al to indicate whether the returned value should be tainted.
2020It is the responsibility of the caller of the pattern (i.e. pp_match,
2021pp_subst etc) to set this flag for any other circumstances where $1 needs
2022to be tainted.
2023
2024The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2025
2026There are three possible sources of taint
2027 * the source string
2028 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2029 * the replacement string (or expression under /e)
2030
2031There are four destinations of taint and they are affected by the sources
2032according to the rules below:
2033
2034 * the return value (not including /r):
2035 tainted by the source string and pattern, but only for the
2036 number-of-iterations case; boolean returns aren't tainted;
2037 * the modified string (or modified copy under /r):
2038 tainted by the source string, pattern, and replacement strings;
2039 * $1 et al:
2040 tainted by the pattern, and under 'use re "taint"', by the source
2041 string too;
2042 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2043 should always be unset before executing subsequent code.
2044
2045The overall action of pp_subst is:
2046
2047 * at the start, set bits in rxtainted indicating the taint status of
2048 the various sources.
2049
2050 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2051 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2052 pattern has subsequently become tainted via locale ops.
2053
2054 * If control is being passed to pp_substcont to execute a /e block,
2055 save rxtainted in the CXt_SUBST block, for future use by
2056 pp_substcont.
2057
2058 * Whenever control is being returned to perl code (either by falling
2059 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2060 use the flag bits in rxtainted to make all the appropriate types of
0ab462a6
DM
2061 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2062 et al will appear tainted.
ef07e810
DM
2063
2064pp_match is just a simpler version of the above.
2065
2066*/
2067
a0d0e21e
LW
2068PP(pp_subst)
2069{
20b7effb 2070 dSP; dTARG;
eb578fdb 2071 PMOP *pm = cPMOP;
a0d0e21e 2072 PMOP *rpm = pm;
eb578fdb 2073 char *s;
a0d0e21e 2074 char *strend;
5c144d81 2075 const char *c;
a0d0e21e
LW
2076 STRLEN clen;
2077 I32 iters = 0;
2078 I32 maxiters;
a0d0e21e 2079 bool once;
ef07e810
DM
2080 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2081 See "how taint works" above */
a0d0e21e 2082 char *orig;
1ed74d04 2083 U8 r_flags;
eb578fdb 2084 REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
2085 STRLEN len;
2086 int force_on_match = 0;
0bcc34c2 2087 const I32 oldsave = PL_savestack_ix;
792b2c16 2088 STRLEN slen;
26a74523 2089 bool doutf8 = FALSE; /* whether replacement is in utf8 */
db2c6cb3 2090#ifdef PERL_ANY_COW
ed252734
NC
2091 bool is_cow;
2092#endif
a0714e2c 2093 SV *nsv = NULL;
b770e143 2094 /* known replacement string? */
eb578fdb 2095 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
a0d0e21e 2096
f410a211
NC
2097 PERL_ASYNC_CHECK();
2098
533c011a 2099 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 2100 TARG = POPs;
6ffceeb7 2101 else if (ARGTARG)
59f00321 2102 GETTARGET;
a0d0e21e 2103 else {
54b9620d 2104 TARG = DEFSV;
a0d0e21e 2105 EXTEND(SP,1);
1c846c1f 2106 }
d9f424b2 2107
64534138 2108 SvGETMAGIC(TARG); /* must come before cow check */
db2c6cb3 2109#ifdef PERL_ANY_COW
ed252734
NC
2110 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2111 because they make integers such as 256 "false". */
2112 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2113#else
765f542d
NC
2114 if (SvIsCOW(TARG))
2115 sv_force_normal_flags(TARG,0);
ed252734 2116#endif
8ca8a454 2117 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
8ca8a454
NC
2118 && (SvREADONLY(TARG)
2119 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2120 || SvTYPE(TARG) > SVt_PVLV)
2121 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
cb077ed2 2122 Perl_croak_no_modify();
8ec5e241
NIS
2123 PUTBACK;
2124
6ac6605d
DM
2125 orig = SvPV_nomg(TARG, len);
2126 /* note we don't (yet) force the var into being a string; if we fail
2127 * to match, we leave as-is; on successful match howeverm, we *will*
2128 * coerce into a string, then repeat the match */
4499db73 2129 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
a0d0e21e 2130 force_on_match = 1;
20be6587
DM
2131
2132 /* only replace once? */
2133 once = !(rpm->op_pmflags & PMf_GLOBAL);
2134
ef07e810 2135 /* See "how taint works" above */
284167a5 2136 if (TAINTING_get) {
20be6587
DM
2137 rxtainted = (
2138 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
284167a5 2139 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
20be6587
DM
2140 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2141 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2142 ? SUBST_TAINT_BOOLRET : 0));
2143 TAINT_NOT;
2144 }
a12c0f56 2145
a0d0e21e 2146 force_it:
6ac6605d
DM
2147 if (!pm || !orig)
2148 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
a0d0e21e 2149
6ac6605d
DM
2150 strend = orig + len;
2151 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
792b2c16
JH
2152 maxiters = 2 * slen + 10; /* We can match twice at each
2153 position, once with zero-length,
2154 second time with non-zero. */
a0d0e21e 2155
6a97c51d 2156 if (!RX_PRELEN(rx) && PL_curpm
8d919b0a 2157 && !ReANY(rx)->mother_re) {
3280af22 2158 pm = PL_curpm;
aaa362c4 2159 rx = PM_GETRE(pm);
a0d0e21e 2160 }
6502e081 2161
6e240d0b 2162#ifdef PERL_SAWAMPERSAND
6502e081
DM
2163 r_flags = ( RX_NPARENS(rx)
2164 || PL_sawampersand
6502e081 2165 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 2166 || (rpm->op_pmflags & PMf_KEEPCOPY)
6502e081
DM
2167 )
2168 ? REXEC_COPY_STR
2169 : 0;
6e240d0b
FC
2170#else
2171 r_flags = REXEC_COPY_STR;
2172#endif
7fba1cd6 2173
0395280b 2174 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
8b64c330 2175 {
5e79dfb9
DM
2176 SPAGAIN;
2177 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2178 LEAVE_SCOPE(oldsave);
2179 RETURN;
2180 }
1754320d
FC
2181 PL_curpm = pm;
2182
71be2cbc 2183 /* known replacement string? */
f272994b 2184 if (dstr) {
8514a05a
JH
2185 /* replacement needing upgrading? */
2186 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2187 nsv = sv_newmortal();
4a176938 2188 SvSetSV(nsv, dstr);
47e13f24 2189 if (IN_ENCODING)
ad2de1b2 2190 sv_recode_to_utf8(nsv, _get_encoding());
8514a05a
JH
2191 else
2192 sv_utf8_upgrade(nsv);
5c144d81 2193 c = SvPV_const(nsv, clen);
4a176938
JH
2194 doutf8 = TRUE;
2195 }
2196 else {
5c144d81 2197 c = SvPV_const(dstr, clen);
4a176938 2198 doutf8 = DO_UTF8(dstr);
8514a05a 2199 }
bb933b9b
FC
2200
2201 if (SvTAINTED(dstr))
2202 rxtainted |= SUBST_TAINT_REPL;
f272994b
A
2203 }
2204 else {
6136c704 2205 c = NULL;
f272994b
A
2206 doutf8 = FALSE;
2207 }
2208
71be2cbc 2209 /* can do inplace substitution? */
ed252734 2210 if (c
db2c6cb3 2211#ifdef PERL_ANY_COW
ed252734
NC
2212 && !is_cow
2213#endif
fbfb1899 2214 && (I32)clen <= RX_MINLENRET(rx)
9cefd268
FC
2215 && ( once
2216 || !(r_flags & REXEC_COPY_STR)
2217 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2218 )
dbc200c5 2219 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
8ca8a454
NC
2220 && (!doutf8 || SvUTF8(TARG))
2221 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
8b030b38 2222 {
ec911639 2223
db2c6cb3 2224#ifdef PERL_ANY_COW
ed252734 2225 if (SvIsCOW(TARG)) {
f7a8268c 2226 if (!force_on_match)
ed252734 2227 goto have_a_cow;
f7a8268c 2228 assert(SvVOK(TARG));
ed252734
NC
2229 }
2230#endif
71be2cbc 2231 if (force_on_match) {
6ac6605d
DM
2232 /* redo the first match, this time with the orig var
2233 * forced into being a string */
71be2cbc 2234 force_on_match = 0;
6ac6605d 2235 orig = SvPV_force_nomg(TARG, len);
71be2cbc
PP
2236 goto force_it;
2237 }
39b40493 2238
71be2cbc 2239 if (once) {
c67ab8f2 2240 char *d, *m;
20be6587
DM
2241 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2242 rxtainted |= SUBST_TAINT_PAT;
07bc277f
NC
2243 m = orig + RX_OFFS(rx)[0].start;
2244 d = orig + RX_OFFS(rx)[0].end;
71be2cbc
PP
2245 s = orig;
2246 if (m - s > strend - d) { /* faster to shorten from end */
2ec7214c 2247 I32 i;
71be2cbc
PP
2248 if (clen) {
2249 Copy(c, m, clen, char);
2250 m += clen;
a0d0e21e 2251 }
71be2cbc
PP
2252 i = strend - d;
2253 if (i > 0) {
2254 Move(d, m, i, char);
2255 m += i;
a0d0e21e 2256 }
71be2cbc
PP
2257 *m = '\0';
2258 SvCUR_set(TARG, m - s);
2259 }
2ec7214c
DM
2260 else { /* faster from front */
2261 I32 i = m - s;
71be2cbc 2262 d -= clen;
2ec7214c
DM
2263 if (i > 0)
2264 Move(s, d - i, i, char);
71be2cbc 2265 sv_chop(TARG, d-i);
71be2cbc 2266 if (clen)
c947cd8d 2267 Copy(c, d, clen, char);
71be2cbc 2268 }
8ec5e241 2269 SPAGAIN;
8ca8a454 2270 PUSHs(&PL_sv_yes);
71be2cbc
PP
2271 }
2272 else {
c67ab8f2 2273 char *d, *m;
0395280b 2274 d = s = RX_OFFS(rx)[0].start + orig;
71be2cbc 2275 do {
2b25edcf 2276 I32 i;
5d9574c1 2277 if (UNLIKELY(iters++ > maxiters))
cea2e8a9 2278 DIE(aTHX_ "Substitution loop");
5d9574c1 2279 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
20be6587 2280 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2281 m = RX_OFFS(rx)[0].start + orig;
155aba94 2282 if ((i = m - s)) {
71be2cbc
PP
2283 if (s != d)
2284 Move(s, d, i, char);
2285 d += i;
a0d0e21e 2286 }
71be2cbc
PP
2287 if (clen) {
2288 Copy(c, d, clen, char);
2289 d += clen;
2290 }
07bc277f 2291 s = RX_OFFS(rx)[0].end + orig;
7ce41e5c
FC
2292 } while (CALLREGEXEC(rx, s, strend, orig,
2293 s == m, /* don't match same null twice */
f722798b 2294 TARG, NULL,
d5e7783a 2295 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
71be2cbc 2296 if (s != d) {
2b25edcf 2297 I32 i = strend - s;
aa07b2f6 2298 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 2299 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2300 }
8ec5e241 2301 SPAGAIN;
8ca8a454 2302 mPUSHi((I32)iters);
a0d0e21e
LW
2303 }
2304 }
ff6e92e8 2305 else {
1754320d 2306 bool first;
c67ab8f2 2307 char *m;
1754320d 2308 SV *repl;
a0d0e21e 2309 if (force_on_match) {
6ac6605d
DM
2310 /* redo the first match, this time with the orig var
2311 * forced into being a string */
a0d0e21e 2312 force_on_match = 0;
0c1438a1
NC
2313 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2314 /* I feel that it should be possible to avoid this mortal copy
2315 given that the code below copies into a new destination.
2316 However, I suspect it isn't worth the complexity of
2317 unravelling the C<goto force_it> for the small number of
2318 cases where it would be viable to drop into the copy code. */
2319 TARG = sv_2mortal(newSVsv(TARG));
2320 }
6ac6605d 2321 orig = SvPV_force_nomg(TARG, len);
a0d0e21e
LW
2322 goto force_it;
2323 }
db2c6cb3 2324#ifdef PERL_ANY_COW
ed252734
NC
2325 have_a_cow:
2326#endif
20be6587
DM
2327 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2328 rxtainted |= SUBST_TAINT_PAT;
1754320d 2329 repl = dstr;
0395280b
DM
2330 s = RX_OFFS(rx)[0].start + orig;
2331 dstr = newSVpvn_flags(orig, s-orig,
2332 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
a0d0e21e 2333 if (!c) {
eb578fdb 2334 PERL_CONTEXT *cx;
8ec5e241 2335 SPAGAIN;
0395280b 2336 m = orig;
20be6587
DM
2337 /* note that a whole bunch of local vars are saved here for
2338 * use by pp_substcont: here's a list of them in case you're
2339 * searching for places in this sub that uses a particular var:
2340 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2341 * s m strend rx once */
a0d0e21e 2342 PUSHSUBST(cx);
20e98b0f 2343 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
a0d0e21e 2344 }
1754320d 2345 first = TRUE;
a0d0e21e 2346 do {
5d9574c1 2347 if (UNLIKELY(iters++ > maxiters))
cea2e8a9 2348 DIE(aTHX_ "Substitution loop");
5d9574c1 2349 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
20be6587 2350 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2351 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
c67ab8f2
DM
2352 char *old_s = s;
2353 char *old_orig = orig;
6502e081 2354 assert(RX_SUBOFFSET(rx) == 0);
c67ab8f2 2355
07bc277f 2356 orig = RX_SUBBEG(rx);
c67ab8f2
DM
2357 s = orig + (old_s - old_orig);
2358 strend = s + (strend - old_s);
a0d0e21e 2359 }
07bc277f 2360 m = RX_OFFS(rx)[0].start + orig;
64534138 2361 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
07bc277f 2362 s = RX_OFFS(rx)[0].end + orig;
1754320d
FC
2363 if (first) {
2364 /* replacement already stringified */
2365 if (clen)
64534138 2366 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
1754320d
FC
2367 first = FALSE;
2368 }
2369 else {
47e13f24 2370 if (IN_ENCODING) {
1754320d
FC
2371 if (!nsv) nsv = sv_newmortal();
2372 sv_copypv(nsv, repl);
ad2de1b2 2373 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
1754320d
FC
2374 sv_catsv(dstr, nsv);
2375 }
2376 else sv_catsv(dstr, repl);
5d9574c1 2377 if (UNLIKELY(SvTAINTED(repl)))
bb933b9b 2378 rxtainted |= SUBST_TAINT_REPL;
1754320d 2379 }
a0d0e21e
LW
2380 if (once)
2381 break;
f9f4320a 2382 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
d5e7783a
DM
2383 TARG, NULL,
2384 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
64534138 2385 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
748a9306 2386
8ca8a454
NC
2387 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2388 /* From here on down we're using the copy, and leaving the original
2389 untouched. */
2390 TARG = dstr;
2391 SPAGAIN;
2392 PUSHs(dstr);
2393 } else {
db2c6cb3 2394#ifdef PERL_ANY_COW
8ca8a454
NC
2395 /* The match may make the string COW. If so, brilliant, because
2396 that's just saved us one malloc, copy and free - the regexp has
2397 donated the old buffer, and we malloc an entirely new one, rather
2398 than the regexp malloc()ing a buffer and copying our original,
2399 only for us to throw it away here during the substitution. */
2400 if (SvIsCOW(TARG)) {
2401 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2402 } else
ed252734 2403#endif
8ca8a454
NC
2404 {
2405 SvPV_free(TARG);
2406 }
2407 SvPV_set(TARG, SvPVX(dstr));
2408 SvCUR_set(TARG, SvCUR(dstr));
2409 SvLEN_set(TARG, SvLEN(dstr));
64534138 2410 SvFLAGS(TARG) |= SvUTF8(dstr);
8ca8a454 2411 SvPV_set(dstr, NULL);
748a9306 2412
8ca8a454 2413 SPAGAIN;
4f4d7508 2414 mPUSHi((I32)iters);
8ca8a454
NC
2415 }
2416 }
2417
2418 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2419 (void)SvPOK_only_UTF8(TARG);
a0d0e21e 2420 }
20be6587 2421
ef07e810 2422 /* See "how taint works" above */
284167a5 2423 if (TAINTING_get) {
20be6587
DM
2424 if ((rxtainted & SUBST_TAINT_PAT) ||
2425 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2426 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2427 )
2428 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2429
2430 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2431 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2432 )
2433 SvTAINTED_on(TOPs); /* taint return value */
2434 else
2435 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2436
2437 /* needed for mg_set below */
284167a5
SM
2438 TAINT_set(
2439 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2440 );
20be6587
DM
2441 SvTAINT(TARG);
2442 }
2443 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2444 TAINT_NOT;
f1a76097
DM
2445 LEAVE_SCOPE(oldsave);
2446 RETURN;
a0d0e21e
LW
2447}
2448
2449PP(pp_grepwhile)
2450{
20b7effb 2451 dSP;
a0d0e21e
LW
2452
2453 if (SvTRUEx(POPs))
3280af22
NIS
2454 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2455 ++*PL_markstack_ptr;
b2a2a901 2456 FREETMPS;
d343c3ef 2457 LEAVE_with_name("grep_item"); /* exit inner scope */
a0d0e21e
LW
2458
2459 /* All done yet? */
5d9574c1 2460 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
a0d0e21e 2461 I32 items;
c4420975 2462 const I32 gimme = GIMME_V;
a0d0e21e 2463
d343c3ef 2464 LEAVE_with_name("grep"); /* exit outer scope */
a0d0e21e 2465 (void)POPMARK; /* pop src */
3280af22 2466 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2467 (void)POPMARK; /* pop dst */
3280af22 2468 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2469 if (gimme == G_SCALAR) {
7cc47870 2470 if (PL_op->op_private & OPpGREP_LEX) {
c4420975 2471 SV* const sv = sv_newmortal();
7cc47870
RGS
2472 sv_setiv(sv, items);
2473 PUSHs(sv);
2474 }
2475 else {
2476 dTARGET;
2477 XPUSHi(items);
2478 }
a0d0e21e 2479 }
54310121
PP
2480 else if (gimme == G_ARRAY)
2481 SP += items;
a0d0e21e
LW
2482 RETURN;
2483 }
2484 else {
2485 SV *src;
2486
d343c3ef 2487 ENTER_with_name("grep_item"); /* enter inner scope */
1d7c1841 2488 SAVEVPTR(PL_curpm);
a0d0e21e 2489
3280af22 2490 src = PL_stack_base[*PL_markstack_ptr];
60779a30 2491 if (SvPADTMP(src)) {
a0ed822e
FC
2492 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2493 PL_tmps_floor++;
2494 }
a0d0e21e 2495 SvTEMP_off(src);
59f00321
RGS
2496 if (PL_op->op_private & OPpGREP_LEX)
2497 PAD_SVl(PL_op->op_targ) = src;
2498 else
414bf5ae 2499 DEFSV_set(src);
a0d0e21e
LW
2500
2501 RETURNOP(cLOGOP->op_other);
2502 }
2503}
2504
2505PP(pp_leavesub)
2506{
20b7effb 2507 dSP;
a0d0e21e
LW
2508 SV **mark;
2509 SV **newsp;
2510 PMOP *newpm;
2511 I32 gimme;
eb578fdb 2512 PERL_CONTEXT *cx;
b0d9ce38 2513 SV *sv;
a0d0e21e 2514
9850bf21
RH
2515 if (CxMULTICALL(&cxstack[cxstack_ix]))
2516 return 0;
2517
a0d0e21e 2518 POPBLOCK(cx,newpm);
5dd42e15 2519 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2520
a1f49e72 2521 TAINT_NOT;
a0d0e21e
LW
2522 if (gimme == G_SCALAR) {
2523 MARK = newsp + 1;
5d9574c1 2524 if (LIKELY(MARK <= SP)) {
a8bba7fa 2525 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
6f48390a
FC
2526 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2527 && !SvMAGICAL(TOPs)) {
a29cdaf0
IZ
2528 *MARK = SvREFCNT_inc(TOPs);
2529 FREETMPS;
2530 sv_2mortal(*MARK);
cd06dffe
GS
2531 }
2532 else {
959e3673 2533 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2534 FREETMPS;
959e3673 2535 *MARK = sv_mortalcopy(sv);
fc2b2dca 2536 SvREFCNT_dec_NN(sv);
a29cdaf0 2537 }
cd06dffe 2538 }
6f48390a
FC
2539 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2540 && !SvMAGICAL(TOPs)) {
767eda44 2541 *MARK = TOPs;
767eda44 2542 }
cd06dffe 2543 else
767eda44 2544 *MARK = sv_mortalcopy(TOPs);
cd06dffe
GS
2545 }
2546 else {
f86702cc 2547 MEXTEND(MARK, 0);
3280af22 2548 *MARK = &PL_sv_undef;
a0d0e21e
LW
2549 }
2550 SP = MARK;
2551 }
54310121 2552 else if (gimme == G_ARRAY) {
f86702cc 2553 for (MARK = newsp + 1; MARK <= SP; MARK++) {
6f48390a
FC
2554 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2555 || SvMAGICAL(*MARK)) {
f86702cc 2556 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2557 TAINT_NOT; /* Each item is independent */
2558 }
f86702cc 2559 }
a0d0e21e 2560 }
f86702cc 2561 PUTBACK;
1c846c1f 2562
a57c6685 2563 LEAVE;
b0d9ce38 2564 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
25375124 2565 cxstack_ix--;
3280af22 2566 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2567
b0d9ce38 2568 LEAVESUB(sv);
f39bc417 2569 return cx->blk_sub.retop;
a0d0e21e
LW
2570}
2571
2572PP(pp_entersub)
2573{
20b7effb 2574 dSP; dPOPss;
a0d0e21e 2575 GV *gv;
eb578fdb
KW
2576 CV *cv;
2577 PERL_CONTEXT *cx;
5d94fbed 2578 I32 gimme;
a9c4fd4e 2579 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e 2580
f5719c02 2581 if (UNLIKELY(!sv))
cea2e8a9 2582 DIE(aTHX_ "Not a CODE reference");
f5719c02
DM
2583 /* This is overwhelmingly the most common case: */
2584 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
313107ce
DM
2585 switch (SvTYPE(sv)) {
2586 case SVt_PVGV:
2587 we_have_a_glob:
2588 if (!(cv = GvCVu((const GV *)sv))) {
2589 HV *stash;
2590 cv = sv_2cv(sv, &stash, &gv, 0);
2591 }
2592 if (!cv) {
2593 ENTER;
2594 SAVETMPS;
2595 goto try_autoload;
2596 }
2597 break;
2598 case SVt_PVLV:
2599 if(isGV_with_GP(sv)) goto we_have_a_glob;
924ba076 2600 /* FALLTHROUGH */
313107ce
DM
2601 default:
2602 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2603 if (hasargs)
2604 SP = PL_stack_base + POPMARK;
2605 else
2606 (void)POPMARK;
2607 RETURN;
2608 }
2609 SvGETMAGIC(sv);
2610 if (SvROK(sv)) {
2611 if (SvAMAGIC(sv)) {
2612 sv = amagic_deref_call(sv, to_cv_amg);
2613 /* Don't SPAGAIN here. */
2614 }
2615 }
2616 else {
2617 const char *sym;
2618 STRLEN len;
2619 if (!SvOK(sv))
2620 DIE(aTHX_ PL_no_usym, "a subroutine");
2621 sym = SvPV_nomg_const(sv, len);
2622 if (PL_op->op_private & HINT_STRICT_REFS)
2623 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2624 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2625 break;
2626 }
2627 cv = MUTABLE_CV(SvRV(sv));
2628 if (SvTYPE(cv) == SVt_PVCV)
2629 break;
924ba076 2630 /* FALLTHROUGH */
313107ce
DM
2631 case SVt_PVHV:
2632 case SVt_PVAV:
2633 DIE(aTHX_ "Not a CODE reference");
2634 /* This is the second most common case: */
2635 case SVt_PVCV:
2636 cv = MUTABLE_CV(sv);
2637 break;
2638 }
f5719c02 2639 }
a0d0e21e 2640
a57c6685 2641 ENTER;
a0d0e21e
LW
2642
2643 retry:
f5719c02 2644 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
541ed3a9 2645 DIE(aTHX_ "Closure prototype called");
f5719c02 2646 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
2f349aa0
NC
2647 GV* autogv;
2648 SV* sub_name;
2649
2650 /* anonymous or undef'd function leaves us no recourse */
ae77754a
FC
2651 if (CvLEXICAL(cv) && CvHASGV(cv))
2652 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
ecf05a58 2653 SVfARG(cv_name(cv, NULL, 0)));
ae77754a 2654 if (CvANON(cv) || !CvHASGV(cv)) {
2f349aa0 2655 DIE(aTHX_ "Undefined subroutine called");
7d2057d8 2656 }
2f349aa0
NC
2657
2658 /* autoloaded stub? */
ae77754a 2659 if (cv != GvCV(gv = CvGV(cv))) {
2f349aa0
NC
2660 cv = GvCV(gv);
2661 }
2662 /* should call AUTOLOAD now? */
2663 else {
7e623da3 2664try_autoload:
d1089224
BF
2665 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2666 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2f349aa0
NC
2667 {
2668 cv = GvCV(autogv);
2669 }
2f349aa0 2670 else {
c220e1a1 2671 sorry:
2f349aa0 2672 sub_name = sv_newmortal();
6136c704 2673 gv_efullname3(sub_name, gv, NULL);
be2597df 2674 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2f349aa0
NC
2675 }
2676 }
2677 if (!cv)
c220e1a1 2678 goto sorry;
2f349aa0 2679 goto retry;
a0d0e21e
LW
2680 }
2681
f5719c02
DM
2682 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
2683 && !CvNODEBUG(cv)))
2684 {
005a8a35 2685 Perl_get_db_sub(aTHX_ &sv, cv);
a9ef256d
NC
2686 if (CvISXSUB(cv))
2687 PL_curcopdb = PL_curcop;
1ad62f64 2688 if (CvLVALUE(cv)) {
2689 /* check for lsub that handles lvalue subroutines */
07b605e5 2690 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
1ad62f64 2691 /* if lsub not found then fall back to DB::sub */
2692 if (!cv) cv = GvCV(PL_DBsub);
2693 } else {
2694 cv = GvCV(PL_DBsub);
2695 }
a9ef256d 2696
ccafdc96
RGS
2697 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2698 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2699 }
a0d0e21e 2700
f5719c02
DM
2701 gimme = GIMME_V;
2702
aed2304a 2703 if (!(CvISXSUB(cv))) {
f1025168 2704 /* This path taken at least 75% of the time */
a0d0e21e 2705 dMARK;
b70d5558 2706 PADLIST * const padlist = CvPADLIST(cv);
3689ad62 2707 I32 depth;
f5719c02 2708
a0d0e21e
LW
2709 PUSHBLOCK(cx, CXt_SUB, MARK);
2710 PUSHSUB(cx);
f39bc417 2711 cx->blk_sub.retop = PL_op->op_next;
3689ad62 2712 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3a76ca88 2713 PERL_STACK_OVERFLOW_CHECK();
3689ad62 2714 pad_push(padlist, depth);
a0d0e21e 2715 }
3a76ca88 2716 SAVECOMPPAD();
3689ad62 2717 PAD_SET_CUR_NOSAVE(padlist, depth);
f5719c02 2718 if (LIKELY(hasargs)) {
10533ace 2719 AV *const av = MUTABLE_AV(PAD_SVl(0));
bdf02c57
DM
2720 SSize_t items;
2721 AV **defavp;
2722
f5719c02 2723 if (UNLIKELY(AvREAL(av))) {
221373f0
GS
2724 /* @_ is normally not REAL--this should only ever
2725 * happen when DB::sub() calls things that modify @_ */
2726 av_clear(av);
2727 AvREAL_off(av);
2728 AvREIFY_on(av);
2729 }
bdf02c57
DM
2730 defavp = &GvAV(PL_defgv);
2731 cx->blk_sub.savearray = *defavp;
2732 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
dd2155a4 2733 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2734 cx->blk_sub.argarray = av;
bdf02c57 2735 items = SP - MARK;
a0d0e21e 2736
f5719c02 2737 if (UNLIKELY(items - 1 > AvMAX(av))) {
77d27ef6
SF
2738 SV **ary = AvALLOC(av);
2739 AvMAX(av) = items - 1;
2740 Renew(ary, items, SV*);
2741 AvALLOC(av) = ary;
2742 AvARRAY(av) = ary;
2743 }
2744
bdf02c57 2745 Copy(MARK+1,AvARRAY(av),items,SV*);
93965878 2746 AvFILLp(av) = items - 1;
1c846c1f 2747
b479c9f2 2748 MARK = AvARRAY(av);
a0d0e21e
LW
2749 while (items--) {
2750 if (*MARK)
b479c9f2 2751 {
60779a30 2752 if (SvPADTMP(*MARK)) {
b479c9f2 2753 *MARK = sv_mortalcopy(*MARK);
60779a30 2754 }
a0d0e21e 2755 SvTEMP_off(*MARK);
b479c9f2 2756 }
a0d0e21e
LW
2757 MARK++;
2758 }
2759 }
b479c9f2 2760 SAVETMPS;
f5719c02
DM
2761 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2762 !CvLVALUE(cv)))
da1dff94 2763 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
4a925ff6
GS
2764 /* warning must come *after* we fully set up the context
2765 * stuff so that __WARN__ handlers can safely dounwind()
2766 * if they want to
2767 */
3689ad62 2768 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
f5719c02
DM
2769 && ckWARN(WARN_RECURSION)
2770 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
4a925ff6 2771 sub_crush_depth(cv);
a0d0e21e
LW
2772 RETURNOP(CvSTART(cv));
2773 }
f1025168 2774 else {
de935cc9 2775 SSize_t markix = TOPMARK;
f1025168 2776
b479c9f2 2777 SAVETMPS;
3a76ca88 2778 PUTBACK;
f1025168 2779
f5719c02 2780 if (UNLIKELY(((PL_op->op_private
4587c532
FC
2781 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2782 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
f5719c02 2783 !CvLVALUE(cv)))
4587c532
FC
2784 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2785
f5719c02 2786 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3a76ca88
RGS
2787 /* Need to copy @_ to stack. Alternative may be to
2788 * switch stack to @_, and copy return values
2789 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2790 AV * const av = GvAV(PL_defgv);
ad39f3a2 2791 const SSize_t items = AvFILL(av) + 1;
3a76ca88
RGS
2792
2793 if (items) {
dd2a7f90 2794 SSize_t i = 0;
ad39f3a2 2795 const bool m = cBOOL(SvRMAGICAL(av));
3a76ca88
RGS
2796 /* Mark is at the end of the stack. */
2797 EXTEND(SP, items);
dd2a7f90 2798 for (; i < items; ++i)
ad39f3a2
FC
2799 {
2800 SV *sv;
2801 if (m) {
2802 SV ** const svp = av_fetch(av, i, 0);
2803 sv = svp ? *svp : NULL;
2804 }
2805 else sv = AvARRAY(av)[i];
2806 if (sv) SP[i+1] = sv;
dd2a7f90 2807 else {
199f858d 2808 SP[i+1] = newSVavdefelem(av, i, 1);
dd2a7f90 2809 }
ad39f3a2 2810 }
3a76ca88
RGS
2811 SP += items;
2812 PUTBACK ;
2813 }
2814 }
3455055f
FC
2815 else {
2816 SV **mark = PL_stack_base + markix;
de935cc9 2817 SSize_t items = SP - mark;
3455055f
FC
2818 while (items--) {
2819 mark++;
60779a30 2820 if (*mark && SvPADTMP(*mark)) {
3455055f 2821 *mark = sv_mortalcopy(*mark);
60779a30 2822 }
3455055f
FC
2823 }
2824 }
3a76ca88 2825 /* We assume first XSUB in &DB::sub is the called one. */
f5719c02 2826 if (UNLIKELY(PL_curcopdb)) {
3a76ca88
RGS
2827 SAVEVPTR(PL_curcop);
2828 PL_curcop = PL_curcopdb;
2829 PL_curcopdb = NULL;
2830 }
2831 /* Do we need to open block here? XXXX */
72df79cf 2832
2833 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2834 assert(CvXSUB(cv));
16c91539 2835 CvXSUB(cv)(aTHX_ cv);
3a76ca88
RGS
2836
2837 /* Enforce some sanity in scalar context. */
89a18b40
DM
2838 if (gimme == G_SCALAR) {
2839 SV **svp = PL_stack_base + markix + 1;
2840 if (svp != PL_stack_sp) {
2841 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
2842 PL_stack_sp = svp;
2843 }
3a76ca88 2844 }
a57c6685 2845 LEAVE;
f1025168
NC
2846 return NORMAL;
2847 }
a0d0e21e
LW
2848}
2849
44a8e56a 2850void
864dbfa3 2851Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 2852{
7918f24d
NC
2853 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2854
44a8e56a 2855 if (CvANON(cv))
9014280d 2856 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 2857 else {
35c1215d 2858 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
ecf05a58 2859 SVfARG(cv_name(cv,NULL,0)));
44a8e56a
PP
2860 }
2861}
2862
a0d0e21e
LW
2863PP(pp_aelem)
2864{
20b7effb 2865 dSP;
a0d0e21e 2866 SV** svp;
a3b680e6 2867 SV* const elemsv = POPs;
d804643f 2868 IV elem = SvIV(elemsv);
502c6561 2869 AV *const av = MUTABLE_AV(POPs);
e1ec3a88 2870 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
bbfdc870 2871 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4ad10a0b
VP
2872 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2873 bool preeminent = TRUE;
be6c24e0 2874 SV *sv;
a0d0e21e 2875
5d9574c1 2876 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
95b63a38
JH
2877 Perl_warner(aTHX_ packWARN(WARN_MISC),
2878 "Use of reference \"%"SVf"\" as array index",
be2597df 2879 SVfARG(elemsv));
5d9574c1 2880 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
a0d0e21e 2881 RETPUSHUNDEF;
4ad10a0b 2882
5d9574c1 2883 if (UNLIKELY(localizing)) {
4ad10a0b
VP
2884 MAGIC *mg;
2885 HV *stash;
2886
2887 /* If we can determine whether the element exist,
2888 * Try to preserve the existenceness of a tied array
2889 * element by using EXISTS and DELETE if possible.
2890 * Fallback to FETCH and STORE otherwise. */
2891 if (SvCANEXISTDELETE(av))
2892 preeminent = av_exists(av, elem);
2893 }
2894
68dc0745 2895 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2896 if (lval) {
2b573ace 2897#ifdef PERL_MALLOC_WRAP
2b573ace 2898 if (SvUOK(elemsv)) {
a9c4fd4e 2899 const UV uv = SvUV(elemsv);
2b573ace
JH
2900 elem = uv > IV_MAX ? IV_MAX : uv;
2901 }
2902 else if (SvNOK(elemsv))
2903 elem = (IV)SvNV(elemsv);
a3b680e6
AL
2904 if (elem > 0) {
2905 static const char oom_array_extend[] =
2906 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 2907 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 2908 }
2b573ace 2909#endif
ce0d59fd 2910 if (!svp || !*svp) {
bbfdc870 2911 IV len;
68dc0745 2912 if (!defer)
cea2e8a9 2913 DIE(aTHX_ PL_no_aelem, elem);
b9f2b683 2914 len = av_tindex(av);
199f858d 2915 mPUSHs(newSVavdefelem(av,
bbfdc870
FC
2916 /* Resolve a negative index now, unless it points before the
2917 beginning of the array, in which case record it for error
2918 reporting in magic_setdefelem. */
199f858d
FC
2919 elem < 0 && len + elem >= 0 ? len + elem : elem,
2920 1));
68dc0745
PP
2921 RETURN;
2922 }
5d9574c1 2923 if (UNLIKELY(localizing)) {
4ad10a0b
VP
2924 if (preeminent)
2925 save_aelem(av, elem, svp);
2926 else
2927 SAVEADELETE(av, elem);
2928 }
9026059d
GG
2929 else if (PL_op->op_private & OPpDEREF) {
2930 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2931 RETURN;
2932 }
a0d0e21e 2933 }
3280af22 2934 sv = (svp ? *svp : &PL_sv_undef);
39cf747a 2935 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 2936 mg_get(sv);
be6c24e0 2937 PUSHs(sv);
a0d0e21e
LW
2938 RETURN;
2939}
2940
9026059d 2941SV*
864dbfa3 2942Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 2943{
7918f24d
NC
2944 PERL_ARGS_ASSERT_VIVIFY_REF;
2945
5b295bef 2946 SvGETMAGIC(sv);
02a9e968
CS
2947 if (!SvOK(sv)) {
2948 if (SvREADONLY(sv))
cb077ed2 2949 Perl_croak_no_modify();
43230e26 2950 prepare_SV_for_RV(sv);
68dc0745 2951 switch (to_what) {
5f05dabc 2952 case OPpDEREF_SV:
561b68a9 2953 SvRV_set(sv, newSV(0));
5f05dabc
PP
2954 break;
2955 case OPpDEREF_AV:
ad64d0ec 2956 SvRV_set(sv, MUTABLE_SV(newAV()));
5f05dabc
PP
2957 break;
2958 case OPpDEREF_HV:
ad64d0ec 2959 SvRV_set(sv, MUTABLE_SV(newHV()));
5f05dabc
PP
2960 break;
2961 }
02a9e968
CS
2962 SvROK_on(sv);
2963 SvSETMAGIC(sv);
7e482323 2964 SvGETMAGIC(sv);
02a9e968 2965 }
9026059d
GG
2966 if (SvGMAGICAL(sv)) {
2967 /* copy the sv without magic to prevent magic from being
2968 executed twice */
2969 SV* msv = sv_newmortal();
2970 sv_setsv_nomg(msv, sv);
2971 return msv;
2972 }
2973 return sv;
02a9e968
CS
2974}
2975
7d6c333c 2976PERL_STATIC_INLINE HV *
2977S_opmethod_stash(pTHX_ SV* meth)
f5d5a27c 2978{
a0d0e21e 2979 SV* ob;
56304f61 2980 HV* stash;
b55b14d0 2981
d648ffcb 2982 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
f226e9be
FC
2983 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2984 "package or object reference", SVfARG(meth)),
2985 (SV *)NULL)
2986 : *(PL_stack_base + TOPMARK + 1);
f5d5a27c 2987
7d6c333c 2988 PERL_ARGS_ASSERT_OPMETHOD_STASH;
d648ffcb 2989
5d9574c1 2990 if (UNLIKELY(!sv))
7156e69a 2991 undefined:
a214957f
VP
2992 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2993 SVfARG(meth));
4f1b7578 2994
d648ffcb 2995 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
2996 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
2997 stash = gv_stashsv(sv, GV_CACHE_ONLY);
7d6c333c 2998 if (stash) return stash;
d648ffcb 2999 }
3000
a0d0e21e 3001 if (SvROK(sv))
ad64d0ec 3002 ob = MUTABLE_SV(SvRV(sv));
7156e69a 3003 else if (!SvOK(sv)) goto undefined;
a77c16f7
FC
3004 else if (isGV_with_GP(sv)) {
3005 if (!GvIO(sv))
3006 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3007 "without a package or object reference",
3008 SVfARG(meth));
3009 ob = sv;
3010 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3011 assert(!LvTARGLEN(ob));
3012 ob = LvTARG(ob);
3013 assert(ob);
3014 }
3015 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3016 }
a0d0e21e 3017 else {
89269094 3018 /* this isn't a reference */
a0d0e21e 3019 GV* iogv;
f937af42 3020 STRLEN packlen;
89269094 3021 const char * const packname = SvPV_nomg_const(sv, packlen);
d283e876 3022 const U32 packname_utf8 = SvUTF8(sv);
3023 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
7d6c333c 3024 if (stash) return stash;
081fc587 3025
89269094 3026 if (!(iogv = gv_fetchpvn_flags(
d283e876 3027 packname, packlen, packname_utf8, SVt_PVIO
da6b625f 3028 )) ||
ad64d0ec 3029 !(ob=MUTABLE_SV(GvIO(iogv))))
a0d0e21e 3030 {
af09ea45 3031 /* this isn't the name of a filehandle either */
89269094 3032 if (!packlen)
834a4ddd 3033 {
7156e69a
FC
3034 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3035 "without a package or object reference",
3036 SVfARG(meth));
834a4ddd 3037 }
af09ea45 3038 /* assume it's a package name */
d283e876 3039 stash = gv_stashpvn(packname, packlen, packname_utf8);
7d6c333c 3040 if (stash) return stash;
3041 else return MUTABLE_HV(sv);
a0d0e21e 3042 }
af09ea45 3043 /* it _is_ a filehandle name -- replace with a reference */
ad64d0ec 3044 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
a0d0e21e
LW
3045 }
3046
1f3ffe4c 3047 /* if we got here, ob should be an object or a glob */
f0d43078 3048 if (!ob || !(SvOBJECT(ob)
a77c16f7 3049 || (isGV_with_GP(ob)
159b6efe 3050 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
f0d43078
GS
3051 && SvOBJECT(ob))))
3052 {
b375e37b
BF
3053 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3054 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3055 ? newSVpvs_flags("DOES", SVs_TEMP)
3056 : meth));
f0d43078 3057 }
a0d0e21e 3058
7d6c333c 3059 return SvSTASH(ob);
3060}
3061
3062PP(pp_method)
3063{
3064 dSP;
3065 GV* gv;
3066 HV* stash;
3067 SV* const meth = TOPs;
3068
3069 if (SvROK(meth)) {
3070 SV* const rmeth = SvRV(meth);
3071 if (SvTYPE(rmeth) == SVt_PVCV) {
3072 SETs(rmeth);
3073 RETURN;
3074 }
3075 }
a0d0e21e 3076
7d6c333c 3077 stash = opmethod_stash(meth);
af09ea45 3078
7d6c333c 3079 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3080 assert(gv);
3081
3082 SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3083 RETURN;
3084}
3085
810bd8b7 3086#define METHOD_CHECK_CACHE(stash,cache,meth) \
3087 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
3088 if (he) { \
3089 gv = MUTABLE_GV(HeVAL(he)); \
3090 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
3091 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
3092 { \
3093 XPUSHs(MUTABLE_SV(GvCV(gv))); \
3094 RETURN; \
3095 } \
3096 } \
3097
7d6c333c 3098PP(pp_method_named)
3099{
3100 dSP;
3101 GV* gv;
3102 SV* const meth = cMETHOPx_meth(PL_op);
3103 HV* const stash = opmethod_stash(meth);
3104
3105 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
810bd8b7 3106 METHOD_CHECK_CACHE(stash, stash, meth);
f5d5a27c
CS
3107 }
3108
7d6c333c 3109 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
256d1bb2 3110 assert(gv);
9b9d0b15 3111
7d6c333c 3112 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3113 RETURN;
3114}
3115
3116PP(pp_method_super)
3117{
3118 dSP;
3119 GV* gv;
3120 HV* cache;
3121 SV* const meth = cMETHOPx_meth(PL_op);
3122 HV* const stash = CopSTASH(PL_curcop);
3123 /* Actually, SUPER doesn't need real object's (or class') stash at all,
3124 * as it uses CopSTASH. However, we must ensure that object(class) is
3125 * correct (this check is done by S_opmethod_stash) */
3126 opmethod_stash(meth);
3127
3128 if ((cache = HvMROMETA(stash)->super)) {
810bd8b7 3129 METHOD_CHECK_CACHE(stash, cache, meth);
3130 }
3131
3132 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3133 assert(gv);
3134
3135 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3136 RETURN;
3137}
3138
3139PP(pp_method_redir)
3140{
3141 dSP;
3142 GV* gv;
3143 SV* const meth = cMETHOPx_meth(PL_op);
3144 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3145 opmethod_stash(meth); /* not used but needed for error checks */
3146
3147 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
3148 else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3149
3150 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3151 assert(gv);
3152
3153 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3154 RETURN;
3155}
3156
3157PP(pp_method_redir_super)
3158{
3159 dSP;
3160 GV* gv;
3161 HV* cache;
3162 SV* const meth = cMETHOPx_meth(PL_op);
3163 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3164 opmethod_stash(meth); /* not used but needed for error checks */
3165
3166 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3167 else if ((cache = HvMROMETA(stash)->super)) {
3168 METHOD_CHECK_CACHE(stash, cache, meth);
7d6c333c 3169 }
3170
3171 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3172 assert(gv);
3173
3174 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3175 RETURN;
a0d0e21e 3176}
241d1a3b
NC
3177
3178/*
3179 * Local variables:
3180 * c-indentation-style: bsd
3181 * c-basic-offset: 4
14d04a33 3182 * indent-tabs-mode: nil
241d1a3b
NC
3183 * End:
3184 *
14d04a33 3185 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3186 */