3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
14 * Awake! Awake! Fear, Fire, Foes! Awake!
19 #define PERL_IN_PP_HOT_C
33 PL_curcop = (COP*)PL_op;
34 TAINT_NOT; /* Each statement is presumed innocent */
35 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
44 if (PL_op->op_private & OPpLVAL_INTRO)
45 PUSHs(save_scalar(cGVOP_gv));
47 PUSHs(GvSV(cGVOP_gv));
58 PL_curcop = (COP*)PL_op;
64 PUSHMARK(PL_stack_sp);
79 XPUSHs((SV*)cGVOP_gv);
90 RETURNOP(cLOGOP->op_other);
98 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
100 temp = left; left = right; right = temp;
102 if (PL_tainting && PL_tainted && !SvTAINTED(left))
104 SvSetMagicSV(right, left);
113 RETURNOP(cLOGOP->op_other);
115 RETURNOP(cLOGOP->op_next);
121 TAINT_NOT; /* Each statement is presumed innocent */
122 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
124 oldsave = PL_scopestack[PL_scopestack_ix - 1];
125 LEAVE_SCOPE(oldsave);
131 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
138 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
139 bool rbyte = !SvUTF8(right), rcopied = FALSE;
141 if (TARG == right && right != left) {
142 right = sv_2mortal(newSVpvn(rpv, rlen));
143 rpv = SvPV(right, rlen); /* no point setting UTF8 here */
148 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
149 lbyte = !SvUTF8(left);
150 sv_setpvn(TARG, lpv, llen);
156 else { /* TARG == left */
157 if (SvGMAGICAL(left))
158 mg_get(left); /* or mg_get(left) may happen here */
161 lpv = SvPV_nomg(left, llen);
162 lbyte = !SvUTF8(left);
165 #if defined(PERL_Y2KWARN)
166 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
167 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
168 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
170 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
171 "about to append an integer to '19'");
176 if (lbyte != rbyte) {
178 sv_utf8_upgrade_nomg(TARG);
181 right = sv_2mortal(newSVpvn(rpv, rlen));
182 sv_utf8_upgrade_nomg(right);
183 rpv = SvPV(right, rlen);
186 sv_catpvn_nomg(TARG, rpv, rlen);
197 if (PL_op->op_flags & OPf_MOD) {
198 if (PL_op->op_private & OPpLVAL_INTRO)
199 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
200 else if (PL_op->op_private & OPpDEREF) {
202 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
211 tryAMAGICunTARGET(iter, 0);
212 PL_last_in_gv = (GV*)(*PL_stack_sp--);
213 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
214 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
215 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
218 XPUSHs((SV*)PL_last_in_gv);
221 PL_last_in_gv = (GV*)(*PL_stack_sp--);
224 return do_readline();
229 dSP; tryAMAGICbinSET(eq,0);
230 #ifndef NV_PRESERVES_UV
231 if (SvROK(TOPs) && SvROK(TOPm1s)) {
233 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
237 #ifdef PERL_PRESERVE_IVUV
240 /* Unless the left argument is integer in range we are going
241 to have to use NV maths. Hence only attempt to coerce the
242 right argument if we know the left is integer. */
245 bool auvok = SvUOK(TOPm1s);
246 bool buvok = SvUOK(TOPs);
248 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
249 /* Casting IV to UV before comparison isn't going to matter
250 on 2s complement. On 1s complement or sign&magnitude
251 (if we have any of them) it could to make negative zero
252 differ from normal zero. As I understand it. (Need to
253 check - is negative zero implementation defined behaviour
255 UV buv = SvUVX(POPs);
256 UV auv = SvUVX(TOPs);
258 SETs(boolSV(auv == buv));
261 { /* ## Mixed IV,UV ## */
265 /* == is commutative so doesn't matter which is left or right */
267 /* top of stack (b) is the iv */
276 /* As uv is a UV, it's >0, so it cannot be == */
280 /* we know iv is >= 0 */
281 SETs(boolSV((UV)iv == SvUVX(uvp)));
289 SETs(boolSV(TOPn == value));
297 if (SvTYPE(TOPs) > SVt_PVLV)
298 DIE(aTHX_ PL_no_modify);
299 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
300 && SvIVX(TOPs) != IV_MAX)
303 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
305 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
318 RETURNOP(cLOGOP->op_other);
324 /* Most of this is lifted straight from pp_defined */
329 if (!sv || !SvANY(sv)) {
331 RETURNOP(cLOGOP->op_other);
334 switch (SvTYPE(sv)) {
336 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
340 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
344 if (CvROOT(sv) || CvXSUB(sv))
355 RETURNOP(cLOGOP->op_other);
360 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
361 useleft = USE_LEFT(TOPm1s);
362 #ifdef PERL_PRESERVE_IVUV
363 /* We must see if we can perform the addition with integers if possible,
364 as the integer code detects overflow while the NV code doesn't.
365 If either argument hasn't had a numeric conversion yet attempt to get
366 the IV. It's important to do this now, rather than just assuming that
367 it's not IOK as a PV of "9223372036854775806" may not take well to NV
368 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
369 integer in case the second argument is IV=9223372036854775806
370 We can (now) rely on sv_2iv to do the right thing, only setting the
371 public IOK flag if the value in the NV (or PV) slot is truly integer.
373 A side effect is that this also aggressively prefers integer maths over
374 fp maths for integer values.
376 How to detect overflow?
378 C 99 section 6.2.6.1 says
380 The range of nonnegative values of a signed integer type is a subrange
381 of the corresponding unsigned integer type, and the representation of
382 the same value in each type is the same. A computation involving
383 unsigned operands can never overflow, because a result that cannot be
384 represented by the resulting unsigned integer type is reduced modulo
385 the number that is one greater than the largest value that can be
386 represented by the resulting type.
390 which I read as "unsigned ints wrap."
392 signed integer overflow seems to be classed as "exception condition"
394 If an exceptional condition occurs during the evaluation of an
395 expression (that is, if the result is not mathematically defined or not
396 in the range of representable values for its type), the behavior is
399 (6.5, the 5th paragraph)
401 I had assumed that on 2s complement machines signed arithmetic would
402 wrap, hence coded pp_add and pp_subtract on the assumption that
403 everything perl builds on would be happy. After much wailing and
404 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
405 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
406 unsigned code below is actually shorter than the old code. :-)
411 /* Unless the left argument is integer in range we are going to have to
412 use NV maths. Hence only attempt to coerce the right argument if
413 we know the left is integer. */
421 /* left operand is undef, treat as zero. + 0 is identity,
422 Could SETi or SETu right now, but space optimise by not adding
423 lots of code to speed up what is probably a rarish case. */
425 /* Left operand is defined, so is it IV? */
428 if ((auvok = SvUOK(TOPm1s)))
431 register IV aiv = SvIVX(TOPm1s);
434 auvok = 1; /* Now acting as a sign flag. */
435 } else { /* 2s complement assumption for IV_MIN */
443 bool result_good = 0;
446 bool buvok = SvUOK(TOPs);
451 register IV biv = SvIVX(TOPs);
458 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
459 else "IV" now, independent of how it came in.
460 if a, b represents positive, A, B negative, a maps to -A etc
465 all UV maths. negate result if A negative.
466 add if signs same, subtract if signs differ. */
472 /* Must get smaller */
478 /* result really should be -(auv-buv). as its negation
479 of true value, need to swap our result flag */
496 if (result <= (UV)IV_MIN)
499 /* result valid, but out of range for IV. */
504 } /* Overflow, drop through to NVs. */
511 /* left operand is undef, treat as zero. + 0.0 is identity. */
515 SETn( value + TOPn );
523 AV *av = GvAV(cGVOP_gv);
524 U32 lval = PL_op->op_flags & OPf_MOD;
525 SV** svp = av_fetch(av, PL_op->op_private, lval);
526 SV *sv = (svp ? *svp : &PL_sv_undef);
528 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
529 sv = sv_mortalcopy(sv);
538 do_join(TARG, *MARK, MARK, SP);
549 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
550 * will be enough to hold an OP*.
552 SV* sv = sv_newmortal();
553 sv_upgrade(sv, SVt_PVLV);
555 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
563 /* Oversized hot code. */
567 dSP; dMARK; dORIGMARK;
573 if (PL_op->op_flags & OPf_STACKED)
578 if (gv && (io = GvIO(gv))
579 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
582 if (MARK == ORIGMARK) {
583 /* If using default handle then we need to make space to
584 * pass object as 1st arg, so move other args up ...
588 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
592 *MARK = SvTIED_obj((SV*)io, mg);
595 call_method("PRINT", G_SCALAR);
603 if (!(io = GvIO(gv))) {
604 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
605 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
607 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
608 report_evil_fh(gv, io, PL_op->op_type);
609 SETERRNO(EBADF,RMS_IFI);
612 else if (!(fp = IoOFP(io))) {
613 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
615 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
616 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
617 report_evil_fh(gv, io, PL_op->op_type);
619 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
624 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
626 if (!do_print(*MARK, fp))
630 if (!do_print(PL_ofs_sv, fp)) { /* $, */
639 if (!do_print(*MARK, fp))
647 if (PL_ors_sv && SvOK(PL_ors_sv))
648 if (!do_print(PL_ors_sv, fp)) /* $\ */
651 if (IoFLAGS(io) & IOf_FLUSH)
652 if (PerlIO_flush(fp) == EOF)
673 tryAMAGICunDEREF(to_av);
676 if (SvTYPE(av) != SVt_PVAV)
677 DIE(aTHX_ "Not an ARRAY reference");
678 if (PL_op->op_flags & OPf_REF) {
683 if (GIMME == G_SCALAR)
684 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
688 else if (PL_op->op_flags & OPf_MOD
689 && PL_op->op_private & OPpLVAL_INTRO)
690 Perl_croak(aTHX_ PL_no_localize_ref);
693 if (SvTYPE(sv) == SVt_PVAV) {
695 if (PL_op->op_flags & OPf_REF) {
700 if (GIMME == G_SCALAR)
701 Perl_croak(aTHX_ "Can't return array to lvalue"
710 if (SvTYPE(sv) != SVt_PVGV) {
714 if (SvGMAGICAL(sv)) {
720 if (PL_op->op_flags & OPf_REF ||
721 PL_op->op_private & HINT_STRICT_REFS)
722 DIE(aTHX_ PL_no_usym, "an ARRAY");
723 if (ckWARN(WARN_UNINITIALIZED))
725 if (GIMME == G_ARRAY) {
732 if ((PL_op->op_flags & OPf_SPECIAL) &&
733 !(PL_op->op_flags & OPf_MOD))
735 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
737 && (!is_gv_magical(sym,len,0)
738 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
744 if (PL_op->op_private & HINT_STRICT_REFS)
745 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
746 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
753 if (PL_op->op_private & OPpLVAL_INTRO)
755 if (PL_op->op_flags & OPf_REF) {
760 if (GIMME == G_SCALAR)
761 Perl_croak(aTHX_ "Can't return array to lvalue"
769 if (GIMME == G_ARRAY) {
770 I32 maxarg = AvFILL(av) + 1;
771 (void)POPs; /* XXXX May be optimized away? */
773 if (SvRMAGICAL(av)) {
775 for (i=0; i < (U32)maxarg; i++) {
776 SV **svp = av_fetch(av, i, FALSE);
777 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
781 Copy(AvARRAY(av), SP+1, maxarg, SV*);
785 else if (GIMME_V == G_SCALAR) {
787 I32 maxarg = AvFILL(av) + 1;
800 tryAMAGICunDEREF(to_hv);
803 if (SvTYPE(hv) != SVt_PVHV)
804 DIE(aTHX_ "Not a HASH reference");
805 if (PL_op->op_flags & OPf_REF) {
810 if (GIMME == G_SCALAR)
811 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
815 else if (PL_op->op_flags & OPf_MOD
816 && PL_op->op_private & OPpLVAL_INTRO)
817 Perl_croak(aTHX_ PL_no_localize_ref);
820 if (SvTYPE(sv) == SVt_PVHV) {
822 if (PL_op->op_flags & OPf_REF) {
827 if (GIMME == G_SCALAR)
828 Perl_croak(aTHX_ "Can't return hash to lvalue"
837 if (SvTYPE(sv) != SVt_PVGV) {
841 if (SvGMAGICAL(sv)) {
847 if (PL_op->op_flags & OPf_REF ||
848 PL_op->op_private & HINT_STRICT_REFS)
849 DIE(aTHX_ PL_no_usym, "a HASH");
850 if (ckWARN(WARN_UNINITIALIZED))
852 if (GIMME == G_ARRAY) {
859 if ((PL_op->op_flags & OPf_SPECIAL) &&
860 !(PL_op->op_flags & OPf_MOD))
862 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
864 && (!is_gv_magical(sym,len,0)
865 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
871 if (PL_op->op_private & HINT_STRICT_REFS)
872 DIE(aTHX_ PL_no_symref, sym, "a HASH");
873 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
880 if (PL_op->op_private & OPpLVAL_INTRO)
882 if (PL_op->op_flags & OPf_REF) {
887 if (GIMME == G_SCALAR)
888 Perl_croak(aTHX_ "Can't return hash to lvalue"
896 if (GIMME == G_ARRAY) { /* array wanted */
897 *PL_stack_sp = (SV*)hv;
903 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
904 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
914 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
920 if (ckWARN(WARN_MISC)) {
921 if (relem == firstrelem &&
923 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
924 SvTYPE(SvRV(*relem)) == SVt_PVHV))
926 Perl_warner(aTHX_ packWARN(WARN_MISC),
927 "Reference found where even-sized list expected");
930 Perl_warner(aTHX_ packWARN(WARN_MISC),
931 "Odd number of elements in hash assignment");
934 tmpstr = NEWSV(29,0);
935 didstore = hv_store_ent(hash,*relem,tmpstr,0);
936 if (SvMAGICAL(hash)) {
937 if (SvSMAGICAL(tmpstr))
949 SV **lastlelem = PL_stack_sp;
950 SV **lastrelem = PL_stack_base + POPMARK;
951 SV **firstrelem = PL_stack_base + POPMARK + 1;
952 SV **firstlelem = lastrelem + 1;
965 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
967 /* If there's a common identifier on both sides we have to take
968 * special care that assigning the identifier on the left doesn't
969 * clobber a value on the right that's used later in the list.
971 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
972 EXTEND_MORTAL(lastrelem - firstrelem + 1);
973 for (relem = firstrelem; relem <= lastrelem; relem++) {
976 TAINT_NOT; /* Each item is independent */
977 *relem = sv_mortalcopy(sv);
987 while (lelem <= lastlelem) {
988 TAINT_NOT; /* Each item stands on its own, taintwise. */
990 switch (SvTYPE(sv)) {
993 magic = SvMAGICAL(ary) != 0;
995 av_extend(ary, lastrelem - relem);
997 while (relem <= lastrelem) { /* gobble up all the rest */
1001 sv_setsv(sv,*relem);
1003 didstore = av_store(ary,i++,sv);
1013 case SVt_PVHV: { /* normal hash */
1017 magic = SvMAGICAL(hash) != 0;
1020 while (relem < lastrelem) { /* gobble up all the rest */
1025 sv = &PL_sv_no, relem++;
1026 tmpstr = NEWSV(29,0);
1028 sv_setsv(tmpstr,*relem); /* value */
1029 *(relem++) = tmpstr;
1030 didstore = hv_store_ent(hash,sv,tmpstr,0);
1032 if (SvSMAGICAL(tmpstr))
1039 if (relem == lastrelem) {
1040 do_oddball(hash, relem, firstrelem);
1046 if (SvIMMORTAL(sv)) {
1047 if (relem <= lastrelem)
1051 if (relem <= lastrelem) {
1052 sv_setsv(sv, *relem);
1056 sv_setsv(sv, &PL_sv_undef);
1061 if (PL_delaymagic & ~DM_DELAY) {
1062 if (PL_delaymagic & DM_UID) {
1063 #ifdef HAS_SETRESUID
1064 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1066 # ifdef HAS_SETREUID
1067 (void)setreuid(PL_uid,PL_euid);
1070 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1071 (void)setruid(PL_uid);
1072 PL_delaymagic &= ~DM_RUID;
1074 # endif /* HAS_SETRUID */
1076 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1077 (void)seteuid(PL_uid);
1078 PL_delaymagic &= ~DM_EUID;
1080 # endif /* HAS_SETEUID */
1081 if (PL_delaymagic & DM_UID) {
1082 if (PL_uid != PL_euid)
1083 DIE(aTHX_ "No setreuid available");
1084 (void)PerlProc_setuid(PL_uid);
1086 # endif /* HAS_SETREUID */
1087 #endif /* HAS_SETRESUID */
1088 PL_uid = PerlProc_getuid();
1089 PL_euid = PerlProc_geteuid();
1091 if (PL_delaymagic & DM_GID) {
1092 #ifdef HAS_SETRESGID
1093 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1095 # ifdef HAS_SETREGID
1096 (void)setregid(PL_gid,PL_egid);
1099 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1100 (void)setrgid(PL_gid);
1101 PL_delaymagic &= ~DM_RGID;
1103 # endif /* HAS_SETRGID */
1105 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1106 (void)setegid(PL_gid);
1107 PL_delaymagic &= ~DM_EGID;
1109 # endif /* HAS_SETEGID */
1110 if (PL_delaymagic & DM_GID) {
1111 if (PL_gid != PL_egid)
1112 DIE(aTHX_ "No setregid available");
1113 (void)PerlProc_setgid(PL_gid);
1115 # endif /* HAS_SETREGID */
1116 #endif /* HAS_SETRESGID */
1117 PL_gid = PerlProc_getgid();
1118 PL_egid = PerlProc_getegid();
1120 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1125 if (gimme == G_VOID)
1126 SP = firstrelem - 1;
1127 else if (gimme == G_SCALAR) {
1130 SETi(lastrelem - firstrelem + 1);
1136 SP = firstrelem + (lastlelem - firstlelem);
1137 lelem = firstlelem + (relem - firstrelem);
1139 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1147 register PMOP *pm = cPMOP;
1148 SV *rv = sv_newmortal();
1149 SV *sv = newSVrv(rv, "Regexp");
1150 if (pm->op_pmdynflags & PMdf_TAINTED)
1152 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1159 register PMOP *pm = cPMOP;
1165 I32 r_flags = REXEC_CHECKED;
1166 char *truebase; /* Start of string */
1167 register REGEXP *rx = PM_GETRE(pm);
1172 I32 oldsave = PL_savestack_ix;
1173 I32 update_minmatch = 1;
1174 I32 had_zerolen = 0;
1176 if (PL_op->op_flags & OPf_STACKED)
1183 PUTBACK; /* EVAL blocks need stack_sp. */
1184 s = SvPV(TARG, len);
1187 DIE(aTHX_ "panic: pp_match");
1188 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1189 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1192 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1194 /* PMdf_USED is set after a ?? matches once */
1195 if (pm->op_pmdynflags & PMdf_USED) {
1197 if (gimme == G_ARRAY)
1202 /* empty pattern special-cased to use last successful pattern if possible */
1203 if (!rx->prelen && PL_curpm) {
1208 if (rx->minlen > (I32)len)
1213 /* XXXX What part of this is needed with true \G-support? */
1214 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1216 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1217 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1218 if (mg && mg->mg_len >= 0) {
1219 if (!(rx->reganch & ROPT_GPOS_SEEN))
1220 rx->endp[0] = rx->startp[0] = mg->mg_len;
1221 else if (rx->reganch & ROPT_ANCH_GPOS) {
1222 r_flags |= REXEC_IGNOREPOS;
1223 rx->endp[0] = rx->startp[0] = mg->mg_len;
1225 minmatch = (mg->mg_flags & MGf_MINMATCH);
1226 update_minmatch = 0;
1230 if ((!global && rx->nparens)
1231 || SvTEMP(TARG) || PL_sawampersand)
1232 r_flags |= REXEC_COPY_STR;
1234 r_flags |= REXEC_SCREAM;
1236 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1237 SAVEINT(PL_multiline);
1238 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1242 if (global && rx->startp[0] != -1) {
1243 t = s = rx->endp[0] + truebase;
1244 if ((s + rx->minlen) > strend)
1246 if (update_minmatch++)
1247 minmatch = had_zerolen;
1249 if (rx->reganch & RE_USE_INTUIT &&
1250 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1251 PL_bostr = truebase;
1252 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1256 if ( (rx->reganch & ROPT_CHECK_ALL)
1258 && ((rx->reganch & ROPT_NOSCAN)
1259 || !((rx->reganch & RE_INTUIT_TAIL)
1260 && (r_flags & REXEC_SCREAM)))
1261 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1264 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1267 if (dynpm->op_pmflags & PMf_ONCE)
1268 dynpm->op_pmdynflags |= PMdf_USED;
1277 RX_MATCH_TAINTED_on(rx);
1278 TAINT_IF(RX_MATCH_TAINTED(rx));
1279 if (gimme == G_ARRAY) {
1280 I32 nparens, i, len;
1282 nparens = rx->nparens;
1283 if (global && !nparens)
1287 SPAGAIN; /* EVAL blocks could move the stack. */
1288 EXTEND(SP, nparens + i);
1289 EXTEND_MORTAL(nparens + i);
1290 for (i = !i; i <= nparens; i++) {
1291 PUSHs(sv_newmortal());
1293 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1294 len = rx->endp[i] - rx->startp[i];
1295 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1296 len < 0 || len > strend - s)
1297 DIE(aTHX_ "panic: pp_match start/end pointers");
1298 s = rx->startp[i] + truebase;
1299 sv_setpvn(*SP, s, len);
1300 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1305 if (dynpm->op_pmflags & PMf_CONTINUE) {
1307 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1308 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1310 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1311 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1313 if (rx->startp[0] != -1) {
1314 mg->mg_len = rx->endp[0];
1315 if (rx->startp[0] == rx->endp[0])
1316 mg->mg_flags |= MGf_MINMATCH;
1318 mg->mg_flags &= ~MGf_MINMATCH;
1321 had_zerolen = (rx->startp[0] != -1
1322 && rx->startp[0] == rx->endp[0]);
1323 PUTBACK; /* EVAL blocks may use stack */
1324 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1329 LEAVE_SCOPE(oldsave);
1335 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1336 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1338 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1339 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1341 if (rx->startp[0] != -1) {
1342 mg->mg_len = rx->endp[0];
1343 if (rx->startp[0] == rx->endp[0])
1344 mg->mg_flags |= MGf_MINMATCH;
1346 mg->mg_flags &= ~MGf_MINMATCH;
1349 LEAVE_SCOPE(oldsave);
1353 yup: /* Confirmed by INTUIT */
1355 RX_MATCH_TAINTED_on(rx);
1356 TAINT_IF(RX_MATCH_TAINTED(rx));
1358 if (dynpm->op_pmflags & PMf_ONCE)
1359 dynpm->op_pmdynflags |= PMdf_USED;
1360 if (RX_MATCH_COPIED(rx))
1361 Safefree(rx->subbeg);
1362 RX_MATCH_COPIED_off(rx);
1363 rx->subbeg = Nullch;
1365 rx->subbeg = truebase;
1366 rx->startp[0] = s - truebase;
1367 if (RX_MATCH_UTF8(rx)) {
1368 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1369 rx->endp[0] = t - truebase;
1372 rx->endp[0] = s - truebase + rx->minlen;
1374 rx->sublen = strend - truebase;
1377 if (PL_sawampersand) {
1379 #ifdef PERL_COPY_ON_WRITE
1380 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1382 PerlIO_printf(Perl_debug_log,
1383 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1384 (int) SvTYPE(TARG), truebase, t,
1387 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1388 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1389 assert (SvPOKp(rx->saved_copy));
1394 rx->subbeg = savepvn(t, strend - t);
1395 #ifdef PERL_COPY_ON_WRITE
1396 rx->saved_copy = Nullsv;
1399 rx->sublen = strend - t;
1400 RX_MATCH_COPIED_on(rx);
1401 off = rx->startp[0] = s - t;
1402 rx->endp[0] = off + rx->minlen;
1404 else { /* startp/endp are used by @- @+. */
1405 rx->startp[0] = s - truebase;
1406 rx->endp[0] = s - truebase + rx->minlen;
1408 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1409 LEAVE_SCOPE(oldsave);
1414 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1415 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1416 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1421 LEAVE_SCOPE(oldsave);
1422 if (gimme == G_ARRAY)
1428 Perl_do_readline(pTHX)
1430 dSP; dTARGETSTACKED;
1435 register IO *io = GvIO(PL_last_in_gv);
1436 register I32 type = PL_op->op_type;
1437 I32 gimme = GIMME_V;
1440 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1442 XPUSHs(SvTIED_obj((SV*)io, mg));
1445 call_method("READLINE", gimme);
1448 if (gimme == G_SCALAR) {
1450 SvSetSV_nosteal(TARG, result);
1459 if (IoFLAGS(io) & IOf_ARGV) {
1460 if (IoFLAGS(io) & IOf_START) {
1462 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1463 IoFLAGS(io) &= ~IOf_START;
1464 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1465 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1466 SvSETMAGIC(GvSV(PL_last_in_gv));
1471 fp = nextargv(PL_last_in_gv);
1472 if (!fp) { /* Note: fp != IoIFP(io) */
1473 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1476 else if (type == OP_GLOB)
1477 fp = Perl_start_glob(aTHX_ POPs, io);
1479 else if (type == OP_GLOB)
1481 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1482 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1486 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1487 && (!io || !(IoFLAGS(io) & IOf_START))) {
1488 if (type == OP_GLOB)
1489 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1490 "glob failed (can't start child: %s)",
1493 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1495 if (gimme == G_SCALAR) {
1496 /* undef TARG, and push that undefined value */
1497 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1498 (void)SvOK_off(TARG);
1504 if (gimme == G_SCALAR) {
1508 (void)SvUPGRADE(sv, SVt_PV);
1509 tmplen = SvLEN(sv); /* remember if already alloced */
1511 Sv_Grow(sv, 80); /* try short-buffering it */
1513 if (type == OP_RCATLINE && SvOK(sv)) {
1516 (void)SvPV_force(sv, n_a);
1522 sv = sv_2mortal(NEWSV(57, 80));
1526 /* This should not be marked tainted if the fp is marked clean */
1527 #define MAYBE_TAINT_LINE(io, sv) \
1528 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1533 /* delay EOF state for a snarfed empty file */
1534 #define SNARF_EOF(gimme,rs,io,sv) \
1535 (gimme != G_SCALAR || SvCUR(sv) \
1536 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1540 if (!sv_gets(sv, fp, offset)
1541 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1543 PerlIO_clearerr(fp);
1544 if (IoFLAGS(io) & IOf_ARGV) {
1545 fp = nextargv(PL_last_in_gv);
1548 (void)do_close(PL_last_in_gv, FALSE);
1550 else if (type == OP_GLOB) {
1551 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1552 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1553 "glob failed (child exited with status %d%s)",
1554 (int)(STATUS_CURRENT >> 8),
1555 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1558 if (gimme == G_SCALAR) {
1559 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1560 (void)SvOK_off(TARG);
1564 MAYBE_TAINT_LINE(io, sv);
1567 MAYBE_TAINT_LINE(io, sv);
1569 IoFLAGS(io) |= IOf_NOLINE;
1573 if (type == OP_GLOB) {
1576 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1577 tmps = SvEND(sv) - 1;
1578 if (*tmps == *SvPVX(PL_rs)) {
1583 for (tmps = SvPVX(sv); *tmps; tmps++)
1584 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1585 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1587 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1588 (void)POPs; /* Unmatched wildcard? Chuck it... */
1592 if (gimme == G_ARRAY) {
1593 if (SvLEN(sv) - SvCUR(sv) > 20) {
1594 SvLEN_set(sv, SvCUR(sv)+1);
1595 Renew(SvPVX(sv), SvLEN(sv), char);
1597 sv = sv_2mortal(NEWSV(58, 80));
1600 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1601 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1605 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1606 Renew(SvPVX(sv), SvLEN(sv), char);
1615 register PERL_CONTEXT *cx;
1616 I32 gimme = OP_GIMME(PL_op, -1);
1619 if (cxstack_ix >= 0)
1620 gimme = cxstack[cxstack_ix].blk_gimme;
1628 PUSHBLOCK(cx, CXt_BLOCK, SP);
1640 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1641 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1643 #ifdef PERL_COPY_ON_WRITE
1644 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1646 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1650 if (SvTYPE(hv) == SVt_PVHV) {
1651 if (PL_op->op_private & OPpLVAL_INTRO) {
1654 /* does the element we're localizing already exist? */
1656 /* can we determine whether it exists? */
1658 || mg_find((SV*)hv, PERL_MAGIC_env)
1659 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1660 /* Try to preserve the existenceness of a tied hash
1661 * element by using EXISTS and DELETE if possible.
1662 * Fallback to FETCH and STORE otherwise */
1663 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1664 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1665 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1667 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1670 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1671 svp = he ? &HeVAL(he) : 0;
1677 if (!svp || *svp == &PL_sv_undef) {
1682 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1684 lv = sv_newmortal();
1685 sv_upgrade(lv, SVt_PVLV);
1687 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1688 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1689 LvTARG(lv) = SvREFCNT_inc(hv);
1694 if (PL_op->op_private & OPpLVAL_INTRO) {
1695 if (HvNAME(hv) && isGV(*svp))
1696 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1700 char *key = SvPV(keysv, keylen);
1701 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1703 save_helem(hv, keysv, svp);
1706 else if (PL_op->op_private & OPpDEREF)
1707 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1709 sv = (svp ? *svp : &PL_sv_undef);
1710 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1711 * Pushing the magical RHS on to the stack is useless, since
1712 * that magic is soon destined to be misled by the local(),
1713 * and thus the later pp_sassign() will fail to mg_get() the
1714 * old value. This should also cure problems with delayed
1715 * mg_get()s. GSAR 98-07-03 */
1716 if (!lval && SvGMAGICAL(sv))
1717 sv = sv_mortalcopy(sv);
1725 register PERL_CONTEXT *cx;
1731 if (PL_op->op_flags & OPf_SPECIAL) {
1732 cx = &cxstack[cxstack_ix];
1733 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1738 gimme = OP_GIMME(PL_op, -1);
1740 if (cxstack_ix >= 0)
1741 gimme = cxstack[cxstack_ix].blk_gimme;
1747 if (gimme == G_VOID)
1749 else if (gimme == G_SCALAR) {
1752 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1755 *MARK = sv_mortalcopy(TOPs);
1758 *MARK = &PL_sv_undef;
1762 else if (gimme == G_ARRAY) {
1763 /* in case LEAVE wipes old return values */
1764 for (mark = newsp + 1; mark <= SP; mark++) {
1765 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1766 *mark = sv_mortalcopy(*mark);
1767 TAINT_NOT; /* Each item is independent */
1771 PL_curpm = newpm; /* Don't pop $1 et al till now */
1781 register PERL_CONTEXT *cx;
1787 cx = &cxstack[cxstack_ix];
1788 if (CxTYPE(cx) != CXt_LOOP)
1789 DIE(aTHX_ "panic: pp_iter");
1791 itersvp = CxITERVAR(cx);
1792 av = cx->blk_loop.iterary;
1793 if (SvTYPE(av) != SVt_PVAV) {
1794 /* iterate ($min .. $max) */
1795 if (cx->blk_loop.iterlval) {
1796 /* string increment */
1797 register SV* cur = cx->blk_loop.iterlval;
1799 char *max = SvPV((SV*)av, maxlen);
1800 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1801 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1802 /* safe to reuse old SV */
1803 sv_setsv(*itersvp, cur);
1807 /* we need a fresh SV every time so that loop body sees a
1808 * completely new SV for closures/references to work as
1810 SvREFCNT_dec(*itersvp);
1811 *itersvp = newSVsv(cur);
1813 if (strEQ(SvPVX(cur), max))
1814 sv_setiv(cur, 0); /* terminate next time */
1821 /* integer increment */
1822 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1825 /* don't risk potential race */
1826 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1827 /* safe to reuse old SV */
1828 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1832 /* we need a fresh SV every time so that loop body sees a
1833 * completely new SV for closures/references to work as they
1835 SvREFCNT_dec(*itersvp);
1836 *itersvp = newSViv(cx->blk_loop.iterix++);
1842 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1845 SvREFCNT_dec(*itersvp);
1847 if (SvMAGICAL(av) || AvREIFY(av)) {
1848 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1855 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1861 if (av != PL_curstack && sv == &PL_sv_undef) {
1862 SV *lv = cx->blk_loop.iterlval;
1863 if (lv && SvREFCNT(lv) > 1) {
1868 SvREFCNT_dec(LvTARG(lv));
1870 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1871 sv_upgrade(lv, SVt_PVLV);
1873 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1875 LvTARG(lv) = SvREFCNT_inc(av);
1876 LvTARGOFF(lv) = cx->blk_loop.iterix;
1877 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1881 *itersvp = SvREFCNT_inc(sv);
1888 register PMOP *pm = cPMOP;
1904 register REGEXP *rx = PM_GETRE(pm);
1906 int force_on_match = 0;
1907 I32 oldsave = PL_savestack_ix;
1909 bool doutf8 = FALSE;
1910 #ifdef PERL_COPY_ON_WRITE
1915 /* known replacement string? */
1916 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1917 if (PL_op->op_flags & OPf_STACKED)
1924 #ifdef PERL_COPY_ON_WRITE
1925 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1926 because they make integers such as 256 "false". */
1927 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1930 sv_force_normal_flags(TARG,0);
1933 #ifdef PERL_COPY_ON_WRITE
1937 || (SvTYPE(TARG) > SVt_PVLV
1938 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1939 DIE(aTHX_ PL_no_modify);
1942 s = SvPV(TARG, len);
1943 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1945 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1946 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1951 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1955 DIE(aTHX_ "panic: pp_subst");
1958 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
1959 maxiters = 2 * slen + 10; /* We can match twice at each
1960 position, once with zero-length,
1961 second time with non-zero. */
1963 if (!rx->prelen && PL_curpm) {
1967 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1968 ? REXEC_COPY_STR : 0;
1970 r_flags |= REXEC_SCREAM;
1971 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1972 SAVEINT(PL_multiline);
1973 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1976 if (rx->reganch & RE_USE_INTUIT) {
1978 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1982 /* How to do it in subst? */
1983 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1985 && ((rx->reganch & ROPT_NOSCAN)
1986 || !((rx->reganch & RE_INTUIT_TAIL)
1987 && (r_flags & REXEC_SCREAM))))
1992 /* only replace once? */
1993 once = !(rpm->op_pmflags & PMf_GLOBAL);
1995 /* known replacement string? */
1997 /* replacement needing upgrading? */
1998 if (DO_UTF8(TARG) && !doutf8) {
1999 nsv = sv_newmortal();
2002 sv_recode_to_utf8(nsv, PL_encoding);
2004 sv_utf8_upgrade(nsv);
2005 c = SvPV(nsv, clen);
2009 c = SvPV(dstr, clen);
2010 doutf8 = DO_UTF8(dstr);
2018 /* can do inplace substitution? */
2020 #ifdef PERL_COPY_ON_WRITE
2023 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2024 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2025 && (!doutf8 || SvUTF8(TARG))) {
2026 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2027 r_flags | REXEC_CHECKED))
2031 LEAVE_SCOPE(oldsave);
2034 #ifdef PERL_COPY_ON_WRITE
2035 if (SvIsCOW(TARG)) {
2036 assert (!force_on_match);
2040 if (force_on_match) {
2042 s = SvPV_force(TARG, len);
2047 SvSCREAM_off(TARG); /* disable possible screamer */
2049 rxtainted |= RX_MATCH_TAINTED(rx);
2050 m = orig + rx->startp[0];
2051 d = orig + rx->endp[0];
2053 if (m - s > strend - d) { /* faster to shorten from end */
2055 Copy(c, m, clen, char);
2060 Move(d, m, i, char);
2064 SvCUR_set(TARG, m - s);
2067 else if ((i = m - s)) { /* faster from front */
2075 Copy(c, m, clen, char);
2080 Copy(c, d, clen, char);
2085 TAINT_IF(rxtainted & 1);
2091 if (iters++ > maxiters)
2092 DIE(aTHX_ "Substitution loop");
2093 rxtainted |= RX_MATCH_TAINTED(rx);
2094 m = rx->startp[0] + orig;
2098 Move(s, d, i, char);
2102 Copy(c, d, clen, char);
2105 s = rx->endp[0] + orig;
2106 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2108 /* don't match same null twice */
2109 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2112 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2113 Move(s, d, i+1, char); /* include the NUL */
2115 TAINT_IF(rxtainted & 1);
2117 PUSHs(sv_2mortal(newSViv((I32)iters)));
2119 (void)SvPOK_only_UTF8(TARG);
2120 TAINT_IF(rxtainted);
2121 if (SvSMAGICAL(TARG)) {
2129 LEAVE_SCOPE(oldsave);
2133 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2134 r_flags | REXEC_CHECKED))
2136 if (force_on_match) {
2138 s = SvPV_force(TARG, len);
2141 #ifdef PERL_COPY_ON_WRITE
2144 rxtainted |= RX_MATCH_TAINTED(rx);
2145 dstr = NEWSV(25, len);
2146 sv_setpvn(dstr, m, s-m);
2151 register PERL_CONTEXT *cx;
2154 RETURNOP(cPMOP->op_pmreplroot);
2156 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2158 if (iters++ > maxiters)
2159 DIE(aTHX_ "Substitution loop");
2160 rxtainted |= RX_MATCH_TAINTED(rx);
2161 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2166 strend = s + (strend - m);
2168 m = rx->startp[0] + orig;
2169 if (doutf8 && !SvUTF8(dstr))
2170 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2172 sv_catpvn(dstr, s, m-s);
2173 s = rx->endp[0] + orig;
2175 sv_catpvn(dstr, c, clen);
2178 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2179 TARG, NULL, r_flags));
2180 if (doutf8 && !DO_UTF8(TARG))
2181 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2183 sv_catpvn(dstr, s, strend - s);
2185 #ifdef PERL_COPY_ON_WRITE
2186 /* The match may make the string COW. If so, brilliant, because that's
2187 just saved us one malloc, copy and free - the regexp has donated
2188 the old buffer, and we malloc an entirely new one, rather than the
2189 regexp malloc()ing a buffer and copying our original, only for
2190 us to throw it away here during the substitution. */
2191 if (SvIsCOW(TARG)) {
2192 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2196 (void)SvOOK_off(TARG);
2198 Safefree(SvPVX(TARG));
2200 SvPVX(TARG) = SvPVX(dstr);
2201 SvCUR_set(TARG, SvCUR(dstr));
2202 SvLEN_set(TARG, SvLEN(dstr));
2203 doutf8 |= DO_UTF8(dstr);
2207 TAINT_IF(rxtainted & 1);
2209 PUSHs(sv_2mortal(newSViv((I32)iters)));
2211 (void)SvPOK_only(TARG);
2214 TAINT_IF(rxtainted);
2217 LEAVE_SCOPE(oldsave);
2226 LEAVE_SCOPE(oldsave);
2235 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2236 ++*PL_markstack_ptr;
2237 LEAVE; /* exit inner scope */
2240 if (PL_stack_base + *PL_markstack_ptr > SP) {
2242 I32 gimme = GIMME_V;
2244 LEAVE; /* exit outer scope */
2245 (void)POPMARK; /* pop src */
2246 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2247 (void)POPMARK; /* pop dst */
2248 SP = PL_stack_base + POPMARK; /* pop original mark */
2249 if (gimme == G_SCALAR) {
2253 else if (gimme == G_ARRAY)
2260 ENTER; /* enter inner scope */
2263 src = PL_stack_base[*PL_markstack_ptr];
2267 RETURNOP(cLOGOP->op_other);
2278 register PERL_CONTEXT *cx;
2284 if (gimme == G_SCALAR) {
2287 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2289 *MARK = SvREFCNT_inc(TOPs);
2294 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2296 *MARK = sv_mortalcopy(sv);
2301 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2305 *MARK = &PL_sv_undef;
2309 else if (gimme == G_ARRAY) {
2310 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2311 if (!SvTEMP(*MARK)) {
2312 *MARK = sv_mortalcopy(*MARK);
2313 TAINT_NOT; /* Each item is independent */
2319 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2320 PL_curpm = newpm; /* ... and pop $1 et al */
2324 return pop_return();
2327 /* This duplicates the above code because the above code must not
2328 * get any slower by more conditions */
2336 register PERL_CONTEXT *cx;
2343 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2344 /* We are an argument to a function or grep().
2345 * This kind of lvalueness was legal before lvalue
2346 * subroutines too, so be backward compatible:
2347 * cannot report errors. */
2349 /* Scalar context *is* possible, on the LHS of -> only,
2350 * as in f()->meth(). But this is not an lvalue. */
2351 if (gimme == G_SCALAR)
2353 if (gimme == G_ARRAY) {
2354 if (!CvLVALUE(cx->blk_sub.cv))
2355 goto temporise_array;
2356 EXTEND_MORTAL(SP - newsp);
2357 for (mark = newsp + 1; mark <= SP; mark++) {
2360 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2361 *mark = sv_mortalcopy(*mark);
2363 /* Can be a localized value subject to deletion. */
2364 PL_tmps_stack[++PL_tmps_ix] = *mark;
2365 (void)SvREFCNT_inc(*mark);
2370 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2371 /* Here we go for robustness, not for speed, so we change all
2372 * the refcounts so the caller gets a live guy. Cannot set
2373 * TEMP, so sv_2mortal is out of question. */
2374 if (!CvLVALUE(cx->blk_sub.cv)) {
2379 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2381 if (gimme == G_SCALAR) {
2385 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2390 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2391 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2392 : "a readonly value" : "a temporary");
2394 else { /* Can be a localized value
2395 * subject to deletion. */
2396 PL_tmps_stack[++PL_tmps_ix] = *mark;
2397 (void)SvREFCNT_inc(*mark);
2400 else { /* Should not happen? */
2405 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2406 (MARK > SP ? "Empty array" : "Array"));
2410 else if (gimme == G_ARRAY) {
2411 EXTEND_MORTAL(SP - newsp);
2412 for (mark = newsp + 1; mark <= SP; mark++) {
2413 if (*mark != &PL_sv_undef
2414 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2415 /* Might be flattened array after $#array = */
2421 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2422 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2425 /* Can be a localized value subject to deletion. */
2426 PL_tmps_stack[++PL_tmps_ix] = *mark;
2427 (void)SvREFCNT_inc(*mark);
2433 if (gimme == G_SCALAR) {
2437 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2439 *MARK = SvREFCNT_inc(TOPs);
2444 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2446 *MARK = sv_mortalcopy(sv);
2451 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2455 *MARK = &PL_sv_undef;
2459 else if (gimme == G_ARRAY) {
2461 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2462 if (!SvTEMP(*MARK)) {
2463 *MARK = sv_mortalcopy(*MARK);
2464 TAINT_NOT; /* Each item is independent */
2471 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2472 PL_curpm = newpm; /* ... and pop $1 et al */
2476 return pop_return();
2481 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2483 SV *dbsv = GvSV(PL_DBsub);
2485 if (!PERLDB_SUB_NN) {
2489 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2490 || strEQ(GvNAME(gv), "END")
2491 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2492 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2493 && (gv = (GV*)*svp) ))) {
2494 /* Use GV from the stack as a fallback. */
2495 /* GV is potentially non-unique, or contain different CV. */
2496 SV *tmp = newRV((SV*)cv);
2497 sv_setsv(dbsv, tmp);
2501 gv_efullname3(dbsv, gv, Nullch);
2505 (void)SvUPGRADE(dbsv, SVt_PVIV);
2506 (void)SvIOK_on(dbsv);
2507 SAVEIV(SvIVX(dbsv));
2508 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2512 PL_curcopdb = PL_curcop;
2513 cv = GvCV(PL_DBsub);
2523 register PERL_CONTEXT *cx;
2525 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2528 DIE(aTHX_ "Not a CODE reference");
2529 switch (SvTYPE(sv)) {
2530 /* This is overwhelming the most common case: */
2532 if (!(cv = GvCVu((GV*)sv)))
2533 cv = sv_2cv(sv, &stash, &gv, FALSE);
2545 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2547 SP = PL_stack_base + POPMARK;
2550 if (SvGMAGICAL(sv)) {
2554 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2557 sym = SvPV(sv, n_a);
2559 DIE(aTHX_ PL_no_usym, "a subroutine");
2560 if (PL_op->op_private & HINT_STRICT_REFS)
2561 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2562 cv = get_cv(sym, TRUE);
2567 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2568 tryAMAGICunDEREF(to_cv);
2571 if (SvTYPE(cv) == SVt_PVCV)
2576 DIE(aTHX_ "Not a CODE reference");
2577 /* This is the second most common case: */
2587 if (!CvROOT(cv) && !CvXSUB(cv)) {
2592 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2593 if (CvASSERTION(cv) && PL_DBassertion)
2594 sv_setiv(PL_DBassertion, 1);
2596 cv = get_db_sub(&sv, cv);
2598 DIE(aTHX_ "No DBsub routine");
2601 if (!(CvXSUB(cv))) {
2602 /* This path taken at least 75% of the time */
2604 register I32 items = SP - MARK;
2605 AV* padlist = CvPADLIST(cv);
2606 push_return(PL_op->op_next);
2607 PUSHBLOCK(cx, CXt_SUB, MARK);
2610 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2611 * that eval'' ops within this sub know the correct lexical space.
2612 * Owing the speed considerations, we choose instead to search for
2613 * the cv using find_runcv() when calling doeval().
2615 if (CvDEPTH(cv) < 2)
2616 (void)SvREFCNT_inc(cv);
2618 PERL_STACK_OVERFLOW_CHECK();
2619 pad_push(padlist, CvDEPTH(cv), 1);
2621 PAD_SET_CUR(padlist, CvDEPTH(cv));
2628 DEBUG_S(PerlIO_printf(Perl_debug_log,
2629 "%p entersub preparing @_\n", thr));
2631 av = (AV*)PAD_SVl(0);
2633 /* @_ is normally not REAL--this should only ever
2634 * happen when DB::sub() calls things that modify @_ */
2639 cx->blk_sub.savearray = GvAV(PL_defgv);
2640 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2641 CX_CURPAD_SAVE(cx->blk_sub);
2642 cx->blk_sub.argarray = av;
2645 if (items > AvMAX(av) + 1) {
2647 if (AvARRAY(av) != ary) {
2648 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2649 SvPVX(av) = (char*)ary;
2651 if (items > AvMAX(av) + 1) {
2652 AvMAX(av) = items - 1;
2653 Renew(ary,items,SV*);
2655 SvPVX(av) = (char*)ary;
2658 Copy(MARK,AvARRAY(av),items,SV*);
2659 AvFILLp(av) = items - 1;
2667 /* warning must come *after* we fully set up the context
2668 * stuff so that __WARN__ handlers can safely dounwind()
2671 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2672 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2673 sub_crush_depth(cv);
2675 DEBUG_S(PerlIO_printf(Perl_debug_log,
2676 "%p entersub returning %p\n", thr, CvSTART(cv)));
2678 RETURNOP(CvSTART(cv));
2681 #ifdef PERL_XSUB_OLDSTYLE
2682 if (CvOLDSTYLE(cv)) {
2683 I32 (*fp3)(int,int,int);
2685 register I32 items = SP - MARK;
2686 /* We dont worry to copy from @_. */
2691 PL_stack_sp = mark + 1;
2692 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2693 items = (*fp3)(CvXSUBANY(cv).any_i32,
2694 MARK - PL_stack_base + 1,
2696 PL_stack_sp = PL_stack_base + items;
2699 #endif /* PERL_XSUB_OLDSTYLE */
2701 I32 markix = TOPMARK;
2706 /* Need to copy @_ to stack. Alternative may be to
2707 * switch stack to @_, and copy return values
2708 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2711 av = GvAV(PL_defgv);
2712 items = AvFILLp(av) + 1; /* @_ is not tieable */
2715 /* Mark is at the end of the stack. */
2717 Copy(AvARRAY(av), SP + 1, items, SV*);
2722 /* We assume first XSUB in &DB::sub is the called one. */
2724 SAVEVPTR(PL_curcop);
2725 PL_curcop = PL_curcopdb;
2728 /* Do we need to open block here? XXXX */
2729 (void)(*CvXSUB(cv))(aTHX_ cv);
2731 /* Enforce some sanity in scalar context. */
2732 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2733 if (markix > PL_stack_sp - PL_stack_base)
2734 *(PL_stack_base + markix) = &PL_sv_undef;
2736 *(PL_stack_base + markix) = *PL_stack_sp;
2737 PL_stack_sp = PL_stack_base + markix;
2744 assert (0); /* Cannot get here. */
2745 /* This is deliberately moved here as spaghetti code to keep it out of the
2752 /* anonymous or undef'd function leaves us no recourse */
2753 if (CvANON(cv) || !(gv = CvGV(cv)))
2754 DIE(aTHX_ "Undefined subroutine called");
2756 /* autoloaded stub? */
2757 if (cv != GvCV(gv)) {
2760 /* should call AUTOLOAD now? */
2763 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2770 sub_name = sv_newmortal();
2771 gv_efullname3(sub_name, gv, Nullch);
2772 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2776 DIE(aTHX_ "Not a CODE reference");
2782 Perl_sub_crush_depth(pTHX_ CV *cv)
2785 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2787 SV* tmpstr = sv_newmortal();
2788 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2789 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2799 IV elem = SvIV(elemsv);
2801 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2802 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2805 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2806 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2808 elem -= PL_curcop->cop_arybase;
2809 if (SvTYPE(av) != SVt_PVAV)
2811 svp = av_fetch(av, elem, lval && !defer);
2813 if (!svp || *svp == &PL_sv_undef) {
2816 DIE(aTHX_ PL_no_aelem, elem);
2817 lv = sv_newmortal();
2818 sv_upgrade(lv, SVt_PVLV);
2820 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2821 LvTARG(lv) = SvREFCNT_inc(av);
2822 LvTARGOFF(lv) = elem;
2827 if (PL_op->op_private & OPpLVAL_INTRO)
2828 save_aelem(av, elem, svp);
2829 else if (PL_op->op_private & OPpDEREF)
2830 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2832 sv = (svp ? *svp : &PL_sv_undef);
2833 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2834 sv = sv_mortalcopy(sv);
2840 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2846 Perl_croak(aTHX_ PL_no_modify);
2847 if (SvTYPE(sv) < SVt_RV)
2848 sv_upgrade(sv, SVt_RV);
2849 else if (SvTYPE(sv) >= SVt_PV) {
2850 (void)SvOOK_off(sv);
2851 Safefree(SvPVX(sv));
2852 SvLEN(sv) = SvCUR(sv) = 0;
2856 SvRV(sv) = NEWSV(355,0);
2859 SvRV(sv) = (SV*)newAV();
2862 SvRV(sv) = (SV*)newHV();
2877 if (SvTYPE(rsv) == SVt_PVCV) {
2883 SETs(method_common(sv, Null(U32*)));
2891 U32 hash = SvUVX(sv);
2893 XPUSHs(method_common(sv, &hash));
2898 S_method_common(pTHX_ SV* meth, U32* hashp)
2907 SV *packsv = Nullsv;
2910 name = SvPV(meth, namelen);
2911 sv = *(PL_stack_base + TOPMARK + 1);
2914 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2923 /* this isn't a reference */
2926 !(packname = SvPV(sv, packlen)) ||
2927 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2928 !(ob=(SV*)GvIO(iogv)))
2930 /* this isn't the name of a filehandle either */
2932 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2933 ? !isIDFIRST_utf8((U8*)packname)
2934 : !isIDFIRST(*packname)
2937 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2938 SvOK(sv) ? "without a package or object reference"
2939 : "on an undefined value");
2941 /* assume it's a package name */
2942 stash = gv_stashpvn(packname, packlen, FALSE);
2947 /* it _is_ a filehandle name -- replace with a reference */
2948 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2951 /* if we got here, ob should be a reference or a glob */
2952 if (!ob || !(SvOBJECT(ob)
2953 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2956 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2960 stash = SvSTASH(ob);
2963 /* NOTE: stash may be null, hope hv_fetch_ent and
2964 gv_fetchmethod can cope (it seems they can) */
2966 /* shortcut for simple names */
2968 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2970 gv = (GV*)HeVAL(he);
2971 if (isGV(gv) && GvCV(gv) &&
2972 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2973 return (SV*)GvCV(gv);
2977 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
2980 /* This code tries to figure out just what went wrong with
2981 gv_fetchmethod. It therefore needs to duplicate a lot of
2982 the internals of that function. We can't move it inside
2983 Perl_gv_fetchmethod_autoload(), however, since that would
2984 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
2991 for (p = name; *p; p++) {
2993 sep = p, leaf = p + 1;
2994 else if (*p == ':' && *(p + 1) == ':')
2995 sep = p, leaf = p + 2;
2997 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
2998 /* the method name is unqualified or starts with SUPER:: */
2999 packname = sep ? CopSTASHPV(PL_curcop) :
3000 stash ? HvNAME(stash) : packname;
3001 packlen = strlen(packname);
3004 /* the method name is qualified */
3006 packlen = sep - name;
3009 /* we're relying on gv_fetchmethod not autovivifying the stash */
3010 if (gv_stashpvn(packname, packlen, FALSE)) {
3012 "Can't locate object method \"%s\" via package \"%.*s\"",
3013 leaf, (int)packlen, packname);
3017 "Can't locate object method \"%s\" via package \"%.*s\""
3018 " (perhaps you forgot to load \"%.*s\"?)",
3019 leaf, (int)packlen, packname, (int)packlen, packname);
3022 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;