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