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