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