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