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