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