This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Split Perl_do_openn() into Perl_do_open_raw() and Perl_do_open6().
[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;
4608196e 1565 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
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++)
7ad1e72d 1701 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
a0d0e21e 1702 break;
349d4f2f 1703 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1704 (void)POPs; /* Unmatched wildcard? Chuck it... */
1705 continue;
1706 }
2d79bf7f 1707 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
1708 if (ckWARN(WARN_UTF8)) {
1709 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1710 const STRLEN len = SvCUR(sv) - offset;
1711 const U8 *f;
1712
1713 if (!is_utf8_string_loc(s, len, &f))
1714 /* Emulate :encoding(utf8) warning in the same case. */
1715 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1716 "utf8 \"\\x%02X\" does not map to Unicode",
1717 f < (U8*)SvEND(sv) ? *f : 0);
1718 }
a0d0e21e 1719 }
54310121 1720 if (gimme == G_ARRAY) {
a0d0e21e 1721 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 1722 SvPV_shrink_to_cur(sv);
a0d0e21e 1723 }
561b68a9 1724 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
1725 continue;
1726 }
54310121 1727 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 1728 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
1729 const STRLEN new_len
1730 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 1731 SvPV_renew(sv, new_len);
a0d0e21e
LW
1732 }
1733 RETURN;
1734 }
1735}
1736
a0d0e21e
LW
1737PP(pp_helem)
1738{
97aff369 1739 dVAR; dSP;
760ac839 1740 HE* he;
ae77835f 1741 SV **svp;
c445ea15 1742 SV * const keysv = POPs;
85fbaab2 1743 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
1744 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1745 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1746 SV *sv;
92970b93 1747 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 1748 bool preeminent = TRUE;
a0d0e21e 1749
d4c19fe8 1750 if (SvTYPE(hv) != SVt_PVHV)
a0d0e21e 1751 RETPUSHUNDEF;
d4c19fe8 1752
92970b93 1753 if (localizing) {
d4c19fe8
AL
1754 MAGIC *mg;
1755 HV *stash;
d30e492c
VP
1756
1757 /* If we can determine whether the element exist,
1758 * Try to preserve the existenceness of a tied hash
1759 * element by using EXISTS and DELETE if possible.
1760 * Fallback to FETCH and STORE otherwise. */
2c5f48c2 1761 if (SvCANEXISTDELETE(hv))
d30e492c 1762 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 1763 }
d30e492c 1764
5f9d7e2b 1765 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
d4c19fe8 1766 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 1767 if (lval) {
746f6409 1768 if (!svp || !*svp || *svp == &PL_sv_undef) {
68dc0745
PP
1769 SV* lv;
1770 SV* key2;
2d8e6c8d 1771 if (!defer) {
be2597df 1772 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 1773 }
68dc0745
PP
1774 lv = sv_newmortal();
1775 sv_upgrade(lv, SVt_PVLV);
1776 LvTYPE(lv) = 'y';
6136c704 1777 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
fc2b2dca 1778 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
b37c2d43 1779 LvTARG(lv) = SvREFCNT_inc_simple(hv);
68dc0745
PP
1780 LvTARGLEN(lv) = 1;
1781 PUSHs(lv);
1782 RETURN;
1783 }
92970b93 1784 if (localizing) {
bfcb3514 1785 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 1786 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
1787 else if (preeminent)
1788 save_helem_flags(hv, keysv, svp,
1789 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1790 else
1791 SAVEHDELETE(hv, keysv);
5f05dabc 1792 }
9026059d
GG
1793 else if (PL_op->op_private & OPpDEREF) {
1794 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1795 RETURN;
1796 }
a0d0e21e 1797 }
746f6409 1798 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
1799 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1800 * was to make C<local $tied{foo} = $tied{foo}> possible.
1801 * However, it seems no longer to be needed for that purpose, and
1802 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1803 * would loop endlessly since the pos magic is getting set on the
1804 * mortal copy and lost. However, the copy has the effect of
1805 * triggering the get magic, and losing it altogether made things like
1806 * c<$tied{foo};> in void context no longer do get magic, which some
1807 * code relied on. Also, delayed triggering of magic on @+ and friends
1808 * meant the original regex may be out of scope by now. So as a
1809 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1810 * being called too many times). */
39cf747a 1811 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 1812 mg_get(sv);
be6c24e0 1813 PUSHs(sv);
a0d0e21e
LW
1814 RETURN;
1815}
1816
a0d0e21e
LW
1817PP(pp_iter)
1818{
97aff369 1819 dVAR; dSP;
eb578fdb 1820 PERL_CONTEXT *cx;
7d6c2cef 1821 SV *oldsv;
1d7c1841 1822 SV **itersvp;
a0d0e21e 1823
924508f0 1824 EXTEND(SP, 1);
a0d0e21e 1825 cx = &cxstack[cxstack_ix];
1d7c1841 1826 itersvp = CxITERVAR(cx);
a48ce6be
DM
1827
1828 switch (CxTYPE(cx)) {
17c91640 1829
b552b52c
DM
1830 case CXt_LOOP_LAZYSV: /* string increment */
1831 {
1832 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1833 SV *end = cx->blk_loop.state_u.lazysv.end;
1834 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1835 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1836 STRLEN maxlen = 0;
1837 const char *max = SvPV_const(end, maxlen);
5d9574c1 1838 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
b552b52c
DM
1839 RETPUSHNO;
1840
1841 oldsv = *itersvp;
5d9574c1 1842 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
b552b52c
DM
1843 /* safe to reuse old SV */
1844 sv_setsv(oldsv, cur);
a48ce6be 1845 }
b552b52c
DM
1846 else
1847 {
1848 /* we need a fresh SV every time so that loop body sees a
1849 * completely new SV for closures/references to work as
1850 * they used to */
1851 *itersvp = newSVsv(cur);
fc2b2dca 1852 SvREFCNT_dec_NN(oldsv);
b552b52c
DM
1853 }
1854 if (strEQ(SvPVX_const(cur), max))
1855 sv_setiv(cur, 0); /* terminate next time */
1856 else
1857 sv_inc(cur);
1858 break;
1859 }
a48ce6be 1860
fcef60b4
DM
1861 case CXt_LOOP_LAZYIV: /* integer increment */
1862 {
1863 IV cur = cx->blk_loop.state_u.lazyiv.cur;
5d9574c1 1864 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
89ea2908 1865 RETPUSHNO;
7f61b687 1866
fcef60b4 1867 oldsv = *itersvp;
3db8f154 1868 /* don't risk potential race */
5d9574c1 1869 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
eaa5c2d6 1870 /* safe to reuse old SV */
fcef60b4 1871 sv_setiv(oldsv, cur);
eaa5c2d6 1872 }
1c846c1f 1873 else
eaa5c2d6
GA
1874 {
1875 /* we need a fresh SV every time so that loop body sees a
1876 * completely new SV for closures/references to work as they
1877 * used to */
fcef60b4 1878 *itersvp = newSViv(cur);
fc2b2dca 1879 SvREFCNT_dec_NN(oldsv);
eaa5c2d6 1880 }
a2309040 1881
5d9574c1 1882 if (UNLIKELY(cur == IV_MAX)) {
cdc1aa42
NC
1883 /* Handle end of range at IV_MAX */
1884 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1885 } else
1886 ++cx->blk_loop.state_u.lazyiv.cur;
a48ce6be 1887 break;
fcef60b4 1888 }
a48ce6be 1889
b552b52c 1890 case CXt_LOOP_FOR: /* iterate array */
7d6c2cef 1891 {
89ea2908 1892
7d6c2cef
DM
1893 AV *av = cx->blk_loop.state_u.ary.ary;
1894 SV *sv;
1895 bool av_is_stack = FALSE;
a8a20bb6 1896 IV ix;
7d6c2cef 1897
de080daa
DM
1898 if (!av) {
1899 av_is_stack = TRUE;
1900 av = PL_curstack;
1901 }
1902 if (PL_op->op_private & OPpITER_REVERSED) {
a8a20bb6 1903 ix = --cx->blk_loop.state_u.ary.ix;
5d9574c1 1904 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
de080daa 1905 RETPUSHNO;
de080daa
DM
1906 }
1907 else {
a8a20bb6 1908 ix = ++cx->blk_loop.state_u.ary.ix;
5d9574c1 1909 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
de080daa 1910 RETPUSHNO;
a8a20bb6 1911 }
de080daa 1912
5d9574c1 1913 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
a8a20bb6
DM
1914 SV * const * const svp = av_fetch(av, ix, FALSE);
1915 sv = svp ? *svp : NULL;
1916 }
1917 else {
1918 sv = AvARRAY(av)[ix];
de080daa 1919 }
ef3e5ea9 1920
5d9574c1
DM
1921 if (LIKELY(sv)) {
1922 if (UNLIKELY(SvIS_FREED(sv))) {
f38aa882
DM
1923 *itersvp = NULL;
1924 Perl_croak(aTHX_ "Use of freed value in iteration");
1925 }
60779a30
DM
1926 if (SvPADTMP(sv)) {
1927 assert(!IS_PADGV(sv));
8e079c2a 1928 sv = newSVsv(sv);
60779a30 1929 }
8e079c2a
FC
1930 else {
1931 SvTEMP_off(sv);
1932 SvREFCNT_inc_simple_void_NN(sv);
1933 }
de080daa 1934 }
a600f7e6 1935 else if (!av_is_stack) {
199f858d 1936 sv = newSVavdefelem(av, ix, 0);
de080daa 1937 }
a600f7e6
FC
1938 else
1939 sv = &PL_sv_undef;
a0d0e21e 1940
de080daa
DM
1941 oldsv = *itersvp;
1942 *itersvp = sv;
1943 SvREFCNT_dec(oldsv);
de080daa 1944 break;
7d6c2cef 1945 }
a48ce6be
DM
1946
1947 default:
1948 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1949 }
b552b52c 1950 RETPUSHYES;
a0d0e21e
LW
1951}
1952
ef07e810
DM
1953/*
1954A description of how taint works in pattern matching and substitution.
1955
284167a5
SM
1956This is all conditional on NO_TAINT_SUPPORT not being defined. Under
1957NO_TAINT_SUPPORT, taint-related operations should become no-ops.
1958
4e19c54b 1959While the pattern is being assembled/concatenated and then compiled,
284167a5
SM
1960PL_tainted will get set (via TAINT_set) if any component of the pattern
1961is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
1962the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
63baef57
KW
1963TAINT_get). Also, if any component of the pattern matches based on
1964locale-dependent behavior, the RXf_TAINTED_SEEN flag is set.
ef07e810 1965
0ab462a6
DM
1966When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1967the pattern is marked as tainted. This means that subsequent usage, such
284167a5
SM
1968as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
1969on the new pattern too.
ef07e810 1970
272d35c9 1971RXf_TAINTED_SEEN is used post-execution by the get magic code
ef07e810
DM
1972of $1 et al to indicate whether the returned value should be tainted.
1973It is the responsibility of the caller of the pattern (i.e. pp_match,
1974pp_subst etc) to set this flag for any other circumstances where $1 needs
1975to be tainted.
1976
1977The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1978
1979There are three possible sources of taint
1980 * the source string
1981 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1982 * the replacement string (or expression under /e)
1983
1984There are four destinations of taint and they are affected by the sources
1985according to the rules below:
1986
1987 * the return value (not including /r):
1988 tainted by the source string and pattern, but only for the
1989 number-of-iterations case; boolean returns aren't tainted;
1990 * the modified string (or modified copy under /r):
1991 tainted by the source string, pattern, and replacement strings;
1992 * $1 et al:
1993 tainted by the pattern, and under 'use re "taint"', by the source
1994 string too;
1995 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
1996 should always be unset before executing subsequent code.
1997
1998The overall action of pp_subst is:
1999
2000 * at the start, set bits in rxtainted indicating the taint status of
2001 the various sources.
2002
2003 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2004 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2005 pattern has subsequently become tainted via locale ops.
2006
2007 * If control is being passed to pp_substcont to execute a /e block,
2008 save rxtainted in the CXt_SUBST block, for future use by
2009 pp_substcont.
2010
2011 * Whenever control is being returned to perl code (either by falling
2012 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2013 use the flag bits in rxtainted to make all the appropriate types of
0ab462a6
DM
2014 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2015 et al will appear tainted.
ef07e810
DM
2016
2017pp_match is just a simpler version of the above.
2018
2019*/
2020
a0d0e21e
LW
2021PP(pp_subst)
2022{
97aff369 2023 dVAR; dSP; dTARG;
eb578fdb 2024 PMOP *pm = cPMOP;
a0d0e21e 2025 PMOP *rpm = pm;
eb578fdb 2026 char *s;
a0d0e21e 2027 char *strend;
5c144d81 2028 const char *c;
a0d0e21e
LW
2029 STRLEN clen;
2030 I32 iters = 0;
2031 I32 maxiters;
a0d0e21e 2032 bool once;
ef07e810
DM
2033 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2034 See "how taint works" above */
a0d0e21e 2035 char *orig;
1ed74d04 2036 U8 r_flags;
eb578fdb 2037 REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
2038 STRLEN len;
2039 int force_on_match = 0;
0bcc34c2 2040 const I32 oldsave = PL_savestack_ix;
792b2c16 2041 STRLEN slen;
26a74523 2042 bool doutf8 = FALSE; /* whether replacement is in utf8 */
db2c6cb3 2043#ifdef PERL_ANY_COW
ed252734
NC
2044 bool is_cow;
2045#endif
a0714e2c 2046 SV *nsv = NULL;
b770e143 2047 /* known replacement string? */
eb578fdb 2048 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
a0d0e21e 2049
f410a211
NC
2050 PERL_ASYNC_CHECK();
2051
533c011a 2052 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 2053 TARG = POPs;
59f00321
RGS
2054 else if (PL_op->op_private & OPpTARGET_MY)
2055 GETTARGET;
a0d0e21e 2056 else {
54b9620d 2057 TARG = DEFSV;
a0d0e21e 2058 EXTEND(SP,1);
1c846c1f 2059 }
d9f424b2 2060
64534138 2061 SvGETMAGIC(TARG); /* must come before cow check */
db2c6cb3 2062#ifdef PERL_ANY_COW
ed252734
NC
2063 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2064 because they make integers such as 256 "false". */
2065 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2066#else
765f542d
NC
2067 if (SvIsCOW(TARG))
2068 sv_force_normal_flags(TARG,0);
ed252734 2069#endif
8ca8a454 2070 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
8ca8a454
NC
2071 && (SvREADONLY(TARG)
2072 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2073 || SvTYPE(TARG) > SVt_PVLV)
2074 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
cb077ed2 2075 Perl_croak_no_modify();
8ec5e241
NIS
2076 PUTBACK;
2077
6ac6605d
DM
2078 orig = SvPV_nomg(TARG, len);
2079 /* note we don't (yet) force the var into being a string; if we fail
2080 * to match, we leave as-is; on successful match howeverm, we *will*
2081 * coerce into a string, then repeat the match */
4499db73 2082 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
a0d0e21e 2083 force_on_match = 1;
20be6587
DM
2084
2085 /* only replace once? */
2086 once = !(rpm->op_pmflags & PMf_GLOBAL);
2087
ef07e810 2088 /* See "how taint works" above */
284167a5 2089 if (TAINTING_get) {
20be6587
DM
2090 rxtainted = (
2091 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
284167a5 2092 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
20be6587
DM
2093 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2094 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2095 ? SUBST_TAINT_BOOLRET : 0));
2096 TAINT_NOT;
2097 }
a12c0f56 2098
a0d0e21e 2099 force_it:
6ac6605d
DM
2100 if (!pm || !orig)
2101 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
a0d0e21e 2102
6ac6605d
DM
2103 strend = orig + len;
2104 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
792b2c16
JH
2105 maxiters = 2 * slen + 10; /* We can match twice at each
2106 position, once with zero-length,
2107 second time with non-zero. */
a0d0e21e 2108
6a97c51d 2109 if (!RX_PRELEN(rx) && PL_curpm
8d919b0a 2110 && !ReANY(rx)->mother_re) {
3280af22 2111 pm = PL_curpm;
aaa362c4 2112 rx = PM_GETRE(pm);
a0d0e21e 2113 }
6502e081 2114
6e240d0b 2115#ifdef PERL_SAWAMPERSAND
6502e081
DM
2116 r_flags = ( RX_NPARENS(rx)
2117 || PL_sawampersand
6502e081 2118 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 2119 || (rpm->op_pmflags & PMf_KEEPCOPY)
6502e081
DM
2120 )
2121 ? REXEC_COPY_STR
2122 : 0;
6e240d0b
FC
2123#else
2124 r_flags = REXEC_COPY_STR;
2125#endif
7fba1cd6 2126
0395280b 2127 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
8b64c330 2128 {
5e79dfb9
DM
2129 SPAGAIN;
2130 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2131 LEAVE_SCOPE(oldsave);
2132 RETURN;
2133 }
1754320d
FC
2134 PL_curpm = pm;
2135
71be2cbc 2136 /* known replacement string? */
f272994b 2137 if (dstr) {
8514a05a
JH
2138 /* replacement needing upgrading? */
2139 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2140 nsv = sv_newmortal();
4a176938 2141 SvSetSV(nsv, dstr);
8514a05a
JH
2142 if (PL_encoding)
2143 sv_recode_to_utf8(nsv, PL_encoding);
2144 else
2145 sv_utf8_upgrade(nsv);
5c144d81 2146 c = SvPV_const(nsv, clen);
4a176938
JH
2147 doutf8 = TRUE;
2148 }
2149 else {
5c144d81 2150 c = SvPV_const(dstr, clen);
4a176938 2151 doutf8 = DO_UTF8(dstr);
8514a05a 2152 }
bb933b9b
FC
2153
2154 if (SvTAINTED(dstr))
2155 rxtainted |= SUBST_TAINT_REPL;
f272994b
A
2156 }
2157 else {
6136c704 2158 c = NULL;
f272994b
A
2159 doutf8 = FALSE;
2160 }
2161
71be2cbc 2162 /* can do inplace substitution? */
ed252734 2163 if (c
db2c6cb3 2164#ifdef PERL_ANY_COW
ed252734
NC
2165 && !is_cow
2166#endif
fbfb1899 2167 && (I32)clen <= RX_MINLENRET(rx)
9cefd268
FC
2168 && ( once
2169 || !(r_flags & REXEC_COPY_STR)
2170 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2171 )
dbc200c5 2172 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
8ca8a454
NC
2173 && (!doutf8 || SvUTF8(TARG))
2174 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
8b030b38 2175 {
ec911639 2176
db2c6cb3 2177#ifdef PERL_ANY_COW
ed252734 2178 if (SvIsCOW(TARG)) {
f7a8268c 2179 if (!force_on_match)
ed252734 2180 goto have_a_cow;
f7a8268c 2181 assert(SvVOK(TARG));
ed252734
NC
2182 }
2183#endif
71be2cbc 2184 if (force_on_match) {
6ac6605d
DM
2185 /* redo the first match, this time with the orig var
2186 * forced into being a string */
71be2cbc 2187 force_on_match = 0;
6ac6605d 2188 orig = SvPV_force_nomg(TARG, len);
71be2cbc
PP
2189 goto force_it;
2190 }
39b40493 2191
71be2cbc 2192 if (once) {
c67ab8f2 2193 char *d, *m;
20be6587
DM
2194 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2195 rxtainted |= SUBST_TAINT_PAT;
07bc277f
NC
2196 m = orig + RX_OFFS(rx)[0].start;
2197 d = orig + RX_OFFS(rx)[0].end;
71be2cbc
PP
2198 s = orig;
2199 if (m - s > strend - d) { /* faster to shorten from end */
2ec7214c 2200 I32 i;
71be2cbc
PP
2201 if (clen) {
2202 Copy(c, m, clen, char);
2203 m += clen;
a0d0e21e 2204 }
71be2cbc
PP
2205 i = strend - d;
2206 if (i > 0) {
2207 Move(d, m, i, char);
2208 m += i;
a0d0e21e 2209 }
71be2cbc
PP
2210 *m = '\0';
2211 SvCUR_set(TARG, m - s);
2212 }
2ec7214c
DM
2213 else { /* faster from front */
2214 I32 i = m - s;
71be2cbc 2215 d -= clen;
2ec7214c
DM
2216 if (i > 0)
2217 Move(s, d - i, i, char);
71be2cbc 2218 sv_chop(TARG, d-i);
71be2cbc 2219 if (clen)
c947cd8d 2220 Copy(c, d, clen, char);
71be2cbc 2221 }
8ec5e241 2222 SPAGAIN;
8ca8a454 2223 PUSHs(&PL_sv_yes);
71be2cbc
PP
2224 }
2225 else {
c67ab8f2 2226 char *d, *m;
0395280b 2227 d = s = RX_OFFS(rx)[0].start + orig;
71be2cbc 2228 do {
2b25edcf 2229 I32 i;
5d9574c1 2230 if (UNLIKELY(iters++ > maxiters))
cea2e8a9 2231 DIE(aTHX_ "Substitution loop");
5d9574c1 2232 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
20be6587 2233 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2234 m = RX_OFFS(rx)[0].start + orig;
155aba94 2235 if ((i = m - s)) {
71be2cbc
PP
2236 if (s != d)
2237 Move(s, d, i, char);
2238 d += i;
a0d0e21e 2239 }
71be2cbc
PP
2240 if (clen) {
2241 Copy(c, d, clen, char);
2242 d += clen;
2243 }
07bc277f 2244 s = RX_OFFS(rx)[0].end + orig;
7ce41e5c
FC
2245 } while (CALLREGEXEC(rx, s, strend, orig,
2246 s == m, /* don't match same null twice */
f722798b 2247 TARG, NULL,
d5e7783a 2248 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
71be2cbc 2249 if (s != d) {
2b25edcf 2250 I32 i = strend - s;
aa07b2f6 2251 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 2252 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2253 }
8ec5e241 2254 SPAGAIN;
8ca8a454 2255 mPUSHi((I32)iters);
a0d0e21e
LW
2256 }
2257 }
ff6e92e8 2258 else {
1754320d 2259 bool first;
c67ab8f2 2260 char *m;
1754320d 2261 SV *repl;
a0d0e21e 2262 if (force_on_match) {
6ac6605d
DM
2263 /* redo the first match, this time with the orig var
2264 * forced into being a string */
a0d0e21e 2265 force_on_match = 0;
0c1438a1
NC
2266 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2267 /* I feel that it should be possible to avoid this mortal copy
2268 given that the code below copies into a new destination.
2269 However, I suspect it isn't worth the complexity of
2270 unravelling the C<goto force_it> for the small number of
2271 cases where it would be viable to drop into the copy code. */
2272 TARG = sv_2mortal(newSVsv(TARG));
2273 }
6ac6605d 2274 orig = SvPV_force_nomg(TARG, len);
a0d0e21e
LW
2275 goto force_it;
2276 }
db2c6cb3 2277#ifdef PERL_ANY_COW
ed252734
NC
2278 have_a_cow:
2279#endif
20be6587
DM
2280 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2281 rxtainted |= SUBST_TAINT_PAT;
1754320d 2282 repl = dstr;
0395280b
DM
2283 s = RX_OFFS(rx)[0].start + orig;
2284 dstr = newSVpvn_flags(orig, s-orig,
2285 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
a0d0e21e 2286 if (!c) {
eb578fdb 2287 PERL_CONTEXT *cx;
8ec5e241 2288 SPAGAIN;
0395280b 2289 m = orig;
20be6587
DM
2290 /* note that a whole bunch of local vars are saved here for
2291 * use by pp_substcont: here's a list of them in case you're
2292 * searching for places in this sub that uses a particular var:
2293 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2294 * s m strend rx once */
a0d0e21e 2295 PUSHSUBST(cx);
20e98b0f 2296 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
a0d0e21e 2297 }
1754320d 2298 first = TRUE;
a0d0e21e 2299 do {
5d9574c1 2300 if (UNLIKELY(iters++ > maxiters))
cea2e8a9 2301 DIE(aTHX_ "Substitution loop");
5d9574c1 2302 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
20be6587 2303 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2304 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
c67ab8f2
DM
2305 char *old_s = s;
2306 char *old_orig = orig;
6502e081 2307 assert(RX_SUBOFFSET(rx) == 0);
c67ab8f2 2308
07bc277f 2309 orig = RX_SUBBEG(rx);
c67ab8f2
DM
2310 s = orig + (old_s - old_orig);
2311 strend = s + (strend - old_s);
a0d0e21e 2312 }
07bc277f 2313 m = RX_OFFS(rx)[0].start + orig;
64534138 2314 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
07bc277f 2315 s = RX_OFFS(rx)[0].end + orig;
1754320d
FC
2316 if (first) {
2317 /* replacement already stringified */
2318 if (clen)
64534138 2319 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
1754320d
FC
2320 first = FALSE;
2321 }
2322 else {
1754320d
FC
2323 if (PL_encoding) {
2324 if (!nsv) nsv = sv_newmortal();
2325 sv_copypv(nsv, repl);
2326 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2327 sv_catsv(dstr, nsv);
2328 }
2329 else sv_catsv(dstr, repl);
5d9574c1 2330 if (UNLIKELY(SvTAINTED(repl)))
bb933b9b 2331 rxtainted |= SUBST_TAINT_REPL;
1754320d 2332 }
a0d0e21e
LW
2333 if (once)
2334 break;
f9f4320a 2335 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
d5e7783a
DM
2336 TARG, NULL,
2337 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
64534138 2338 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
748a9306 2339
8ca8a454
NC
2340 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2341 /* From here on down we're using the copy, and leaving the original
2342 untouched. */
2343 TARG = dstr;
2344 SPAGAIN;
2345 PUSHs(dstr);
2346 } else {
db2c6cb3 2347#ifdef PERL_ANY_COW
8ca8a454
NC
2348 /* The match may make the string COW. If so, brilliant, because
2349 that's just saved us one malloc, copy and free - the regexp has
2350 donated the old buffer, and we malloc an entirely new one, rather
2351 than the regexp malloc()ing a buffer and copying our original,
2352 only for us to throw it away here during the substitution. */
2353 if (SvIsCOW(TARG)) {
2354 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2355 } else
ed252734 2356#endif
8ca8a454
NC
2357 {
2358 SvPV_free(TARG);
2359 }
2360 SvPV_set(TARG, SvPVX(dstr));
2361 SvCUR_set(TARG, SvCUR(dstr));
2362 SvLEN_set(TARG, SvLEN(dstr));
64534138 2363 SvFLAGS(TARG) |= SvUTF8(dstr);
8ca8a454 2364 SvPV_set(dstr, NULL);
748a9306 2365
8ca8a454 2366 SPAGAIN;
4f4d7508 2367 mPUSHi((I32)iters);
8ca8a454
NC
2368 }
2369 }
2370
2371 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2372 (void)SvPOK_only_UTF8(TARG);
a0d0e21e 2373 }
20be6587 2374
ef07e810 2375 /* See "how taint works" above */
284167a5 2376 if (TAINTING_get) {
20be6587
DM
2377 if ((rxtainted & SUBST_TAINT_PAT) ||
2378 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2379 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2380 )
2381 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2382
2383 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2384 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2385 )
2386 SvTAINTED_on(TOPs); /* taint return value */
2387 else
2388 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2389
2390 /* needed for mg_set below */
284167a5
SM
2391 TAINT_set(
2392 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2393 );
20be6587
DM
2394 SvTAINT(TARG);
2395 }
2396 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2397 TAINT_NOT;
f1a76097
DM
2398 LEAVE_SCOPE(oldsave);
2399 RETURN;
a0d0e21e
LW
2400}
2401
2402PP(pp_grepwhile)
2403{
27da23d5 2404 dVAR; dSP;
a0d0e21e
LW
2405
2406 if (SvTRUEx(POPs))
3280af22
NIS
2407 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2408 ++*PL_markstack_ptr;
b2a2a901 2409 FREETMPS;
d343c3ef 2410 LEAVE_with_name("grep_item"); /* exit inner scope */
a0d0e21e
LW
2411
2412 /* All done yet? */
5d9574c1 2413 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
a0d0e21e 2414 I32 items;
c4420975 2415 const I32 gimme = GIMME_V;
a0d0e21e 2416
d343c3ef 2417 LEAVE_with_name("grep"); /* exit outer scope */
a0d0e21e 2418 (void)POPMARK; /* pop src */
3280af22 2419 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2420 (void)POPMARK; /* pop dst */
3280af22 2421 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2422 if (gimme == G_SCALAR) {
7cc47870 2423 if (PL_op->op_private & OPpGREP_LEX) {
c4420975 2424 SV* const sv = sv_newmortal();
7cc47870
RGS
2425 sv_setiv(sv, items);
2426 PUSHs(sv);
2427 }
2428 else {
2429 dTARGET;
2430 XPUSHi(items);
2431 }
a0d0e21e 2432 }
54310121
PP
2433 else if (gimme == G_ARRAY)
2434 SP += items;
a0d0e21e
LW
2435 RETURN;
2436 }
2437 else {
2438 SV *src;
2439
d343c3ef 2440 ENTER_with_name("grep_item"); /* enter inner scope */
1d7c1841 2441 SAVEVPTR(PL_curpm);
a0d0e21e 2442
3280af22 2443 src = PL_stack_base[*PL_markstack_ptr];
60779a30
DM
2444 if (SvPADTMP(src)) {
2445 assert(!IS_PADGV(src));
a0ed822e
FC
2446 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2447 PL_tmps_floor++;
2448 }
a0d0e21e 2449 SvTEMP_off(src);
59f00321
RGS
2450 if (PL_op->op_private & OPpGREP_LEX)
2451 PAD_SVl(PL_op->op_targ) = src;
2452 else
414bf5ae 2453 DEFSV_set(src);
a0d0e21e
LW
2454
2455 RETURNOP(cLOGOP->op_other);
2456 }
2457}
2458
2459PP(pp_leavesub)
2460{
27da23d5 2461 dVAR; dSP;
a0d0e21e
LW
2462 SV **mark;
2463 SV **newsp;
2464 PMOP *newpm;
2465 I32 gimme;
eb578fdb 2466 PERL_CONTEXT *cx;
b0d9ce38 2467 SV *sv;
a0d0e21e 2468
9850bf21
RH
2469 if (CxMULTICALL(&cxstack[cxstack_ix]))
2470 return 0;
2471
a0d0e21e 2472 POPBLOCK(cx,newpm);
5dd42e15 2473 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2474
a1f49e72 2475 TAINT_NOT;
a0d0e21e
LW
2476 if (gimme == G_SCALAR) {
2477 MARK = newsp + 1;
5d9574c1 2478 if (LIKELY(MARK <= SP)) {
a8bba7fa 2479 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
6f48390a
FC
2480 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2481 && !SvMAGICAL(TOPs)) {
a29cdaf0
IZ
2482 *MARK = SvREFCNT_inc(TOPs);
2483 FREETMPS;
2484 sv_2mortal(*MARK);
cd06dffe
GS
2485 }
2486 else {
959e3673 2487 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2488 FREETMPS;
959e3673 2489 *MARK = sv_mortalcopy(sv);
fc2b2dca 2490 SvREFCNT_dec_NN(sv);
a29cdaf0 2491 }
cd06dffe 2492 }
6f48390a
FC
2493 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2494 && !SvMAGICAL(TOPs)) {
767eda44 2495 *MARK = TOPs;
767eda44 2496 }
cd06dffe 2497 else
767eda44 2498 *MARK = sv_mortalcopy(TOPs);
cd06dffe
GS
2499 }
2500 else {
f86702cc 2501 MEXTEND(MARK, 0);
3280af22 2502 *MARK = &PL_sv_undef;
a0d0e21e
LW
2503 }
2504 SP = MARK;
2505 }
54310121 2506 else if (gimme == G_ARRAY) {
f86702cc 2507 for (MARK = newsp + 1; MARK <= SP; MARK++) {
6f48390a
FC
2508 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2509 || SvMAGICAL(*MARK)) {
f86702cc 2510 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2511 TAINT_NOT; /* Each item is independent */
2512 }
f86702cc 2513 }
a0d0e21e 2514 }
f86702cc 2515 PUTBACK;
1c846c1f 2516
a57c6685 2517 LEAVE;
b0d9ce38 2518 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
25375124 2519 cxstack_ix--;
3280af22 2520 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2521
b0d9ce38 2522 LEAVESUB(sv);
f39bc417 2523 return cx->blk_sub.retop;
a0d0e21e
LW
2524}
2525
2526PP(pp_entersub)
2527{
27da23d5 2528 dVAR; dSP; dPOPss;
a0d0e21e 2529 GV *gv;
eb578fdb
KW
2530 CV *cv;
2531 PERL_CONTEXT *cx;
5d94fbed 2532 I32 gimme;
a9c4fd4e 2533 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e 2534
f5719c02 2535 if (UNLIKELY(!sv))
cea2e8a9 2536 DIE(aTHX_ "Not a CODE reference");
f5719c02
DM
2537 /* This is overwhelmingly the most common case: */
2538 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
313107ce
DM
2539 switch (SvTYPE(sv)) {
2540 case SVt_PVGV:
2541 we_have_a_glob:
2542 if (!(cv = GvCVu((const GV *)sv))) {
2543 HV *stash;
2544 cv = sv_2cv(sv, &stash, &gv, 0);
2545 }
2546 if (!cv) {
2547 ENTER;
2548 SAVETMPS;
2549 goto try_autoload;
2550 }
2551 break;
2552 case SVt_PVLV:
2553 if(isGV_with_GP(sv)) goto we_have_a_glob;
2554 /*FALLTHROUGH*/
2555 default:
2556 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2557 if (hasargs)
2558 SP = PL_stack_base + POPMARK;
2559 else
2560 (void)POPMARK;
2561 RETURN;
2562 }
2563 SvGETMAGIC(sv);
2564 if (SvROK(sv)) {
2565 if (SvAMAGIC(sv)) {
2566 sv = amagic_deref_call(sv, to_cv_amg);
2567 /* Don't SPAGAIN here. */
2568 }
2569 }
2570 else {
2571 const char *sym;
2572 STRLEN len;
2573 if (!SvOK(sv))
2574 DIE(aTHX_ PL_no_usym, "a subroutine");
2575 sym = SvPV_nomg_const(sv, len);
2576 if (PL_op->op_private & HINT_STRICT_REFS)
2577 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2578 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2579 break;
2580 }
2581 cv = MUTABLE_CV(SvRV(sv));
2582 if (SvTYPE(cv) == SVt_PVCV)
2583 break;
2584 /* FALL THROUGH */
2585 case SVt_PVHV:
2586 case SVt_PVAV:
2587 DIE(aTHX_ "Not a CODE reference");
2588 /* This is the second most common case: */
2589 case SVt_PVCV:
2590 cv = MUTABLE_CV(sv);
2591 break;
2592 }
f5719c02 2593 }
a0d0e21e 2594
a57c6685 2595 ENTER;
a0d0e21e
LW
2596
2597 retry:
f5719c02 2598 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
541ed3a9 2599 DIE(aTHX_ "Closure prototype called");
f5719c02 2600 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
2f349aa0
NC
2601 GV* autogv;
2602 SV* sub_name;
2603
2604 /* anonymous or undef'd function leaves us no recourse */
7d2057d8
FC
2605 if (CvANON(cv) || !(gv = CvGV(cv))) {
2606 if (CvNAMED(cv))
2607 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2608 HEKfARG(CvNAME_HEK(cv)));
2f349aa0 2609 DIE(aTHX_ "Undefined subroutine called");
7d2057d8 2610 }
2f349aa0
NC
2611
2612 /* autoloaded stub? */
2613 if (cv != GvCV(gv)) {
2614 cv = GvCV(gv);
2615 }
2616 /* should call AUTOLOAD now? */
2617 else {
7e623da3 2618try_autoload:
d1089224
BF
2619 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2620 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2f349aa0
NC
2621 {
2622 cv = GvCV(autogv);
2623 }
2f349aa0 2624 else {
c220e1a1 2625 sorry:
2f349aa0 2626 sub_name = sv_newmortal();
6136c704 2627 gv_efullname3(sub_name, gv, NULL);
be2597df 2628 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2f349aa0
NC
2629 }
2630 }
2631 if (!cv)
c220e1a1 2632 goto sorry;
2f349aa0 2633 goto retry;
a0d0e21e
LW
2634 }
2635
f5719c02
DM
2636 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
2637 && !CvNODEBUG(cv)))
2638 {
005a8a35 2639 Perl_get_db_sub(aTHX_ &sv, cv);
a9ef256d
NC
2640 if (CvISXSUB(cv))
2641 PL_curcopdb = PL_curcop;
1ad62f64 2642 if (CvLVALUE(cv)) {
2643 /* check for lsub that handles lvalue subroutines */
07b605e5 2644 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
1ad62f64 2645 /* if lsub not found then fall back to DB::sub */
2646 if (!cv) cv = GvCV(PL_DBsub);
2647 } else {
2648 cv = GvCV(PL_DBsub);
2649 }
a9ef256d 2650
ccafdc96
RGS
2651 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2652 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2653 }
a0d0e21e 2654
f5719c02
DM
2655 gimme = GIMME_V;
2656
aed2304a 2657 if (!(CvISXSUB(cv))) {
f1025168 2658 /* This path taken at least 75% of the time */
a0d0e21e 2659 dMARK;
b70d5558 2660 PADLIST * const padlist = CvPADLIST(cv);
3689ad62 2661 I32 depth;
f5719c02 2662
a0d0e21e
LW
2663 PUSHBLOCK(cx, CXt_SUB, MARK);
2664 PUSHSUB(cx);
f39bc417 2665 cx->blk_sub.retop = PL_op->op_next;
3689ad62 2666 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3a76ca88 2667 PERL_STACK_OVERFLOW_CHECK();
3689ad62 2668 pad_push(padlist, depth);
a0d0e21e 2669 }
3a76ca88 2670 SAVECOMPPAD();
3689ad62 2671 PAD_SET_CUR_NOSAVE(padlist, depth);
f5719c02 2672 if (LIKELY(hasargs)) {
10533ace 2673 AV *const av = MUTABLE_AV(PAD_SVl(0));
bdf02c57
DM
2674 SSize_t items;
2675 AV **defavp;
2676
f5719c02 2677 if (UNLIKELY(AvREAL(av))) {
221373f0
GS
2678 /* @_ is normally not REAL--this should only ever
2679 * happen when DB::sub() calls things that modify @_ */
2680 av_clear(av);
2681 AvREAL_off(av);
2682 AvREIFY_on(av);
2683 }
bdf02c57
DM
2684 defavp = &GvAV(PL_defgv);
2685 cx->blk_sub.savearray = *defavp;
2686 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
dd2155a4 2687 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2688 cx->blk_sub.argarray = av;
bdf02c57 2689 items = SP - MARK;
a0d0e21e 2690
f5719c02 2691 if (UNLIKELY(items - 1 > AvMAX(av))) {
77d27ef6
SF
2692 SV **ary = AvALLOC(av);
2693 AvMAX(av) = items - 1;
2694 Renew(ary, items, SV*);
2695 AvALLOC(av) = ary;
2696 AvARRAY(av) = ary;
2697 }
2698
bdf02c57 2699 Copy(MARK+1,AvARRAY(av),items,SV*);
93965878 2700 AvFILLp(av) = items - 1;
1c846c1f 2701
b479c9f2 2702 MARK = AvARRAY(av);
a0d0e21e
LW
2703 while (items--) {
2704 if (*MARK)
b479c9f2 2705 {
60779a30
DM
2706 if (SvPADTMP(*MARK)) {
2707 assert(!IS_PADGV(*MARK));
b479c9f2 2708 *MARK = sv_mortalcopy(*MARK);
60779a30 2709 }
a0d0e21e 2710 SvTEMP_off(*MARK);
b479c9f2 2711 }
a0d0e21e
LW
2712 MARK++;
2713 }
2714 }
b479c9f2 2715 SAVETMPS;
f5719c02
DM
2716 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2717 !CvLVALUE(cv)))
da1dff94 2718 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
4a925ff6
GS
2719 /* warning must come *after* we fully set up the context
2720 * stuff so that __WARN__ handlers can safely dounwind()
2721 * if they want to
2722 */
3689ad62 2723 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
f5719c02
DM
2724 && ckWARN(WARN_RECURSION)
2725 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
4a925ff6 2726 sub_crush_depth(cv);
a0d0e21e
LW
2727 RETURNOP(CvSTART(cv));
2728 }
f1025168 2729 else {
de935cc9 2730 SSize_t markix = TOPMARK;
f1025168 2731
b479c9f2 2732 SAVETMPS;
3a76ca88 2733 PUTBACK;
f1025168 2734
f5719c02 2735 if (UNLIKELY(((PL_op->op_private
4587c532
FC
2736 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2737 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
f5719c02 2738 !CvLVALUE(cv)))
4587c532
FC
2739 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2740
f5719c02 2741 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3a76ca88
RGS
2742 /* Need to copy @_ to stack. Alternative may be to
2743 * switch stack to @_, and copy return values
2744 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2745 AV * const av = GvAV(PL_defgv);
ad39f3a2 2746 const SSize_t items = AvFILL(av) + 1;
3a76ca88
RGS
2747
2748 if (items) {
dd2a7f90 2749 SSize_t i = 0;
ad39f3a2 2750 const bool m = cBOOL(SvRMAGICAL(av));
3a76ca88
RGS
2751 /* Mark is at the end of the stack. */
2752 EXTEND(SP, items);
dd2a7f90 2753 for (; i < items; ++i)
ad39f3a2
FC
2754 {
2755 SV *sv;
2756 if (m) {
2757 SV ** const svp = av_fetch(av, i, 0);
2758 sv = svp ? *svp : NULL;
2759 }
2760 else sv = AvARRAY(av)[i];
2761 if (sv) SP[i+1] = sv;
dd2a7f90 2762 else {
199f858d 2763 SP[i+1] = newSVavdefelem(av, i, 1);
dd2a7f90 2764 }
ad39f3a2 2765 }
3a76ca88
RGS
2766 SP += items;
2767 PUTBACK ;
2768 }
2769 }
3455055f
FC
2770 else {
2771 SV **mark = PL_stack_base + markix;
de935cc9 2772 SSize_t items = SP - mark;
3455055f
FC
2773 while (items--) {
2774 mark++;
60779a30
DM
2775 if (*mark && SvPADTMP(*mark)) {
2776 assert(!IS_PADGV(*mark));
3455055f 2777 *mark = sv_mortalcopy(*mark);
60779a30 2778 }
3455055f
FC
2779 }
2780 }
3a76ca88 2781 /* We assume first XSUB in &DB::sub is the called one. */
f5719c02 2782 if (UNLIKELY(PL_curcopdb)) {
3a76ca88
RGS
2783 SAVEVPTR(PL_curcop);
2784 PL_curcop = PL_curcopdb;
2785 PL_curcopdb = NULL;
2786 }
2787 /* Do we need to open block here? XXXX */
72df79cf 2788
2789 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2790 assert(CvXSUB(cv));
16c91539 2791 CvXSUB(cv)(aTHX_ cv);
3a76ca88
RGS
2792
2793 /* Enforce some sanity in scalar context. */
89a18b40
DM
2794 if (gimme == G_SCALAR) {
2795 SV **svp = PL_stack_base + markix + 1;
2796 if (svp != PL_stack_sp) {
2797 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
2798 PL_stack_sp = svp;
2799 }
3a76ca88 2800 }
a57c6685 2801 LEAVE;
f1025168
NC
2802 return NORMAL;
2803 }
a0d0e21e
LW
2804}
2805
44a8e56a 2806void
864dbfa3 2807Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 2808{
7918f24d
NC
2809 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2810
44a8e56a 2811 if (CvANON(cv))
9014280d 2812 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 2813 else {
07b2687d
LM
2814 HEK *const hek = CvNAME_HEK(cv);
2815 SV *tmpstr;
2816 if (hek) {
2817 tmpstr = sv_2mortal(newSVhek(hek));
2818 }
2819 else {
2820 tmpstr = sv_newmortal();
2821 gv_efullname3(tmpstr, CvGV(cv), NULL);
2822 }
35c1215d 2823 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
be2597df 2824 SVfARG(tmpstr));
44a8e56a
PP
2825 }
2826}
2827
a0d0e21e
LW
2828PP(pp_aelem)
2829{
97aff369 2830 dVAR; dSP;
a0d0e21e 2831 SV** svp;
a3b680e6 2832 SV* const elemsv = POPs;
d804643f 2833 IV elem = SvIV(elemsv);
502c6561 2834 AV *const av = MUTABLE_AV(POPs);
e1ec3a88 2835 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
bbfdc870 2836 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4ad10a0b
VP
2837 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2838 bool preeminent = TRUE;
be6c24e0 2839 SV *sv;
a0d0e21e 2840
5d9574c1 2841 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
95b63a38
JH
2842 Perl_warner(aTHX_ packWARN(WARN_MISC),
2843 "Use of reference \"%"SVf"\" as array index",
be2597df 2844 SVfARG(elemsv));
5d9574c1 2845 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
a0d0e21e 2846 RETPUSHUNDEF;
4ad10a0b 2847
5d9574c1 2848 if (UNLIKELY(localizing)) {
4ad10a0b
VP
2849 MAGIC *mg;
2850 HV *stash;
2851
2852 /* If we can determine whether the element exist,
2853 * Try to preserve the existenceness of a tied array
2854 * element by using EXISTS and DELETE if possible.
2855 * Fallback to FETCH and STORE otherwise. */
2856 if (SvCANEXISTDELETE(av))
2857 preeminent = av_exists(av, elem);
2858 }
2859
68dc0745 2860 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2861 if (lval) {
2b573ace 2862#ifdef PERL_MALLOC_WRAP
2b573ace 2863 if (SvUOK(elemsv)) {
a9c4fd4e 2864 const UV uv = SvUV(elemsv);
2b573ace
JH
2865 elem = uv > IV_MAX ? IV_MAX : uv;
2866 }
2867 else if (SvNOK(elemsv))
2868 elem = (IV)SvNV(elemsv);
a3b680e6
AL
2869 if (elem > 0) {
2870 static const char oom_array_extend[] =
2871 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 2872 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 2873 }
2b573ace 2874#endif
ce0d59fd 2875 if (!svp || !*svp) {
bbfdc870 2876 IV len;
68dc0745 2877 if (!defer)
cea2e8a9 2878 DIE(aTHX_ PL_no_aelem, elem);
b9f2b683 2879 len = av_tindex(av);
199f858d 2880 mPUSHs(newSVavdefelem(av,
bbfdc870
FC
2881 /* Resolve a negative index now, unless it points before the
2882 beginning of the array, in which case record it for error
2883 reporting in magic_setdefelem. */
199f858d
FC
2884 elem < 0 && len + elem >= 0 ? len + elem : elem,
2885 1));
68dc0745
PP
2886 RETURN;
2887 }
5d9574c1 2888 if (UNLIKELY(localizing)) {
4ad10a0b
VP
2889 if (preeminent)
2890 save_aelem(av, elem, svp);
2891 else
2892 SAVEADELETE(av, elem);
2893 }
9026059d
GG
2894 else if (PL_op->op_private & OPpDEREF) {
2895 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2896 RETURN;
2897 }
a0d0e21e 2898 }
3280af22 2899 sv = (svp ? *svp : &PL_sv_undef);
39cf747a 2900 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 2901 mg_get(sv);
be6c24e0 2902 PUSHs(sv);
a0d0e21e
LW
2903 RETURN;
2904}
2905
9026059d 2906SV*
864dbfa3 2907Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 2908{
7918f24d
NC
2909 PERL_ARGS_ASSERT_VIVIFY_REF;
2910
5b295bef 2911 SvGETMAGIC(sv);
02a9e968
CS
2912 if (!SvOK(sv)) {
2913 if (SvREADONLY(sv))
cb077ed2 2914 Perl_croak_no_modify();
43230e26 2915 prepare_SV_for_RV(sv);
68dc0745 2916 switch (to_what) {
5f05dabc 2917 case OPpDEREF_SV:
561b68a9 2918 SvRV_set(sv, newSV(0));
5f05dabc
PP
2919 break;
2920 case OPpDEREF_AV:
ad64d0ec 2921 SvRV_set(sv, MUTABLE_SV(newAV()));
5f05dabc
PP
2922 break;
2923 case OPpDEREF_HV:
ad64d0ec 2924 SvRV_set(sv, MUTABLE_SV(newHV()));
5f05dabc
PP
2925 break;
2926 }
02a9e968
CS
2927 SvROK_on(sv);
2928 SvSETMAGIC(sv);
7e482323 2929 SvGETMAGIC(sv);
02a9e968 2930 }
9026059d
GG
2931 if (SvGMAGICAL(sv)) {
2932 /* copy the sv without magic to prevent magic from being
2933 executed twice */
2934 SV* msv = sv_newmortal();
2935 sv_setsv_nomg(msv, sv);
2936 return msv;
2937 }
2938 return sv;
02a9e968
CS
2939}
2940
a0d0e21e
LW
2941PP(pp_method)
2942{
97aff369 2943 dVAR; dSP;
890ce7af 2944 SV* const sv = TOPs;
f5d5a27c
CS
2945
2946 if (SvROK(sv)) {
890ce7af 2947 SV* const rsv = SvRV(sv);
f5d5a27c
CS
2948 if (SvTYPE(rsv) == SVt_PVCV) {
2949 SETs(rsv);
2950 RETURN;
2951 }
2952 }
2953
4608196e 2954 SETs(method_common(sv, NULL));
f5d5a27c
CS
2955 RETURN;
2956}
2957
2958PP(pp_method_named)
2959{
97aff369 2960 dVAR; dSP;
890ce7af 2961 SV* const sv = cSVOP_sv;
c158a4fd 2962 U32 hash = SvSHARED_HASH(sv);
f5d5a27c
CS
2963
2964 XPUSHs(method_common(sv, &hash));
2965 RETURN;
2966}
2967
2968STATIC SV *
2969S_method_common(pTHX_ SV* meth, U32* hashp)
2970{
97aff369 2971 dVAR;
a0d0e21e
LW
2972 SV* ob;
2973 GV* gv;
56304f61 2974 HV* stash;
a0714e2c 2975 SV *packsv = NULL;
f226e9be
FC
2976 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2977 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2978 "package or object reference", SVfARG(meth)),
2979 (SV *)NULL)
2980 : *(PL_stack_base + TOPMARK + 1);
f5d5a27c 2981
7918f24d
NC
2982 PERL_ARGS_ASSERT_METHOD_COMMON;
2983
5d9574c1 2984 if (UNLIKELY(!sv))
7156e69a 2985 undefined:
a214957f
VP
2986 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2987 SVfARG(meth));
4f1b7578 2988
5b295bef 2989 SvGETMAGIC(sv);
a0d0e21e 2990 if (SvROK(sv))
ad64d0ec 2991 ob = MUTABLE_SV(SvRV(sv));
7156e69a 2992 else if (!SvOK(sv)) goto undefined;
a77c16f7
FC
2993 else if (isGV_with_GP(sv)) {
2994 if (!GvIO(sv))
2995 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
2996 "without a package or object reference",
2997 SVfARG(meth));
2998 ob = sv;
2999 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3000 assert(!LvTARGLEN(ob));
3001 ob = LvTARG(ob);
3002 assert(ob);
3003 }
3004 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3005 }
a0d0e21e 3006 else {
89269094 3007 /* this isn't a reference */
a0d0e21e 3008 GV* iogv;
f937af42 3009 STRLEN packlen;
89269094 3010 const char * const packname = SvPV_nomg_const(sv, packlen);
b3ebc221 3011 const bool packname_is_utf8 = !!SvUTF8(sv);
89269094 3012 const HE* const he =
b3ebc221
NC
3013 (const HE *)hv_common(
3014 PL_stashcache, NULL, packname, packlen,
3015 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
da6b625f
FC
3016 );
3017
89269094 3018 if (he) {
5e6396ae 3019 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
103f5a36
NC
3020 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
3021 stash, sv));
081fc587 3022 goto fetch;
081fc587
AB
3023 }
3024
89269094 3025 if (!(iogv = gv_fetchpvn_flags(
da6b625f
FC
3026 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
3027 )) ||
ad64d0ec 3028 !(ob=MUTABLE_SV(GvIO(iogv))))
a0d0e21e 3029 {
af09ea45 3030 /* this isn't the name of a filehandle either */
89269094 3031 if (!packlen)
834a4ddd 3032 {
7156e69a
FC
3033 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3034 "without a package or object reference",
3035 SVfARG(meth));
834a4ddd 3036 }
af09ea45 3037 /* assume it's a package name */
f937af42 3038 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
0dae17bd
GS
3039 if (!stash)
3040 packsv = sv;
081fc587 3041 else {
d4c19fe8 3042 SV* const ref = newSViv(PTR2IV(stash));
f937af42 3043 (void)hv_store(PL_stashcache, packname,
c60dbbc3 3044 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
103f5a36
NC
3045 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3046 stash, sv));
7e8961ec 3047 }
ac91690f 3048 goto fetch;
a0d0e21e 3049 }
af09ea45 3050 /* it _is_ a filehandle name -- replace with a reference */
ad64d0ec 3051 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
a0d0e21e
LW
3052 }
3053
1f3ffe4c 3054 /* if we got here, ob should be an object or a glob */
f0d43078 3055 if (!ob || !(SvOBJECT(ob)
a77c16f7 3056 || (isGV_with_GP(ob)
159b6efe 3057 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
f0d43078
GS
3058 && SvOBJECT(ob))))
3059 {
b375e37b
BF
3060 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3061 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3062 ? newSVpvs_flags("DOES", SVs_TEMP)
3063 : meth));
f0d43078 3064 }
a0d0e21e 3065
56304f61 3066 stash = SvSTASH(ob);
a0d0e21e 3067
ac91690f 3068 fetch:
af09ea45
IK
3069 /* NOTE: stash may be null, hope hv_fetch_ent and
3070 gv_fetchmethod can cope (it seems they can) */
3071
f5d5a27c
CS
3072 /* shortcut for simple names */
3073 if (hashp) {
b464bac0 3074 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
f5d5a27c 3075 if (he) {
159b6efe 3076 gv = MUTABLE_GV(HeVAL(he));
f5d5a27c 3077 if (isGV(gv) && GvCV(gv) &&
e1a479c5 3078 (!GvCVGEN(gv) || GvCVGEN(gv)
dd69841b 3079 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
ad64d0ec 3080 return MUTABLE_SV(GvCV(gv));
f5d5a27c
CS
3081 }
3082 }
3083
f937af42
BF
3084 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3085 meth, GV_AUTOLOAD | GV_CROAK);
9b9d0b15 3086
256d1bb2 3087 assert(gv);
9b9d0b15 3088
ad64d0ec 3089 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
a0d0e21e 3090}
241d1a3b
NC
3091
3092/*
3093 * Local variables:
3094 * c-indentation-style: bsd
3095 * c-basic-offset: 4
14d04a33 3096 * indent-tabs-mode: nil
241d1a3b
NC
3097 * End:
3098 *
14d04a33 3099 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3100 */