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 a %s from lvalue subroutine",
2321 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2323 else { /* Can be a localized value
2324 * subject to deletion. */
2325 PL_tmps_stack[++PL_tmps_ix] = *mark;
2326 (void)SvREFCNT_inc(*mark);
2329 else { /* Should not happen? */
2334 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2335 (MARK > SP ? "Empty array" : "Array"));
2339 else if (gimme == G_ARRAY) {
2340 EXTEND_MORTAL(SP - newsp);
2341 for (mark = newsp + 1; mark <= SP; mark++) {
2342 if (*mark != &PL_sv_undef
2343 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2344 /* Might be flattened array after $#array = */
2350 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2351 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2354 /* Can be a localized value subject to deletion. */
2355 PL_tmps_stack[++PL_tmps_ix] = *mark;
2356 (void)SvREFCNT_inc(*mark);
2362 if (gimme == G_SCALAR) {
2366 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2368 *MARK = SvREFCNT_inc(TOPs);
2373 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2375 *MARK = sv_mortalcopy(sv);
2380 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2384 *MARK = &PL_sv_undef;
2388 else if (gimme == G_ARRAY) {
2390 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2391 if (!SvTEMP(*MARK)) {
2392 *MARK = sv_mortalcopy(*MARK);
2393 TAINT_NOT; /* Each item is independent */
2400 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2401 PL_curpm = newpm; /* ... and pop $1 et al */
2405 return pop_return();
2410 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2412 SV *dbsv = GvSV(PL_DBsub);
2414 if (!PERLDB_SUB_NN) {
2418 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2419 || strEQ(GvNAME(gv), "END")
2420 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2421 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2422 && (gv = (GV*)*svp) ))) {
2423 /* Use GV from the stack as a fallback. */
2424 /* GV is potentially non-unique, or contain different CV. */
2425 SV *tmp = newRV((SV*)cv);
2426 sv_setsv(dbsv, tmp);
2430 gv_efullname3(dbsv, gv, Nullch);
2434 (void)SvUPGRADE(dbsv, SVt_PVIV);
2435 (void)SvIOK_on(dbsv);
2436 SAVEIV(SvIVX(dbsv));
2437 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2441 PL_curcopdb = PL_curcop;
2442 cv = GvCV(PL_DBsub);
2452 register PERL_CONTEXT *cx;
2454 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2457 DIE(aTHX_ "Not a CODE reference");
2458 switch (SvTYPE(sv)) {
2464 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2466 SP = PL_stack_base + POPMARK;
2469 if (SvGMAGICAL(sv)) {
2473 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2476 sym = SvPV(sv, n_a);
2478 DIE(aTHX_ PL_no_usym, "a subroutine");
2479 if (PL_op->op_private & HINT_STRICT_REFS)
2480 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2481 cv = get_cv(sym, TRUE);
2486 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2487 tryAMAGICunDEREF(to_cv);
2490 if (SvTYPE(cv) == SVt_PVCV)
2495 DIE(aTHX_ "Not a CODE reference");
2500 if (!(cv = GvCVu((GV*)sv)))
2501 cv = sv_2cv(sv, &stash, &gv, FALSE);
2514 if (!CvROOT(cv) && !CvXSUB(cv)) {
2518 /* anonymous or undef'd function leaves us no recourse */
2519 if (CvANON(cv) || !(gv = CvGV(cv)))
2520 DIE(aTHX_ "Undefined subroutine called");
2522 /* autoloaded stub? */
2523 if (cv != GvCV(gv)) {
2526 /* should call AUTOLOAD now? */
2529 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2536 sub_name = sv_newmortal();
2537 gv_efullname3(sub_name, gv, Nullch);
2538 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2542 DIE(aTHX_ "Not a CODE reference");
2547 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2548 cv = get_db_sub(&sv, cv);
2550 DIE(aTHX_ "No DBsub routine");
2554 #ifdef PERL_XSUB_OLDSTYLE
2555 if (CvOLDSTYLE(cv)) {
2556 I32 (*fp3)(int,int,int);
2558 register I32 items = SP - MARK;
2559 /* We dont worry to copy from @_. */
2564 PL_stack_sp = mark + 1;
2565 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2566 items = (*fp3)(CvXSUBANY(cv).any_i32,
2567 MARK - PL_stack_base + 1,
2569 PL_stack_sp = PL_stack_base + items;
2572 #endif /* PERL_XSUB_OLDSTYLE */
2574 I32 markix = TOPMARK;
2579 /* Need to copy @_ to stack. Alternative may be to
2580 * switch stack to @_, and copy return values
2581 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2584 av = GvAV(PL_defgv);
2585 items = AvFILLp(av) + 1; /* @_ is not tieable */
2588 /* Mark is at the end of the stack. */
2590 Copy(AvARRAY(av), SP + 1, items, SV*);
2595 /* We assume first XSUB in &DB::sub is the called one. */
2597 SAVEVPTR(PL_curcop);
2598 PL_curcop = PL_curcopdb;
2601 /* Do we need to open block here? XXXX */
2602 (void)(*CvXSUB(cv))(aTHX_ cv);
2604 /* Enforce some sanity in scalar context. */
2605 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2606 if (markix > PL_stack_sp - PL_stack_base)
2607 *(PL_stack_base + markix) = &PL_sv_undef;
2609 *(PL_stack_base + markix) = *PL_stack_sp;
2610 PL_stack_sp = PL_stack_base + markix;
2618 register I32 items = SP - MARK;
2619 AV* padlist = CvPADLIST(cv);
2620 push_return(PL_op->op_next);
2621 PUSHBLOCK(cx, CXt_SUB, MARK);
2624 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2625 * that eval'' ops within this sub know the correct lexical space.
2626 * Owing the speed considerations, we choose to search for the cv
2627 * in doeval() instead.
2629 if (CvDEPTH(cv) < 2)
2630 (void)SvREFCNT_inc(cv);
2632 PERL_STACK_OVERFLOW_CHECK();
2633 pad_push(padlist, CvDEPTH(cv), 1);
2635 PAD_SET_CUR(padlist, CvDEPTH(cv));
2642 DEBUG_S(PerlIO_printf(Perl_debug_log,
2643 "%p entersub preparing @_\n", thr));
2645 av = (AV*)PAD_SVl(0);
2647 /* @_ is normally not REAL--this should only ever
2648 * happen when DB::sub() calls things that modify @_ */
2653 cx->blk_sub.savearray = GvAV(PL_defgv);
2654 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2655 CX_CURPAD_SAVE(cx->blk_sub);
2656 cx->blk_sub.argarray = av;
2659 if (items > AvMAX(av) + 1) {
2661 if (AvARRAY(av) != ary) {
2662 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2663 SvPVX(av) = (char*)ary;
2665 if (items > AvMAX(av) + 1) {
2666 AvMAX(av) = items - 1;
2667 Renew(ary,items,SV*);
2669 SvPVX(av) = (char*)ary;
2672 Copy(MARK,AvARRAY(av),items,SV*);
2673 AvFILLp(av) = items - 1;
2681 /* warning must come *after* we fully set up the context
2682 * stuff so that __WARN__ handlers can safely dounwind()
2685 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2686 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2687 sub_crush_depth(cv);
2689 DEBUG_S(PerlIO_printf(Perl_debug_log,
2690 "%p entersub returning %p\n", thr, CvSTART(cv)));
2692 RETURNOP(CvSTART(cv));
2697 Perl_sub_crush_depth(pTHX_ CV *cv)
2700 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2702 SV* tmpstr = sv_newmortal();
2703 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2704 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
2714 IV elem = SvIV(elemsv);
2716 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2717 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2720 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2721 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2723 elem -= PL_curcop->cop_arybase;
2724 if (SvTYPE(av) != SVt_PVAV)
2726 svp = av_fetch(av, elem, lval && !defer);
2728 if (!svp || *svp == &PL_sv_undef) {
2731 DIE(aTHX_ PL_no_aelem, elem);
2732 lv = sv_newmortal();
2733 sv_upgrade(lv, SVt_PVLV);
2735 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2736 LvTARG(lv) = SvREFCNT_inc(av);
2737 LvTARGOFF(lv) = elem;
2742 if (PL_op->op_private & OPpLVAL_INTRO)
2743 save_aelem(av, elem, svp);
2744 else if (PL_op->op_private & OPpDEREF)
2745 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2747 sv = (svp ? *svp : &PL_sv_undef);
2748 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2749 sv = sv_mortalcopy(sv);
2755 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2761 Perl_croak(aTHX_ PL_no_modify);
2762 if (SvTYPE(sv) < SVt_RV)
2763 sv_upgrade(sv, SVt_RV);
2764 else if (SvTYPE(sv) >= SVt_PV) {
2765 (void)SvOOK_off(sv);
2766 Safefree(SvPVX(sv));
2767 SvLEN(sv) = SvCUR(sv) = 0;
2771 SvRV(sv) = NEWSV(355,0);
2774 SvRV(sv) = (SV*)newAV();
2777 SvRV(sv) = (SV*)newHV();
2792 if (SvTYPE(rsv) == SVt_PVCV) {
2798 SETs(method_common(sv, Null(U32*)));
2805 SV* sv = cSVOP->op_sv;
2806 U32 hash = SvUVX(sv);
2808 XPUSHs(method_common(sv, &hash));
2813 S_method_common(pTHX_ SV* meth, U32* hashp)
2824 name = SvPV(meth, namelen);
2825 sv = *(PL_stack_base + TOPMARK + 1);
2828 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2837 /* this isn't a reference */
2840 !(packname = SvPV(sv, packlen)) ||
2841 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2842 !(ob=(SV*)GvIO(iogv)))
2844 /* this isn't the name of a filehandle either */
2846 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2847 ? !isIDFIRST_utf8((U8*)packname)
2848 : !isIDFIRST(*packname)
2851 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2852 SvOK(sv) ? "without a package or object reference"
2853 : "on an undefined value");
2855 /* assume it's a package name */
2856 stash = gv_stashpvn(packname, packlen, FALSE);
2859 /* it _is_ a filehandle name -- replace with a reference */
2860 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2863 /* if we got here, ob should be a reference or a glob */
2864 if (!ob || !(SvOBJECT(ob)
2865 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2868 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2872 stash = SvSTASH(ob);
2875 /* NOTE: stash may be null, hope hv_fetch_ent and
2876 gv_fetchmethod can cope (it seems they can) */
2878 /* shortcut for simple names */
2880 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2882 gv = (GV*)HeVAL(he);
2883 if (isGV(gv) && GvCV(gv) &&
2884 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2885 return (SV*)GvCV(gv);
2889 gv = gv_fetchmethod(stash, name);
2892 /* This code tries to figure out just what went wrong with
2893 gv_fetchmethod. It therefore needs to duplicate a lot of
2894 the internals of that function. We can't move it inside
2895 Perl_gv_fetchmethod_autoload(), however, since that would
2896 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
2903 for (p = name; *p; p++) {
2905 sep = p, leaf = p + 1;
2906 else if (*p == ':' && *(p + 1) == ':')
2907 sep = p, leaf = p + 2;
2909 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
2910 /* the method name is unqualified or starts with SUPER:: */
2911 packname = sep ? CopSTASHPV(PL_curcop) :
2912 stash ? HvNAME(stash) : packname;
2913 packlen = strlen(packname);
2916 /* the method name is qualified */
2918 packlen = sep - name;
2921 /* we're relying on gv_fetchmethod not autovivifying the stash */
2922 if (gv_stashpvn(packname, packlen, FALSE)) {
2924 "Can't locate object method \"%s\" via package \"%.*s\"",
2925 leaf, (int)packlen, packname);
2929 "Can't locate object method \"%s\" via package \"%.*s\""
2930 " (perhaps you forgot to load \"%.*s\"?)",
2931 leaf, (int)packlen, packname, (int)packlen, packname);
2934 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;