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