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