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