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