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