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);
141 if (TARG == right && right != left) {
142 right = sv_2mortal(newSVpvn(rpv, rlen));
143 rpv = SvPV(right, rlen); /* no point setting UTF8 here */
147 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
148 lbyte = !SvUTF8(left);
149 sv_setpvn(TARG, lpv, llen);
155 else { /* TARG == left */
156 if (SvGMAGICAL(left))
157 mg_get(left); /* or mg_get(left) may happen here */
160 lpv = SvPV_nomg(left, llen);
161 lbyte = !SvUTF8(left);
164 #if defined(PERL_Y2KWARN)
165 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
166 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
167 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
169 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
170 "about to append an integer to '19'");
175 if (lbyte != rbyte) {
177 sv_utf8_upgrade_nomg(TARG);
179 sv_utf8_upgrade_nomg(right);
180 rpv = SvPV(right, rlen);
183 sv_catpvn_nomg(TARG, rpv, rlen);
194 if (PL_op->op_flags & OPf_MOD) {
195 if (PL_op->op_private & OPpLVAL_INTRO)
196 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
197 else if (PL_op->op_private & OPpDEREF) {
199 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
208 tryAMAGICunTARGET(iter, 0);
209 PL_last_in_gv = (GV*)(*PL_stack_sp--);
210 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
211 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
212 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
215 XPUSHs((SV*)PL_last_in_gv);
218 PL_last_in_gv = (GV*)(*PL_stack_sp--);
221 return do_readline();
226 dSP; tryAMAGICbinSET(eq,0);
227 #ifndef NV_PRESERVES_UV
228 if (SvROK(TOPs) && SvROK(TOPm1s)) {
230 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
234 #ifdef PERL_PRESERVE_IVUV
237 /* Unless the left argument is integer in range we are going
238 to have to use NV maths. Hence only attempt to coerce the
239 right argument if we know the left is integer. */
242 bool auvok = SvUOK(TOPm1s);
243 bool buvok = SvUOK(TOPs);
245 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
246 /* Casting IV to UV before comparison isn't going to matter
247 on 2s complement. On 1s complement or sign&magnitude
248 (if we have any of them) it could to make negative zero
249 differ from normal zero. As I understand it. (Need to
250 check - is negative zero implementation defined behaviour
252 UV buv = SvUVX(POPs);
253 UV auv = SvUVX(TOPs);
255 SETs(boolSV(auv == buv));
258 { /* ## Mixed IV,UV ## */
262 /* == is commutative so doesn't matter which is left or right */
264 /* top of stack (b) is the iv */
273 /* As uv is a UV, it's >0, so it cannot be == */
277 /* we know iv is >= 0 */
278 SETs(boolSV((UV)iv == SvUVX(uvp)));
286 SETs(boolSV(TOPn == value));
294 if (SvTYPE(TOPs) > SVt_PVLV)
295 DIE(aTHX_ PL_no_modify);
296 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
297 && SvIVX(TOPs) != IV_MAX)
300 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
302 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
315 RETURNOP(cLOGOP->op_other);
321 /* Most of this is lifted straight from pp_defined */
326 if (!sv || !SvANY(sv)) {
328 RETURNOP(cLOGOP->op_other);
331 switch (SvTYPE(sv)) {
333 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
337 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
341 if (CvROOT(sv) || CvXSUB(sv))
352 RETURNOP(cLOGOP->op_other);
357 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
358 useleft = USE_LEFT(TOPm1s);
359 #ifdef PERL_PRESERVE_IVUV
360 /* We must see if we can perform the addition with integers if possible,
361 as the integer code detects overflow while the NV code doesn't.
362 If either argument hasn't had a numeric conversion yet attempt to get
363 the IV. It's important to do this now, rather than just assuming that
364 it's not IOK as a PV of "9223372036854775806" may not take well to NV
365 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
366 integer in case the second argument is IV=9223372036854775806
367 We can (now) rely on sv_2iv to do the right thing, only setting the
368 public IOK flag if the value in the NV (or PV) slot is truly integer.
370 A side effect is that this also aggressively prefers integer maths over
371 fp maths for integer values.
373 How to detect overflow?
375 C 99 section 6.2.6.1 says
377 The range of nonnegative values of a signed integer type is a subrange
378 of the corresponding unsigned integer type, and the representation of
379 the same value in each type is the same. A computation involving
380 unsigned operands can never overflow, because a result that cannot be
381 represented by the resulting unsigned integer type is reduced modulo
382 the number that is one greater than the largest value that can be
383 represented by the resulting type.
387 which I read as "unsigned ints wrap."
389 signed integer overflow seems to be classed as "exception condition"
391 If an exceptional condition occurs during the evaluation of an
392 expression (that is, if the result is not mathematically defined or not
393 in the range of representable values for its type), the behavior is
396 (6.5, the 5th paragraph)
398 I had assumed that on 2s complement machines signed arithmetic would
399 wrap, hence coded pp_add and pp_subtract on the assumption that
400 everything perl builds on would be happy. After much wailing and
401 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
402 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
403 unsigned code below is actually shorter than the old code. :-)
408 /* Unless the left argument is integer in range we are going to have to
409 use NV maths. Hence only attempt to coerce the right argument if
410 we know the left is integer. */
418 /* left operand is undef, treat as zero. + 0 is identity,
419 Could SETi or SETu right now, but space optimise by not adding
420 lots of code to speed up what is probably a rarish case. */
422 /* Left operand is defined, so is it IV? */
425 if ((auvok = SvUOK(TOPm1s)))
428 register IV aiv = SvIVX(TOPm1s);
431 auvok = 1; /* Now acting as a sign flag. */
432 } else { /* 2s complement assumption for IV_MIN */
440 bool result_good = 0;
443 bool buvok = SvUOK(TOPs);
448 register IV biv = SvIVX(TOPs);
455 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
456 else "IV" now, independent of how it came in.
457 if a, b represents positive, A, B negative, a maps to -A etc
462 all UV maths. negate result if A negative.
463 add if signs same, subtract if signs differ. */
469 /* Must get smaller */
475 /* result really should be -(auv-buv). as its negation
476 of true value, need to swap our result flag */
493 if (result <= (UV)IV_MIN)
496 /* result valid, but out of range for IV. */
501 } /* Overflow, drop through to NVs. */
508 /* left operand is undef, treat as zero. + 0.0 is identity. */
512 SETn( value + TOPn );
520 AV *av = GvAV(cGVOP_gv);
521 U32 lval = PL_op->op_flags & OPf_MOD;
522 SV** svp = av_fetch(av, PL_op->op_private, lval);
523 SV *sv = (svp ? *svp : &PL_sv_undef);
525 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
526 sv = sv_mortalcopy(sv);
535 do_join(TARG, *MARK, MARK, SP);
546 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
547 * will be enough to hold an OP*.
549 SV* sv = sv_newmortal();
550 sv_upgrade(sv, SVt_PVLV);
552 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
560 /* Oversized hot code. */
564 dSP; dMARK; dORIGMARK;
570 if (PL_op->op_flags & OPf_STACKED)
575 if (gv && (io = GvIO(gv))
576 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
579 if (MARK == ORIGMARK) {
580 /* If using default handle then we need to make space to
581 * pass object as 1st arg, so move other args up ...
585 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
589 *MARK = SvTIED_obj((SV*)io, mg);
592 call_method("PRINT", G_SCALAR);
600 if (!(io = GvIO(gv))) {
601 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
602 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
604 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
605 report_evil_fh(gv, io, PL_op->op_type);
606 SETERRNO(EBADF,RMS_IFI);
609 else if (!(fp = IoOFP(io))) {
610 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
612 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
613 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
614 report_evil_fh(gv, io, PL_op->op_type);
616 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
621 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
623 if (!do_print(*MARK, fp))
627 if (!do_print(PL_ofs_sv, fp)) { /* $, */
636 if (!do_print(*MARK, fp))
644 if (PL_ors_sv && SvOK(PL_ors_sv))
645 if (!do_print(PL_ors_sv, fp)) /* $\ */
648 if (IoFLAGS(io) & IOf_FLUSH)
649 if (PerlIO_flush(fp) == EOF)
670 tryAMAGICunDEREF(to_av);
673 if (SvTYPE(av) != SVt_PVAV)
674 DIE(aTHX_ "Not an ARRAY reference");
675 if (PL_op->op_flags & OPf_REF) {
680 if (GIMME == G_SCALAR)
681 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
687 if (SvTYPE(sv) == SVt_PVAV) {
689 if (PL_op->op_flags & OPf_REF) {
694 if (GIMME == G_SCALAR)
695 Perl_croak(aTHX_ "Can't return array to lvalue"
704 if (SvTYPE(sv) != SVt_PVGV) {
708 if (SvGMAGICAL(sv)) {
714 if (PL_op->op_flags & OPf_REF ||
715 PL_op->op_private & HINT_STRICT_REFS)
716 DIE(aTHX_ PL_no_usym, "an ARRAY");
717 if (ckWARN(WARN_UNINITIALIZED))
719 if (GIMME == G_ARRAY) {
726 if ((PL_op->op_flags & OPf_SPECIAL) &&
727 !(PL_op->op_flags & OPf_MOD))
729 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
731 && (!is_gv_magical(sym,len,0)
732 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
738 if (PL_op->op_private & HINT_STRICT_REFS)
739 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
740 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
747 if (PL_op->op_private & OPpLVAL_INTRO)
749 if (PL_op->op_flags & OPf_REF) {
754 if (GIMME == G_SCALAR)
755 Perl_croak(aTHX_ "Can't return array to lvalue"
763 if (GIMME == G_ARRAY) {
764 I32 maxarg = AvFILL(av) + 1;
765 (void)POPs; /* XXXX May be optimized away? */
767 if (SvRMAGICAL(av)) {
769 for (i=0; i < (U32)maxarg; i++) {
770 SV **svp = av_fetch(av, i, FALSE);
771 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
775 Copy(AvARRAY(av), SP+1, maxarg, SV*);
779 else if (GIMME_V == G_SCALAR) {
781 I32 maxarg = AvFILL(av) + 1;
794 tryAMAGICunDEREF(to_hv);
797 if (SvTYPE(hv) != SVt_PVHV)
798 DIE(aTHX_ "Not a HASH reference");
799 if (PL_op->op_flags & OPf_REF) {
804 if (GIMME == G_SCALAR)
805 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
811 if (SvTYPE(sv) == SVt_PVHV) {
813 if (PL_op->op_flags & OPf_REF) {
818 if (GIMME == G_SCALAR)
819 Perl_croak(aTHX_ "Can't return hash to lvalue"
828 if (SvTYPE(sv) != SVt_PVGV) {
832 if (SvGMAGICAL(sv)) {
838 if (PL_op->op_flags & OPf_REF ||
839 PL_op->op_private & HINT_STRICT_REFS)
840 DIE(aTHX_ PL_no_usym, "a HASH");
841 if (ckWARN(WARN_UNINITIALIZED))
843 if (GIMME == G_ARRAY) {
850 if ((PL_op->op_flags & OPf_SPECIAL) &&
851 !(PL_op->op_flags & OPf_MOD))
853 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
855 && (!is_gv_magical(sym,len,0)
856 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
862 if (PL_op->op_private & HINT_STRICT_REFS)
863 DIE(aTHX_ PL_no_symref, sym, "a HASH");
864 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
871 if (PL_op->op_private & OPpLVAL_INTRO)
873 if (PL_op->op_flags & OPf_REF) {
878 if (GIMME == G_SCALAR)
879 Perl_croak(aTHX_ "Can't return hash to lvalue"
887 if (GIMME == G_ARRAY) { /* array wanted */
888 *PL_stack_sp = (SV*)hv;
894 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
895 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
905 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
911 if (ckWARN(WARN_MISC)) {
912 if (relem == firstrelem &&
914 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
915 SvTYPE(SvRV(*relem)) == SVt_PVHV))
917 Perl_warner(aTHX_ packWARN(WARN_MISC),
918 "Reference found where even-sized list expected");
921 Perl_warner(aTHX_ packWARN(WARN_MISC),
922 "Odd number of elements in hash assignment");
925 tmpstr = NEWSV(29,0);
926 didstore = hv_store_ent(hash,*relem,tmpstr,0);
927 if (SvMAGICAL(hash)) {
928 if (SvSMAGICAL(tmpstr))
940 SV **lastlelem = PL_stack_sp;
941 SV **lastrelem = PL_stack_base + POPMARK;
942 SV **firstrelem = PL_stack_base + POPMARK + 1;
943 SV **firstlelem = lastrelem + 1;
956 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
958 /* If there's a common identifier on both sides we have to take
959 * special care that assigning the identifier on the left doesn't
960 * clobber a value on the right that's used later in the list.
962 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
963 EXTEND_MORTAL(lastrelem - firstrelem + 1);
964 for (relem = firstrelem; relem <= lastrelem; relem++) {
967 TAINT_NOT; /* Each item is independent */
968 *relem = sv_mortalcopy(sv);
978 while (lelem <= lastlelem) {
979 TAINT_NOT; /* Each item stands on its own, taintwise. */
981 switch (SvTYPE(sv)) {
984 magic = SvMAGICAL(ary) != 0;
986 av_extend(ary, lastrelem - relem);
988 while (relem <= lastrelem) { /* gobble up all the rest */
994 didstore = av_store(ary,i++,sv);
1004 case SVt_PVHV: { /* normal hash */
1008 magic = SvMAGICAL(hash) != 0;
1011 while (relem < lastrelem) { /* gobble up all the rest */
1016 sv = &PL_sv_no, relem++;
1017 tmpstr = NEWSV(29,0);
1019 sv_setsv(tmpstr,*relem); /* value */
1020 *(relem++) = tmpstr;
1021 didstore = hv_store_ent(hash,sv,tmpstr,0);
1023 if (SvSMAGICAL(tmpstr))
1030 if (relem == lastrelem) {
1031 do_oddball(hash, relem, firstrelem);
1037 if (SvIMMORTAL(sv)) {
1038 if (relem <= lastrelem)
1042 if (relem <= lastrelem) {
1043 sv_setsv(sv, *relem);
1047 sv_setsv(sv, &PL_sv_undef);
1052 if (PL_delaymagic & ~DM_DELAY) {
1053 if (PL_delaymagic & DM_UID) {
1054 #ifdef HAS_SETRESUID
1055 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1057 # ifdef HAS_SETREUID
1058 (void)setreuid(PL_uid,PL_euid);
1061 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1062 (void)setruid(PL_uid);
1063 PL_delaymagic &= ~DM_RUID;
1065 # endif /* HAS_SETRUID */
1067 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1068 (void)seteuid(PL_uid);
1069 PL_delaymagic &= ~DM_EUID;
1071 # endif /* HAS_SETEUID */
1072 if (PL_delaymagic & DM_UID) {
1073 if (PL_uid != PL_euid)
1074 DIE(aTHX_ "No setreuid available");
1075 (void)PerlProc_setuid(PL_uid);
1077 # endif /* HAS_SETREUID */
1078 #endif /* HAS_SETRESUID */
1079 PL_uid = PerlProc_getuid();
1080 PL_euid = PerlProc_geteuid();
1082 if (PL_delaymagic & DM_GID) {
1083 #ifdef HAS_SETRESGID
1084 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1086 # ifdef HAS_SETREGID
1087 (void)setregid(PL_gid,PL_egid);
1090 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1091 (void)setrgid(PL_gid);
1092 PL_delaymagic &= ~DM_RGID;
1094 # endif /* HAS_SETRGID */
1096 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1097 (void)setegid(PL_gid);
1098 PL_delaymagic &= ~DM_EGID;
1100 # endif /* HAS_SETEGID */
1101 if (PL_delaymagic & DM_GID) {
1102 if (PL_gid != PL_egid)
1103 DIE(aTHX_ "No setregid available");
1104 (void)PerlProc_setgid(PL_gid);
1106 # endif /* HAS_SETREGID */
1107 #endif /* HAS_SETRESGID */
1108 PL_gid = PerlProc_getgid();
1109 PL_egid = PerlProc_getegid();
1111 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1116 if (gimme == G_VOID)
1117 SP = firstrelem - 1;
1118 else if (gimme == G_SCALAR) {
1121 SETi(lastrelem - firstrelem + 1);
1127 SP = firstrelem + (lastlelem - firstlelem);
1128 lelem = firstlelem + (relem - firstrelem);
1130 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1138 register PMOP *pm = cPMOP;
1139 SV *rv = sv_newmortal();
1140 SV *sv = newSVrv(rv, "Regexp");
1141 if (pm->op_pmdynflags & PMdf_TAINTED)
1143 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1150 register PMOP *pm = cPMOP;
1156 I32 r_flags = REXEC_CHECKED;
1157 char *truebase; /* Start of string */
1158 register REGEXP *rx = PM_GETRE(pm);
1163 I32 oldsave = PL_savestack_ix;
1164 I32 update_minmatch = 1;
1165 I32 had_zerolen = 0;
1167 if (PL_op->op_flags & OPf_STACKED)
1174 PUTBACK; /* EVAL blocks need stack_sp. */
1175 s = SvPV(TARG, len);
1178 DIE(aTHX_ "panic: pp_match");
1179 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1180 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1183 PL_reg_match_utf8 = DO_UTF8(TARG);
1185 /* PMdf_USED is set after a ?? matches once */
1186 if (pm->op_pmdynflags & PMdf_USED) {
1188 if (gimme == G_ARRAY)
1193 /* empty pattern special-cased to use last successful pattern if possible */
1194 if (!rx->prelen && PL_curpm) {
1199 if (rx->minlen > (I32)len)
1204 /* XXXX What part of this is needed with true \G-support? */
1205 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1207 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1208 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1209 if (mg && mg->mg_len >= 0) {
1210 if (!(rx->reganch & ROPT_GPOS_SEEN))
1211 rx->endp[0] = rx->startp[0] = mg->mg_len;
1212 else if (rx->reganch & ROPT_ANCH_GPOS) {
1213 r_flags |= REXEC_IGNOREPOS;
1214 rx->endp[0] = rx->startp[0] = mg->mg_len;
1216 minmatch = (mg->mg_flags & MGf_MINMATCH);
1217 update_minmatch = 0;
1221 if ((!global && rx->nparens)
1222 || SvTEMP(TARG) || PL_sawampersand)
1223 r_flags |= REXEC_COPY_STR;
1225 r_flags |= REXEC_SCREAM;
1227 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1228 SAVEINT(PL_multiline);
1229 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1233 if (global && rx->startp[0] != -1) {
1234 t = s = rx->endp[0] + truebase;
1235 if ((s + rx->minlen) > strend)
1237 if (update_minmatch++)
1238 minmatch = had_zerolen;
1240 if (rx->reganch & RE_USE_INTUIT &&
1241 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1242 PL_bostr = truebase;
1243 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1247 if ( (rx->reganch & ROPT_CHECK_ALL)
1249 && ((rx->reganch & ROPT_NOSCAN)
1250 || !((rx->reganch & RE_INTUIT_TAIL)
1251 && (r_flags & REXEC_SCREAM)))
1252 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1255 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1258 if (dynpm->op_pmflags & PMf_ONCE)
1259 dynpm->op_pmdynflags |= PMdf_USED;
1268 RX_MATCH_TAINTED_on(rx);
1269 TAINT_IF(RX_MATCH_TAINTED(rx));
1270 if (gimme == G_ARRAY) {
1271 I32 nparens, i, len;
1273 nparens = rx->nparens;
1274 if (global && !nparens)
1278 SPAGAIN; /* EVAL blocks could move the stack. */
1279 EXTEND(SP, nparens + i);
1280 EXTEND_MORTAL(nparens + i);
1281 for (i = !i; i <= nparens; i++) {
1282 PUSHs(sv_newmortal());
1284 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1285 len = rx->endp[i] - rx->startp[i];
1286 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1287 len < 0 || len > strend - s)
1288 DIE(aTHX_ "panic: pp_match start/end pointers");
1289 s = rx->startp[i] + truebase;
1290 sv_setpvn(*SP, s, len);
1291 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1296 if (dynpm->op_pmflags & PMf_CONTINUE) {
1298 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1299 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1301 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1302 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1304 if (rx->startp[0] != -1) {
1305 mg->mg_len = rx->endp[0];
1306 if (rx->startp[0] == rx->endp[0])
1307 mg->mg_flags |= MGf_MINMATCH;
1309 mg->mg_flags &= ~MGf_MINMATCH;
1312 had_zerolen = (rx->startp[0] != -1
1313 && rx->startp[0] == rx->endp[0]);
1314 PUTBACK; /* EVAL blocks may use stack */
1315 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1320 LEAVE_SCOPE(oldsave);
1326 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1327 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1329 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1330 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1332 if (rx->startp[0] != -1) {
1333 mg->mg_len = rx->endp[0];
1334 if (rx->startp[0] == rx->endp[0])
1335 mg->mg_flags |= MGf_MINMATCH;
1337 mg->mg_flags &= ~MGf_MINMATCH;
1340 LEAVE_SCOPE(oldsave);
1344 yup: /* Confirmed by INTUIT */
1346 RX_MATCH_TAINTED_on(rx);
1347 TAINT_IF(RX_MATCH_TAINTED(rx));
1349 if (dynpm->op_pmflags & PMf_ONCE)
1350 dynpm->op_pmdynflags |= PMdf_USED;
1351 if (RX_MATCH_COPIED(rx))
1352 Safefree(rx->subbeg);
1353 RX_MATCH_COPIED_off(rx);
1354 rx->subbeg = Nullch;
1356 rx->subbeg = truebase;
1357 rx->startp[0] = s - truebase;
1358 if (PL_reg_match_utf8) {
1359 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1360 rx->endp[0] = t - truebase;
1363 rx->endp[0] = s - truebase + rx->minlen;
1365 rx->sublen = strend - truebase;
1368 if (PL_sawampersand) {
1371 rx->subbeg = savepvn(t, strend - t);
1372 rx->sublen = strend - t;
1373 RX_MATCH_COPIED_on(rx);
1374 off = rx->startp[0] = s - t;
1375 rx->endp[0] = off + rx->minlen;
1377 else { /* startp/endp are used by @- @+. */
1378 rx->startp[0] = s - truebase;
1379 rx->endp[0] = s - truebase + rx->minlen;
1381 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1382 LEAVE_SCOPE(oldsave);
1387 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1388 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1389 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1394 LEAVE_SCOPE(oldsave);
1395 if (gimme == G_ARRAY)
1401 Perl_do_readline(pTHX)
1403 dSP; dTARGETSTACKED;
1408 register IO *io = GvIO(PL_last_in_gv);
1409 register I32 type = PL_op->op_type;
1410 I32 gimme = GIMME_V;
1413 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1415 XPUSHs(SvTIED_obj((SV*)io, mg));
1418 call_method("READLINE", gimme);
1421 if (gimme == G_SCALAR) {
1423 SvSetSV_nosteal(TARG, result);
1432 if (IoFLAGS(io) & IOf_ARGV) {
1433 if (IoFLAGS(io) & IOf_START) {
1435 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1436 IoFLAGS(io) &= ~IOf_START;
1437 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1438 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1439 SvSETMAGIC(GvSV(PL_last_in_gv));
1444 fp = nextargv(PL_last_in_gv);
1445 if (!fp) { /* Note: fp != IoIFP(io) */
1446 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1449 else if (type == OP_GLOB)
1450 fp = Perl_start_glob(aTHX_ POPs, io);
1452 else if (type == OP_GLOB)
1454 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1455 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1459 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1460 && (!io || !(IoFLAGS(io) & IOf_START))) {
1461 if (type == OP_GLOB)
1462 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1463 "glob failed (can't start child: %s)",
1466 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1468 if (gimme == G_SCALAR) {
1469 (void)SvOK_off(TARG);
1475 if (gimme == G_SCALAR) {
1479 (void)SvUPGRADE(sv, SVt_PV);
1480 tmplen = SvLEN(sv); /* remember if already alloced */
1482 Sv_Grow(sv, 80); /* try short-buffering it */
1484 if (type == OP_RCATLINE && SvOK(sv)) {
1487 (void)SvPV_force(sv, n_a);
1493 sv = sv_2mortal(NEWSV(57, 80));
1497 /* This should not be marked tainted if the fp is marked clean */
1498 #define MAYBE_TAINT_LINE(io, sv) \
1499 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1504 /* delay EOF state for a snarfed empty file */
1505 #define SNARF_EOF(gimme,rs,io,sv) \
1506 (gimme != G_SCALAR || SvCUR(sv) \
1507 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1511 if (!sv_gets(sv, fp, offset)
1512 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1514 PerlIO_clearerr(fp);
1515 if (IoFLAGS(io) & IOf_ARGV) {
1516 fp = nextargv(PL_last_in_gv);
1519 (void)do_close(PL_last_in_gv, FALSE);
1521 else if (type == OP_GLOB) {
1522 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1523 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1524 "glob failed (child exited with status %d%s)",
1525 (int)(STATUS_CURRENT >> 8),
1526 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1529 if (gimme == G_SCALAR) {
1530 (void)SvOK_off(TARG);
1534 MAYBE_TAINT_LINE(io, sv);
1537 MAYBE_TAINT_LINE(io, sv);
1539 IoFLAGS(io) |= IOf_NOLINE;
1543 if (type == OP_GLOB) {
1546 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1547 tmps = SvEND(sv) - 1;
1548 if (*tmps == *SvPVX(PL_rs)) {
1553 for (tmps = SvPVX(sv); *tmps; tmps++)
1554 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1555 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1557 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1558 (void)POPs; /* Unmatched wildcard? Chuck it... */
1562 if (gimme == G_ARRAY) {
1563 if (SvLEN(sv) - SvCUR(sv) > 20) {
1564 SvLEN_set(sv, SvCUR(sv)+1);
1565 Renew(SvPVX(sv), SvLEN(sv), char);
1567 sv = sv_2mortal(NEWSV(58, 80));
1570 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1571 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1575 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1576 Renew(SvPVX(sv), SvLEN(sv), char);
1585 register PERL_CONTEXT *cx;
1586 I32 gimme = OP_GIMME(PL_op, -1);
1589 if (cxstack_ix >= 0)
1590 gimme = cxstack[cxstack_ix].blk_gimme;
1598 PUSHBLOCK(cx, CXt_BLOCK, SP);
1610 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1611 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1613 #ifdef PERL_COPY_ON_WRITE
1614 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1616 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1620 if (SvTYPE(hv) == SVt_PVHV) {
1621 if (PL_op->op_private & OPpLVAL_INTRO) {
1624 /* does the element we're localizing already exist? */
1626 /* can we determine whether it exists? */
1628 || mg_find((SV*)hv, PERL_MAGIC_env)
1629 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1630 /* Try to preserve the existenceness of a tied hash
1631 * element by using EXISTS and DELETE if possible.
1632 * Fallback to FETCH and STORE otherwise */
1633 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1634 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1635 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1637 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1640 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1641 svp = he ? &HeVAL(he) : 0;
1647 if (!svp || *svp == &PL_sv_undef) {
1652 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1654 lv = sv_newmortal();
1655 sv_upgrade(lv, SVt_PVLV);
1657 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1658 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1659 LvTARG(lv) = SvREFCNT_inc(hv);
1664 if (PL_op->op_private & OPpLVAL_INTRO) {
1665 if (HvNAME(hv) && isGV(*svp))
1666 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1670 char *key = SvPV(keysv, keylen);
1671 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1673 save_helem(hv, keysv, svp);
1676 else if (PL_op->op_private & OPpDEREF)
1677 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1679 sv = (svp ? *svp : &PL_sv_undef);
1680 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1681 * Pushing the magical RHS on to the stack is useless, since
1682 * that magic is soon destined to be misled by the local(),
1683 * and thus the later pp_sassign() will fail to mg_get() the
1684 * old value. This should also cure problems with delayed
1685 * mg_get()s. GSAR 98-07-03 */
1686 if (!lval && SvGMAGICAL(sv))
1687 sv = sv_mortalcopy(sv);
1695 register PERL_CONTEXT *cx;
1701 if (PL_op->op_flags & OPf_SPECIAL) {
1702 cx = &cxstack[cxstack_ix];
1703 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1708 gimme = OP_GIMME(PL_op, -1);
1710 if (cxstack_ix >= 0)
1711 gimme = cxstack[cxstack_ix].blk_gimme;
1717 if (gimme == G_VOID)
1719 else if (gimme == G_SCALAR) {
1722 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1725 *MARK = sv_mortalcopy(TOPs);
1728 *MARK = &PL_sv_undef;
1732 else if (gimme == G_ARRAY) {
1733 /* in case LEAVE wipes old return values */
1734 for (mark = newsp + 1; mark <= SP; mark++) {
1735 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1736 *mark = sv_mortalcopy(*mark);
1737 TAINT_NOT; /* Each item is independent */
1741 PL_curpm = newpm; /* Don't pop $1 et al till now */
1751 register PERL_CONTEXT *cx;
1757 cx = &cxstack[cxstack_ix];
1758 if (CxTYPE(cx) != CXt_LOOP)
1759 DIE(aTHX_ "panic: pp_iter");
1761 itersvp = CxITERVAR(cx);
1762 av = cx->blk_loop.iterary;
1763 if (SvTYPE(av) != SVt_PVAV) {
1764 /* iterate ($min .. $max) */
1765 if (cx->blk_loop.iterlval) {
1766 /* string increment */
1767 register SV* cur = cx->blk_loop.iterlval;
1769 char *max = SvPV((SV*)av, maxlen);
1770 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1771 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1772 /* safe to reuse old SV */
1773 sv_setsv(*itersvp, cur);
1777 /* we need a fresh SV every time so that loop body sees a
1778 * completely new SV for closures/references to work as
1780 SvREFCNT_dec(*itersvp);
1781 *itersvp = newSVsv(cur);
1783 if (strEQ(SvPVX(cur), max))
1784 sv_setiv(cur, 0); /* terminate next time */
1791 /* integer increment */
1792 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1795 /* don't risk potential race */
1796 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1797 /* safe to reuse old SV */
1798 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1802 /* we need a fresh SV every time so that loop body sees a
1803 * completely new SV for closures/references to work as they
1805 SvREFCNT_dec(*itersvp);
1806 *itersvp = newSViv(cx->blk_loop.iterix++);
1812 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1815 SvREFCNT_dec(*itersvp);
1817 if (SvMAGICAL(av) || AvREIFY(av)) {
1818 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1825 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1831 if (av != PL_curstack && sv == &PL_sv_undef) {
1832 SV *lv = cx->blk_loop.iterlval;
1833 if (lv && SvREFCNT(lv) > 1) {
1838 SvREFCNT_dec(LvTARG(lv));
1840 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1841 sv_upgrade(lv, SVt_PVLV);
1843 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1845 LvTARG(lv) = SvREFCNT_inc(av);
1846 LvTARGOFF(lv) = cx->blk_loop.iterix;
1847 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1851 *itersvp = SvREFCNT_inc(sv);
1858 register PMOP *pm = cPMOP;
1874 register REGEXP *rx = PM_GETRE(pm);
1876 int force_on_match = 0;
1877 I32 oldsave = PL_savestack_ix;
1879 bool doutf8 = FALSE;
1881 /* known replacement string? */
1882 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1883 if (PL_op->op_flags & OPf_STACKED)
1891 sv_force_normal_flags(TARG,0);
1892 if (SvREADONLY(TARG)
1893 || (SvTYPE(TARG) > SVt_PVLV
1894 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1895 DIE(aTHX_ PL_no_modify);
1898 s = SvPV(TARG, len);
1899 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1901 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1902 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1907 PL_reg_match_utf8 = DO_UTF8(TARG);
1911 DIE(aTHX_ "panic: pp_subst");
1914 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1915 maxiters = 2 * slen + 10; /* We can match twice at each
1916 position, once with zero-length,
1917 second time with non-zero. */
1919 if (!rx->prelen && PL_curpm) {
1923 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1924 ? REXEC_COPY_STR : 0;
1926 r_flags |= REXEC_SCREAM;
1927 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1928 SAVEINT(PL_multiline);
1929 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1932 if (rx->reganch & RE_USE_INTUIT) {
1934 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1938 /* How to do it in subst? */
1939 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1941 && ((rx->reganch & ROPT_NOSCAN)
1942 || !((rx->reganch & RE_INTUIT_TAIL)
1943 && (r_flags & REXEC_SCREAM))))
1948 /* only replace once? */
1949 once = !(rpm->op_pmflags & PMf_GLOBAL);
1951 /* known replacement string? */
1953 /* replacement needing upgrading? */
1954 if (DO_UTF8(TARG) && !doutf8) {
1955 SV *nsv = sv_newmortal();
1958 sv_recode_to_utf8(nsv, PL_encoding);
1960 sv_utf8_upgrade(nsv);
1961 c = SvPV(nsv, clen);
1965 c = SvPV(dstr, clen);
1966 doutf8 = DO_UTF8(dstr);
1974 /* can do inplace substitution? */
1975 if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1976 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1977 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1978 r_flags | REXEC_CHECKED))
1982 LEAVE_SCOPE(oldsave);
1985 if (force_on_match) {
1987 s = SvPV_force(TARG, len);
1992 SvSCREAM_off(TARG); /* disable possible screamer */
1994 rxtainted |= RX_MATCH_TAINTED(rx);
1995 m = orig + rx->startp[0];
1996 d = orig + rx->endp[0];
1998 if (m - s > strend - d) { /* faster to shorten from end */
2000 Copy(c, m, clen, char);
2005 Move(d, m, i, char);
2009 SvCUR_set(TARG, m - s);
2012 else if ((i = m - s)) { /* faster from front */
2020 Copy(c, m, clen, char);
2025 Copy(c, d, clen, char);
2030 TAINT_IF(rxtainted & 1);
2036 if (iters++ > maxiters)
2037 DIE(aTHX_ "Substitution loop");
2038 rxtainted |= RX_MATCH_TAINTED(rx);
2039 m = rx->startp[0] + orig;
2043 Move(s, d, i, char);
2047 Copy(c, d, clen, char);
2050 s = rx->endp[0] + orig;
2051 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2053 /* don't match same null twice */
2054 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2057 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2058 Move(s, d, i+1, char); /* include the NUL */
2060 TAINT_IF(rxtainted & 1);
2062 PUSHs(sv_2mortal(newSViv((I32)iters)));
2064 (void)SvPOK_only_UTF8(TARG);
2065 TAINT_IF(rxtainted);
2066 if (SvSMAGICAL(TARG)) {
2074 LEAVE_SCOPE(oldsave);
2078 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2079 r_flags | REXEC_CHECKED))
2081 if (force_on_match) {
2083 s = SvPV_force(TARG, len);
2086 rxtainted |= RX_MATCH_TAINTED(rx);
2087 dstr = NEWSV(25, len);
2088 sv_setpvn(dstr, m, s-m);
2093 register PERL_CONTEXT *cx;
2096 RETURNOP(cPMOP->op_pmreplroot);
2098 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2100 if (iters++ > maxiters)
2101 DIE(aTHX_ "Substitution loop");
2102 rxtainted |= RX_MATCH_TAINTED(rx);
2103 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2108 strend = s + (strend - m);
2110 m = rx->startp[0] + orig;
2111 sv_catpvn(dstr, s, m-s);
2112 s = rx->endp[0] + orig;
2114 sv_catpvn(dstr, c, clen);
2117 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2118 TARG, NULL, r_flags));
2119 if (doutf8 && !DO_UTF8(dstr)) {
2120 SV* nsv = sv_2mortal(newSVpvn(s, strend - s));
2122 sv_utf8_upgrade(nsv);
2123 sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv));
2126 sv_catpvn(dstr, s, strend - s);
2128 (void)SvOOK_off(TARG);
2129 Safefree(SvPVX(TARG));
2130 SvPVX(TARG) = SvPVX(dstr);
2131 SvCUR_set(TARG, SvCUR(dstr));
2132 SvLEN_set(TARG, SvLEN(dstr));
2133 doutf8 |= DO_UTF8(dstr);
2137 TAINT_IF(rxtainted & 1);
2139 PUSHs(sv_2mortal(newSViv((I32)iters)));
2141 (void)SvPOK_only(TARG);
2144 TAINT_IF(rxtainted);
2147 LEAVE_SCOPE(oldsave);
2156 LEAVE_SCOPE(oldsave);
2165 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2166 ++*PL_markstack_ptr;
2167 LEAVE; /* exit inner scope */
2170 if (PL_stack_base + *PL_markstack_ptr > SP) {
2172 I32 gimme = GIMME_V;
2174 LEAVE; /* exit outer scope */
2175 (void)POPMARK; /* pop src */
2176 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2177 (void)POPMARK; /* pop dst */
2178 SP = PL_stack_base + POPMARK; /* pop original mark */
2179 if (gimme == G_SCALAR) {
2183 else if (gimme == G_ARRAY)
2190 ENTER; /* enter inner scope */
2193 src = PL_stack_base[*PL_markstack_ptr];
2197 RETURNOP(cLOGOP->op_other);
2208 register PERL_CONTEXT *cx;
2214 if (gimme == G_SCALAR) {
2217 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2219 *MARK = SvREFCNT_inc(TOPs);
2224 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2226 *MARK = sv_mortalcopy(sv);
2231 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2235 *MARK = &PL_sv_undef;
2239 else if (gimme == G_ARRAY) {
2240 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2241 if (!SvTEMP(*MARK)) {
2242 *MARK = sv_mortalcopy(*MARK);
2243 TAINT_NOT; /* Each item is independent */
2249 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2250 PL_curpm = newpm; /* ... and pop $1 et al */
2254 return pop_return();
2257 /* This duplicates the above code because the above code must not
2258 * get any slower by more conditions */
2266 register PERL_CONTEXT *cx;
2273 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2274 /* We are an argument to a function or grep().
2275 * This kind of lvalueness was legal before lvalue
2276 * subroutines too, so be backward compatible:
2277 * cannot report errors. */
2279 /* Scalar context *is* possible, on the LHS of -> only,
2280 * as in f()->meth(). But this is not an lvalue. */
2281 if (gimme == G_SCALAR)
2283 if (gimme == G_ARRAY) {
2284 if (!CvLVALUE(cx->blk_sub.cv))
2285 goto temporise_array;
2286 EXTEND_MORTAL(SP - newsp);
2287 for (mark = newsp + 1; mark <= SP; mark++) {
2290 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2291 *mark = sv_mortalcopy(*mark);
2293 /* Can be a localized value subject to deletion. */
2294 PL_tmps_stack[++PL_tmps_ix] = *mark;
2295 (void)SvREFCNT_inc(*mark);
2300 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2301 /* Here we go for robustness, not for speed, so we change all
2302 * the refcounts so the caller gets a live guy. Cannot set
2303 * TEMP, so sv_2mortal is out of question. */
2304 if (!CvLVALUE(cx->blk_sub.cv)) {
2309 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2311 if (gimme == G_SCALAR) {
2315 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2320 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2321 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2322 : "a readonly value" : "a temporary");
2324 else { /* Can be a localized value
2325 * subject to deletion. */
2326 PL_tmps_stack[++PL_tmps_ix] = *mark;
2327 (void)SvREFCNT_inc(*mark);
2330 else { /* Should not happen? */
2335 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2336 (MARK > SP ? "Empty array" : "Array"));
2340 else if (gimme == G_ARRAY) {
2341 EXTEND_MORTAL(SP - newsp);
2342 for (mark = newsp + 1; mark <= SP; mark++) {
2343 if (*mark != &PL_sv_undef
2344 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2345 /* Might be flattened array after $#array = */
2351 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2352 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2355 /* Can be a localized value subject to deletion. */
2356 PL_tmps_stack[++PL_tmps_ix] = *mark;
2357 (void)SvREFCNT_inc(*mark);
2363 if (gimme == G_SCALAR) {
2367 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2369 *MARK = SvREFCNT_inc(TOPs);
2374 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2376 *MARK = sv_mortalcopy(sv);
2381 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2385 *MARK = &PL_sv_undef;
2389 else if (gimme == G_ARRAY) {
2391 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2392 if (!SvTEMP(*MARK)) {
2393 *MARK = sv_mortalcopy(*MARK);
2394 TAINT_NOT; /* Each item is independent */
2401 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2402 PL_curpm = newpm; /* ... and pop $1 et al */
2406 return pop_return();
2411 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2413 SV *dbsv = GvSV(PL_DBsub);
2415 if (!PERLDB_SUB_NN) {
2419 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2420 || strEQ(GvNAME(gv), "END")
2421 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2422 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2423 && (gv = (GV*)*svp) ))) {
2424 /* Use GV from the stack as a fallback. */
2425 /* GV is potentially non-unique, or contain different CV. */
2426 SV *tmp = newRV((SV*)cv);
2427 sv_setsv(dbsv, tmp);
2431 gv_efullname3(dbsv, gv, Nullch);
2435 (void)SvUPGRADE(dbsv, SVt_PVIV);
2436 (void)SvIOK_on(dbsv);
2437 SAVEIV(SvIVX(dbsv));
2438 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2442 PL_curcopdb = PL_curcop;
2443 cv = GvCV(PL_DBsub);
2453 register PERL_CONTEXT *cx;
2455 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2458 DIE(aTHX_ "Not a CODE reference");
2459 switch (SvTYPE(sv)) {
2465 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2467 SP = PL_stack_base + POPMARK;
2470 if (SvGMAGICAL(sv)) {
2474 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2477 sym = SvPV(sv, n_a);
2479 DIE(aTHX_ PL_no_usym, "a subroutine");
2480 if (PL_op->op_private & HINT_STRICT_REFS)
2481 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2482 cv = get_cv(sym, TRUE);
2487 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2488 tryAMAGICunDEREF(to_cv);
2491 if (SvTYPE(cv) == SVt_PVCV)
2496 DIE(aTHX_ "Not a CODE reference");
2501 if (!(cv = GvCVu((GV*)sv)))
2502 cv = sv_2cv(sv, &stash, &gv, FALSE);
2515 if (!CvROOT(cv) && !CvXSUB(cv)) {
2519 /* anonymous or undef'd function leaves us no recourse */
2520 if (CvANON(cv) || !(gv = CvGV(cv)))
2521 DIE(aTHX_ "Undefined subroutine called");
2523 /* autoloaded stub? */
2524 if (cv != GvCV(gv)) {
2527 /* should call AUTOLOAD now? */
2530 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2537 sub_name = sv_newmortal();
2538 gv_efullname3(sub_name, gv, Nullch);
2539 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2543 DIE(aTHX_ "Not a CODE reference");
2548 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2549 cv = get_db_sub(&sv, cv);
2551 DIE(aTHX_ "No DBsub routine");
2555 #ifdef PERL_XSUB_OLDSTYLE
2556 if (CvOLDSTYLE(cv)) {
2557 I32 (*fp3)(int,int,int);
2559 register I32 items = SP - MARK;
2560 /* We dont worry to copy from @_. */
2565 PL_stack_sp = mark + 1;
2566 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2567 items = (*fp3)(CvXSUBANY(cv).any_i32,
2568 MARK - PL_stack_base + 1,
2570 PL_stack_sp = PL_stack_base + items;
2573 #endif /* PERL_XSUB_OLDSTYLE */
2575 I32 markix = TOPMARK;
2580 /* Need to copy @_ to stack. Alternative may be to
2581 * switch stack to @_, and copy return values
2582 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2585 av = GvAV(PL_defgv);
2586 items = AvFILLp(av) + 1; /* @_ is not tieable */
2589 /* Mark is at the end of the stack. */
2591 Copy(AvARRAY(av), SP + 1, items, SV*);
2596 /* We assume first XSUB in &DB::sub is the called one. */
2598 SAVEVPTR(PL_curcop);
2599 PL_curcop = PL_curcopdb;
2602 /* Do we need to open block here? XXXX */
2603 (void)(*CvXSUB(cv))(aTHX_ cv);
2605 /* Enforce some sanity in scalar context. */
2606 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2607 if (markix > PL_stack_sp - PL_stack_base)
2608 *(PL_stack_base + markix) = &PL_sv_undef;
2610 *(PL_stack_base + markix) = *PL_stack_sp;
2611 PL_stack_sp = PL_stack_base + markix;
2619 register I32 items = SP - MARK;
2620 AV* padlist = CvPADLIST(cv);
2621 push_return(PL_op->op_next);
2622 PUSHBLOCK(cx, CXt_SUB, MARK);
2625 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2626 * that eval'' ops within this sub know the correct lexical space.
2627 * Owing the speed considerations, we choose to search for the cv
2628 * in doeval() instead.
2630 if (CvDEPTH(cv) < 2)
2631 (void)SvREFCNT_inc(cv);
2633 PERL_STACK_OVERFLOW_CHECK();
2634 pad_push(padlist, CvDEPTH(cv), 1);
2636 PAD_SET_CUR(padlist, CvDEPTH(cv));
2643 DEBUG_S(PerlIO_printf(Perl_debug_log,
2644 "%p entersub preparing @_\n", thr));
2646 av = (AV*)PAD_SVl(0);
2648 /* @_ is normally not REAL--this should only ever
2649 * happen when DB::sub() calls things that modify @_ */
2654 cx->blk_sub.savearray = GvAV(PL_defgv);
2655 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2656 CX_CURPAD_SAVE(cx->blk_sub);
2657 cx->blk_sub.argarray = av;
2660 if (items > AvMAX(av) + 1) {
2662 if (AvARRAY(av) != ary) {
2663 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2664 SvPVX(av) = (char*)ary;
2666 if (items > AvMAX(av) + 1) {
2667 AvMAX(av) = items - 1;
2668 Renew(ary,items,SV*);
2670 SvPVX(av) = (char*)ary;
2673 Copy(MARK,AvARRAY(av),items,SV*);
2674 AvFILLp(av) = items - 1;
2682 /* warning must come *after* we fully set up the context
2683 * stuff so that __WARN__ handlers can safely dounwind()
2686 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2687 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2688 sub_crush_depth(cv);
2690 DEBUG_S(PerlIO_printf(Perl_debug_log,
2691 "%p entersub returning %p\n", thr, CvSTART(cv)));
2693 RETURNOP(CvSTART(cv));
2698 Perl_sub_crush_depth(pTHX_ CV *cv)
2701 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2703 SV* tmpstr = sv_newmortal();
2704 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2705 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
2715 IV elem = SvIV(elemsv);
2717 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2718 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2721 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2722 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2724 elem -= PL_curcop->cop_arybase;
2725 if (SvTYPE(av) != SVt_PVAV)
2727 svp = av_fetch(av, elem, lval && !defer);
2729 if (!svp || *svp == &PL_sv_undef) {
2732 DIE(aTHX_ PL_no_aelem, elem);
2733 lv = sv_newmortal();
2734 sv_upgrade(lv, SVt_PVLV);
2736 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2737 LvTARG(lv) = SvREFCNT_inc(av);
2738 LvTARGOFF(lv) = elem;
2743 if (PL_op->op_private & OPpLVAL_INTRO)
2744 save_aelem(av, elem, svp);
2745 else if (PL_op->op_private & OPpDEREF)
2746 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2748 sv = (svp ? *svp : &PL_sv_undef);
2749 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2750 sv = sv_mortalcopy(sv);
2756 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2762 Perl_croak(aTHX_ PL_no_modify);
2763 if (SvTYPE(sv) < SVt_RV)
2764 sv_upgrade(sv, SVt_RV);
2765 else if (SvTYPE(sv) >= SVt_PV) {
2766 (void)SvOOK_off(sv);
2767 Safefree(SvPVX(sv));
2768 SvLEN(sv) = SvCUR(sv) = 0;
2772 SvRV(sv) = NEWSV(355,0);
2775 SvRV(sv) = (SV*)newAV();
2778 SvRV(sv) = (SV*)newHV();
2793 if (SvTYPE(rsv) == SVt_PVCV) {
2799 SETs(method_common(sv, Null(U32*)));
2806 SV* sv = cSVOP->op_sv;
2807 U32 hash = SvUVX(sv);
2809 XPUSHs(method_common(sv, &hash));
2814 S_method_common(pTHX_ SV* meth, U32* hashp)
2823 SV *packsv = Nullsv;
2826 name = SvPV(meth, namelen);
2827 sv = *(PL_stack_base + TOPMARK + 1);
2830 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2839 /* this isn't a reference */
2842 !(packname = SvPV(sv, packlen)) ||
2843 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2844 !(ob=(SV*)GvIO(iogv)))
2846 /* this isn't the name of a filehandle either */
2848 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2849 ? !isIDFIRST_utf8((U8*)packname)
2850 : !isIDFIRST(*packname)
2853 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2854 SvOK(sv) ? "without a package or object reference"
2855 : "on an undefined value");
2857 /* assume it's a package name */
2858 stash = gv_stashpvn(packname, packlen, FALSE);
2863 /* it _is_ a filehandle name -- replace with a reference */
2864 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2867 /* if we got here, ob should be a reference or a glob */
2868 if (!ob || !(SvOBJECT(ob)
2869 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2872 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2876 stash = SvSTASH(ob);
2879 /* NOTE: stash may be null, hope hv_fetch_ent and
2880 gv_fetchmethod can cope (it seems they can) */
2882 /* shortcut for simple names */
2884 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2886 gv = (GV*)HeVAL(he);
2887 if (isGV(gv) && GvCV(gv) &&
2888 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2889 return (SV*)GvCV(gv);
2893 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
2896 /* This code tries to figure out just what went wrong with
2897 gv_fetchmethod. It therefore needs to duplicate a lot of
2898 the internals of that function. We can't move it inside
2899 Perl_gv_fetchmethod_autoload(), however, since that would
2900 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
2907 for (p = name; *p; p++) {
2909 sep = p, leaf = p + 1;
2910 else if (*p == ':' && *(p + 1) == ':')
2911 sep = p, leaf = p + 2;
2913 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
2914 /* the method name is unqualified or starts with SUPER:: */
2915 packname = sep ? CopSTASHPV(PL_curcop) :
2916 stash ? HvNAME(stash) : packname;
2917 packlen = strlen(packname);
2920 /* the method name is qualified */
2922 packlen = sep - name;
2925 /* we're relying on gv_fetchmethod not autovivifying the stash */
2926 if (gv_stashpvn(packname, packlen, FALSE)) {
2928 "Can't locate object method \"%s\" via package \"%.*s\"",
2929 leaf, (int)packlen, packname);
2933 "Can't locate object method \"%s\" via package \"%.*s\""
2934 " (perhaps you forgot to load \"%.*s\"?)",
2935 leaf, (int)packlen, packname, (int)packlen, packname);
2938 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;