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