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 RX_MATCH_UTF8_set(rx, 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 (RX_MATCH_UTF8(rx)) {
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) {
1370 #ifdef PERL_COPY_ON_WRITE
1371 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1373 PerlIO_printf(Perl_debug_log,
1374 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1375 (int) SvTYPE(TARG), truebase, t,
1378 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1379 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1380 assert (SvPOKp(rx->saved_copy));
1385 rx->subbeg = savepvn(t, strend - t);
1386 #ifdef PERL_COPY_ON_WRITE
1387 rx->saved_copy = Nullsv;
1390 rx->sublen = strend - t;
1391 RX_MATCH_COPIED_on(rx);
1392 off = rx->startp[0] = s - t;
1393 rx->endp[0] = off + rx->minlen;
1395 else { /* startp/endp are used by @- @+. */
1396 rx->startp[0] = s - truebase;
1397 rx->endp[0] = s - truebase + rx->minlen;
1399 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1400 LEAVE_SCOPE(oldsave);
1405 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1406 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1407 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1412 LEAVE_SCOPE(oldsave);
1413 if (gimme == G_ARRAY)
1419 Perl_do_readline(pTHX)
1421 dSP; dTARGETSTACKED;
1426 register IO *io = GvIO(PL_last_in_gv);
1427 register I32 type = PL_op->op_type;
1428 I32 gimme = GIMME_V;
1431 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1433 XPUSHs(SvTIED_obj((SV*)io, mg));
1436 call_method("READLINE", gimme);
1439 if (gimme == G_SCALAR) {
1441 SvSetSV_nosteal(TARG, result);
1450 if (IoFLAGS(io) & IOf_ARGV) {
1451 if (IoFLAGS(io) & IOf_START) {
1453 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1454 IoFLAGS(io) &= ~IOf_START;
1455 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1456 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1457 SvSETMAGIC(GvSV(PL_last_in_gv));
1462 fp = nextargv(PL_last_in_gv);
1463 if (!fp) { /* Note: fp != IoIFP(io) */
1464 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1467 else if (type == OP_GLOB)
1468 fp = Perl_start_glob(aTHX_ POPs, io);
1470 else if (type == OP_GLOB)
1472 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1473 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1477 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1478 && (!io || !(IoFLAGS(io) & IOf_START))) {
1479 if (type == OP_GLOB)
1480 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1481 "glob failed (can't start child: %s)",
1484 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1486 if (gimme == G_SCALAR) {
1487 /* undef TARG, and push that undefined value */
1488 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1489 (void)SvOK_off(TARG);
1495 if (gimme == G_SCALAR) {
1499 (void)SvUPGRADE(sv, SVt_PV);
1500 tmplen = SvLEN(sv); /* remember if already alloced */
1502 Sv_Grow(sv, 80); /* try short-buffering it */
1504 if (type == OP_RCATLINE && SvOK(sv)) {
1507 (void)SvPV_force(sv, n_a);
1513 sv = sv_2mortal(NEWSV(57, 80));
1517 /* This should not be marked tainted if the fp is marked clean */
1518 #define MAYBE_TAINT_LINE(io, sv) \
1519 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1524 /* delay EOF state for a snarfed empty file */
1525 #define SNARF_EOF(gimme,rs,io,sv) \
1526 (gimme != G_SCALAR || SvCUR(sv) \
1527 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1531 if (!sv_gets(sv, fp, offset)
1532 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1534 PerlIO_clearerr(fp);
1535 if (IoFLAGS(io) & IOf_ARGV) {
1536 fp = nextargv(PL_last_in_gv);
1539 (void)do_close(PL_last_in_gv, FALSE);
1541 else if (type == OP_GLOB) {
1542 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1543 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1544 "glob failed (child exited with status %d%s)",
1545 (int)(STATUS_CURRENT >> 8),
1546 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1549 if (gimme == G_SCALAR) {
1550 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1551 (void)SvOK_off(TARG);
1555 MAYBE_TAINT_LINE(io, sv);
1558 MAYBE_TAINT_LINE(io, sv);
1560 IoFLAGS(io) |= IOf_NOLINE;
1564 if (type == OP_GLOB) {
1567 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1568 tmps = SvEND(sv) - 1;
1569 if (*tmps == *SvPVX(PL_rs)) {
1574 for (tmps = SvPVX(sv); *tmps; tmps++)
1575 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1576 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1578 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1579 (void)POPs; /* Unmatched wildcard? Chuck it... */
1583 if (gimme == G_ARRAY) {
1584 if (SvLEN(sv) - SvCUR(sv) > 20) {
1585 SvLEN_set(sv, SvCUR(sv)+1);
1586 Renew(SvPVX(sv), SvLEN(sv), char);
1588 sv = sv_2mortal(NEWSV(58, 80));
1591 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1592 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1596 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1597 Renew(SvPVX(sv), SvLEN(sv), char);
1606 register PERL_CONTEXT *cx;
1607 I32 gimme = OP_GIMME(PL_op, -1);
1610 if (cxstack_ix >= 0)
1611 gimme = cxstack[cxstack_ix].blk_gimme;
1619 PUSHBLOCK(cx, CXt_BLOCK, SP);
1631 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1632 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1634 #ifdef PERL_COPY_ON_WRITE
1635 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1637 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1641 if (SvTYPE(hv) == SVt_PVHV) {
1642 if (PL_op->op_private & OPpLVAL_INTRO) {
1645 /* does the element we're localizing already exist? */
1647 /* can we determine whether it exists? */
1649 || mg_find((SV*)hv, PERL_MAGIC_env)
1650 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1651 /* Try to preserve the existenceness of a tied hash
1652 * element by using EXISTS and DELETE if possible.
1653 * Fallback to FETCH and STORE otherwise */
1654 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1655 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1656 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1658 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1661 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1662 svp = he ? &HeVAL(he) : 0;
1668 if (!svp || *svp == &PL_sv_undef) {
1673 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1675 lv = sv_newmortal();
1676 sv_upgrade(lv, SVt_PVLV);
1678 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1679 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1680 LvTARG(lv) = SvREFCNT_inc(hv);
1685 if (PL_op->op_private & OPpLVAL_INTRO) {
1686 if (HvNAME(hv) && isGV(*svp))
1687 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1691 char *key = SvPV(keysv, keylen);
1692 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1694 save_helem(hv, keysv, svp);
1697 else if (PL_op->op_private & OPpDEREF)
1698 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1700 sv = (svp ? *svp : &PL_sv_undef);
1701 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1702 * Pushing the magical RHS on to the stack is useless, since
1703 * that magic is soon destined to be misled by the local(),
1704 * and thus the later pp_sassign() will fail to mg_get() the
1705 * old value. This should also cure problems with delayed
1706 * mg_get()s. GSAR 98-07-03 */
1707 if (!lval && SvGMAGICAL(sv))
1708 sv = sv_mortalcopy(sv);
1716 register PERL_CONTEXT *cx;
1722 if (PL_op->op_flags & OPf_SPECIAL) {
1723 cx = &cxstack[cxstack_ix];
1724 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1729 gimme = OP_GIMME(PL_op, -1);
1731 if (cxstack_ix >= 0)
1732 gimme = cxstack[cxstack_ix].blk_gimme;
1738 if (gimme == G_VOID)
1740 else if (gimme == G_SCALAR) {
1743 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1746 *MARK = sv_mortalcopy(TOPs);
1749 *MARK = &PL_sv_undef;
1753 else if (gimme == G_ARRAY) {
1754 /* in case LEAVE wipes old return values */
1755 for (mark = newsp + 1; mark <= SP; mark++) {
1756 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1757 *mark = sv_mortalcopy(*mark);
1758 TAINT_NOT; /* Each item is independent */
1762 PL_curpm = newpm; /* Don't pop $1 et al till now */
1772 register PERL_CONTEXT *cx;
1778 cx = &cxstack[cxstack_ix];
1779 if (CxTYPE(cx) != CXt_LOOP)
1780 DIE(aTHX_ "panic: pp_iter");
1782 itersvp = CxITERVAR(cx);
1783 av = cx->blk_loop.iterary;
1784 if (SvTYPE(av) != SVt_PVAV) {
1785 /* iterate ($min .. $max) */
1786 if (cx->blk_loop.iterlval) {
1787 /* string increment */
1788 register SV* cur = cx->blk_loop.iterlval;
1790 char *max = SvPV((SV*)av, maxlen);
1791 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1792 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1793 /* safe to reuse old SV */
1794 sv_setsv(*itersvp, cur);
1798 /* we need a fresh SV every time so that loop body sees a
1799 * completely new SV for closures/references to work as
1801 SvREFCNT_dec(*itersvp);
1802 *itersvp = newSVsv(cur);
1804 if (strEQ(SvPVX(cur), max))
1805 sv_setiv(cur, 0); /* terminate next time */
1812 /* integer increment */
1813 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1816 /* don't risk potential race */
1817 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1818 /* safe to reuse old SV */
1819 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1823 /* we need a fresh SV every time so that loop body sees a
1824 * completely new SV for closures/references to work as they
1826 SvREFCNT_dec(*itersvp);
1827 *itersvp = newSViv(cx->blk_loop.iterix++);
1833 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1836 SvREFCNT_dec(*itersvp);
1838 if (SvMAGICAL(av) || AvREIFY(av)) {
1839 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1846 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1852 if (av != PL_curstack && sv == &PL_sv_undef) {
1853 SV *lv = cx->blk_loop.iterlval;
1854 if (lv && SvREFCNT(lv) > 1) {
1859 SvREFCNT_dec(LvTARG(lv));
1861 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1862 sv_upgrade(lv, SVt_PVLV);
1864 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1866 LvTARG(lv) = SvREFCNT_inc(av);
1867 LvTARGOFF(lv) = cx->blk_loop.iterix;
1868 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1872 *itersvp = SvREFCNT_inc(sv);
1879 register PMOP *pm = cPMOP;
1895 register REGEXP *rx = PM_GETRE(pm);
1897 int force_on_match = 0;
1898 I32 oldsave = PL_savestack_ix;
1900 bool doutf8 = FALSE;
1901 #ifdef PERL_COPY_ON_WRITE
1905 /* known replacement string? */
1906 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1907 if (PL_op->op_flags & OPf_STACKED)
1914 #ifdef PERL_COPY_ON_WRITE
1915 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1916 because they make integers such as 256 "false". */
1917 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1920 sv_force_normal_flags(TARG,0);
1923 #ifdef PERL_COPY_ON_WRITE
1927 || (SvTYPE(TARG) > SVt_PVLV
1928 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1929 DIE(aTHX_ PL_no_modify);
1932 s = SvPV(TARG, len);
1933 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1935 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1936 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1941 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1945 DIE(aTHX_ "panic: pp_subst");
1948 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
1949 maxiters = 2 * slen + 10; /* We can match twice at each
1950 position, once with zero-length,
1951 second time with non-zero. */
1953 if (!rx->prelen && PL_curpm) {
1957 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1958 ? REXEC_COPY_STR : 0;
1960 r_flags |= REXEC_SCREAM;
1961 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1962 SAVEINT(PL_multiline);
1963 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1966 if (rx->reganch & RE_USE_INTUIT) {
1968 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1972 /* How to do it in subst? */
1973 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1975 && ((rx->reganch & ROPT_NOSCAN)
1976 || !((rx->reganch & RE_INTUIT_TAIL)
1977 && (r_flags & REXEC_SCREAM))))
1982 /* only replace once? */
1983 once = !(rpm->op_pmflags & PMf_GLOBAL);
1985 /* known replacement string? */
1987 /* replacement needing upgrading? */
1988 if (DO_UTF8(TARG) && !doutf8) {
1989 SV *nsv = sv_newmortal();
1992 sv_recode_to_utf8(nsv, PL_encoding);
1994 sv_utf8_upgrade(nsv);
1995 c = SvPV(nsv, clen);
1999 c = SvPV(dstr, clen);
2000 doutf8 = DO_UTF8(dstr);
2008 /* can do inplace substitution? */
2010 #ifdef PERL_COPY_ON_WRITE
2013 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2014 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
2015 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2016 r_flags | REXEC_CHECKED))
2020 LEAVE_SCOPE(oldsave);
2023 #ifdef PERL_COPY_ON_WRITE
2024 if (SvIsCOW(TARG)) {
2025 assert (!force_on_match);
2029 if (force_on_match) {
2031 s = SvPV_force(TARG, len);
2036 SvSCREAM_off(TARG); /* disable possible screamer */
2038 rxtainted |= RX_MATCH_TAINTED(rx);
2039 m = orig + rx->startp[0];
2040 d = orig + rx->endp[0];
2042 if (m - s > strend - d) { /* faster to shorten from end */
2044 Copy(c, m, clen, char);
2049 Move(d, m, i, char);
2053 SvCUR_set(TARG, m - s);
2056 else if ((i = m - s)) { /* faster from front */
2064 Copy(c, m, clen, char);
2069 Copy(c, d, clen, char);
2074 TAINT_IF(rxtainted & 1);
2080 if (iters++ > maxiters)
2081 DIE(aTHX_ "Substitution loop");
2082 rxtainted |= RX_MATCH_TAINTED(rx);
2083 m = rx->startp[0] + orig;
2087 Move(s, d, i, char);
2091 Copy(c, d, clen, char);
2094 s = rx->endp[0] + orig;
2095 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2097 /* don't match same null twice */
2098 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2101 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2102 Move(s, d, i+1, char); /* include the NUL */
2104 TAINT_IF(rxtainted & 1);
2106 PUSHs(sv_2mortal(newSViv((I32)iters)));
2108 (void)SvPOK_only_UTF8(TARG);
2109 TAINT_IF(rxtainted);
2110 if (SvSMAGICAL(TARG)) {
2118 LEAVE_SCOPE(oldsave);
2122 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2123 r_flags | REXEC_CHECKED))
2125 if (force_on_match) {
2127 s = SvPV_force(TARG, len);
2130 #ifdef PERL_COPY_ON_WRITE
2133 rxtainted |= RX_MATCH_TAINTED(rx);
2134 dstr = NEWSV(25, len);
2135 sv_setpvn(dstr, m, s-m);
2140 register PERL_CONTEXT *cx;
2143 RETURNOP(cPMOP->op_pmreplroot);
2145 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2147 if (iters++ > maxiters)
2148 DIE(aTHX_ "Substitution loop");
2149 rxtainted |= RX_MATCH_TAINTED(rx);
2150 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2155 strend = s + (strend - m);
2157 m = rx->startp[0] + orig;
2158 sv_catpvn(dstr, s, m-s);
2159 s = rx->endp[0] + orig;
2161 sv_catpvn(dstr, c, clen);
2164 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2165 TARG, NULL, r_flags));
2166 if (doutf8 && !DO_UTF8(dstr)) {
2167 SV* nsv = sv_2mortal(newSVpvn(s, strend - s));
2169 sv_utf8_upgrade(nsv);
2170 sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv));
2173 sv_catpvn(dstr, s, strend - s);
2175 #ifdef PERL_COPY_ON_WRITE
2176 /* The match may make the string COW. If so, brilliant, because that's
2177 just saved us one malloc, copy and free - the regexp has donated
2178 the old buffer, and we malloc an entirely new one, rather than the
2179 regexp malloc()ing a buffer and copying our original, only for
2180 us to throw it away here during the substitution. */
2181 if (SvIsCOW(TARG)) {
2182 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2186 (void)SvOOK_off(TARG);
2188 Safefree(SvPVX(TARG));
2190 SvPVX(TARG) = SvPVX(dstr);
2191 SvCUR_set(TARG, SvCUR(dstr));
2192 SvLEN_set(TARG, SvLEN(dstr));
2193 doutf8 |= DO_UTF8(dstr);
2197 TAINT_IF(rxtainted & 1);
2199 PUSHs(sv_2mortal(newSViv((I32)iters)));
2201 (void)SvPOK_only(TARG);
2204 TAINT_IF(rxtainted);
2207 LEAVE_SCOPE(oldsave);
2216 LEAVE_SCOPE(oldsave);
2225 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2226 ++*PL_markstack_ptr;
2227 LEAVE; /* exit inner scope */
2230 if (PL_stack_base + *PL_markstack_ptr > SP) {
2232 I32 gimme = GIMME_V;
2234 LEAVE; /* exit outer scope */
2235 (void)POPMARK; /* pop src */
2236 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2237 (void)POPMARK; /* pop dst */
2238 SP = PL_stack_base + POPMARK; /* pop original mark */
2239 if (gimme == G_SCALAR) {
2243 else if (gimme == G_ARRAY)
2250 ENTER; /* enter inner scope */
2253 src = PL_stack_base[*PL_markstack_ptr];
2257 RETURNOP(cLOGOP->op_other);
2268 register PERL_CONTEXT *cx;
2274 if (gimme == G_SCALAR) {
2277 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2279 *MARK = SvREFCNT_inc(TOPs);
2284 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2286 *MARK = sv_mortalcopy(sv);
2291 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2295 *MARK = &PL_sv_undef;
2299 else if (gimme == G_ARRAY) {
2300 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2301 if (!SvTEMP(*MARK)) {
2302 *MARK = sv_mortalcopy(*MARK);
2303 TAINT_NOT; /* Each item is independent */
2309 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2310 PL_curpm = newpm; /* ... and pop $1 et al */
2314 return pop_return();
2317 /* This duplicates the above code because the above code must not
2318 * get any slower by more conditions */
2326 register PERL_CONTEXT *cx;
2333 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2334 /* We are an argument to a function or grep().
2335 * This kind of lvalueness was legal before lvalue
2336 * subroutines too, so be backward compatible:
2337 * cannot report errors. */
2339 /* Scalar context *is* possible, on the LHS of -> only,
2340 * as in f()->meth(). But this is not an lvalue. */
2341 if (gimme == G_SCALAR)
2343 if (gimme == G_ARRAY) {
2344 if (!CvLVALUE(cx->blk_sub.cv))
2345 goto temporise_array;
2346 EXTEND_MORTAL(SP - newsp);
2347 for (mark = newsp + 1; mark <= SP; mark++) {
2350 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2351 *mark = sv_mortalcopy(*mark);
2353 /* Can be a localized value subject to deletion. */
2354 PL_tmps_stack[++PL_tmps_ix] = *mark;
2355 (void)SvREFCNT_inc(*mark);
2360 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2361 /* Here we go for robustness, not for speed, so we change all
2362 * the refcounts so the caller gets a live guy. Cannot set
2363 * TEMP, so sv_2mortal is out of question. */
2364 if (!CvLVALUE(cx->blk_sub.cv)) {
2369 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2371 if (gimme == G_SCALAR) {
2375 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2380 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2381 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2382 : "a readonly value" : "a temporary");
2384 else { /* Can be a localized value
2385 * subject to deletion. */
2386 PL_tmps_stack[++PL_tmps_ix] = *mark;
2387 (void)SvREFCNT_inc(*mark);
2390 else { /* Should not happen? */
2395 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2396 (MARK > SP ? "Empty array" : "Array"));
2400 else if (gimme == G_ARRAY) {
2401 EXTEND_MORTAL(SP - newsp);
2402 for (mark = newsp + 1; mark <= SP; mark++) {
2403 if (*mark != &PL_sv_undef
2404 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2405 /* Might be flattened array after $#array = */
2411 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2412 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2415 /* Can be a localized value subject to deletion. */
2416 PL_tmps_stack[++PL_tmps_ix] = *mark;
2417 (void)SvREFCNT_inc(*mark);
2423 if (gimme == G_SCALAR) {
2427 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2429 *MARK = SvREFCNT_inc(TOPs);
2434 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2436 *MARK = sv_mortalcopy(sv);
2441 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2445 *MARK = &PL_sv_undef;
2449 else if (gimme == G_ARRAY) {
2451 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2452 if (!SvTEMP(*MARK)) {
2453 *MARK = sv_mortalcopy(*MARK);
2454 TAINT_NOT; /* Each item is independent */
2461 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2462 PL_curpm = newpm; /* ... and pop $1 et al */
2466 return pop_return();
2471 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2473 SV *dbsv = GvSV(PL_DBsub);
2475 if (!PERLDB_SUB_NN) {
2479 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2480 || strEQ(GvNAME(gv), "END")
2481 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2482 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2483 && (gv = (GV*)*svp) ))) {
2484 /* Use GV from the stack as a fallback. */
2485 /* GV is potentially non-unique, or contain different CV. */
2486 SV *tmp = newRV((SV*)cv);
2487 sv_setsv(dbsv, tmp);
2491 gv_efullname3(dbsv, gv, Nullch);
2495 (void)SvUPGRADE(dbsv, SVt_PVIV);
2496 (void)SvIOK_on(dbsv);
2497 SAVEIV(SvIVX(dbsv));
2498 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2502 PL_curcopdb = PL_curcop;
2503 cv = GvCV(PL_DBsub);
2513 register PERL_CONTEXT *cx;
2515 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2518 DIE(aTHX_ "Not a CODE reference");
2519 switch (SvTYPE(sv)) {
2520 /* This is overwhelming the most common case: */
2522 if (!(cv = GvCVu((GV*)sv)))
2523 cv = sv_2cv(sv, &stash, &gv, FALSE);
2535 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2537 SP = PL_stack_base + POPMARK;
2540 if (SvGMAGICAL(sv)) {
2544 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2547 sym = SvPV(sv, n_a);
2549 DIE(aTHX_ PL_no_usym, "a subroutine");
2550 if (PL_op->op_private & HINT_STRICT_REFS)
2551 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2552 cv = get_cv(sym, TRUE);
2557 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2558 tryAMAGICunDEREF(to_cv);
2561 if (SvTYPE(cv) == SVt_PVCV)
2566 DIE(aTHX_ "Not a CODE reference");
2567 /* This is the second most common case: */
2577 if (!CvROOT(cv) && !CvXSUB(cv)) {
2582 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2583 if (CvASSERTION(cv) && PL_DBassertion)
2584 sv_setiv(PL_DBassertion, 1);
2586 cv = get_db_sub(&sv, cv);
2588 DIE(aTHX_ "No DBsub routine");
2591 if (!(CvXSUB(cv))) {
2592 /* This path taken at least 75% of the time */
2594 register I32 items = SP - MARK;
2595 AV* padlist = CvPADLIST(cv);
2596 push_return(PL_op->op_next);
2597 PUSHBLOCK(cx, CXt_SUB, MARK);
2600 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2601 * that eval'' ops within this sub know the correct lexical space.
2602 * Owing the speed considerations, we choose instead to search for
2603 * the cv using find_runcv() when calling doeval().
2605 if (CvDEPTH(cv) < 2)
2606 (void)SvREFCNT_inc(cv);
2608 PERL_STACK_OVERFLOW_CHECK();
2609 pad_push(padlist, CvDEPTH(cv), 1);
2611 PAD_SET_CUR(padlist, CvDEPTH(cv));
2618 DEBUG_S(PerlIO_printf(Perl_debug_log,
2619 "%p entersub preparing @_\n", thr));
2621 av = (AV*)PAD_SVl(0);
2623 /* @_ is normally not REAL--this should only ever
2624 * happen when DB::sub() calls things that modify @_ */
2629 cx->blk_sub.savearray = GvAV(PL_defgv);
2630 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2631 CX_CURPAD_SAVE(cx->blk_sub);
2632 cx->blk_sub.argarray = av;
2635 if (items > AvMAX(av) + 1) {
2637 if (AvARRAY(av) != ary) {
2638 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2639 SvPVX(av) = (char*)ary;
2641 if (items > AvMAX(av) + 1) {
2642 AvMAX(av) = items - 1;
2643 Renew(ary,items,SV*);
2645 SvPVX(av) = (char*)ary;
2648 Copy(MARK,AvARRAY(av),items,SV*);
2649 AvFILLp(av) = items - 1;
2657 /* warning must come *after* we fully set up the context
2658 * stuff so that __WARN__ handlers can safely dounwind()
2661 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2662 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2663 sub_crush_depth(cv);
2665 DEBUG_S(PerlIO_printf(Perl_debug_log,
2666 "%p entersub returning %p\n", thr, CvSTART(cv)));
2668 RETURNOP(CvSTART(cv));
2671 #ifdef PERL_XSUB_OLDSTYLE
2672 if (CvOLDSTYLE(cv)) {
2673 I32 (*fp3)(int,int,int);
2675 register I32 items = SP - MARK;
2676 /* We dont worry to copy from @_. */
2681 PL_stack_sp = mark + 1;
2682 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2683 items = (*fp3)(CvXSUBANY(cv).any_i32,
2684 MARK - PL_stack_base + 1,
2686 PL_stack_sp = PL_stack_base + items;
2689 #endif /* PERL_XSUB_OLDSTYLE */
2691 I32 markix = TOPMARK;
2696 /* Need to copy @_ to stack. Alternative may be to
2697 * switch stack to @_, and copy return values
2698 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2701 av = GvAV(PL_defgv);
2702 items = AvFILLp(av) + 1; /* @_ is not tieable */
2705 /* Mark is at the end of the stack. */
2707 Copy(AvARRAY(av), SP + 1, items, SV*);
2712 /* We assume first XSUB in &DB::sub is the called one. */
2714 SAVEVPTR(PL_curcop);
2715 PL_curcop = PL_curcopdb;
2718 /* Do we need to open block here? XXXX */
2719 (void)(*CvXSUB(cv))(aTHX_ cv);
2721 /* Enforce some sanity in scalar context. */
2722 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2723 if (markix > PL_stack_sp - PL_stack_base)
2724 *(PL_stack_base + markix) = &PL_sv_undef;
2726 *(PL_stack_base + markix) = *PL_stack_sp;
2727 PL_stack_sp = PL_stack_base + markix;
2734 assert (0); /* Cannot get here. */
2735 /* This is deliberately moved here as spaghetti code to keep it out of the
2742 /* anonymous or undef'd function leaves us no recourse */
2743 if (CvANON(cv) || !(gv = CvGV(cv)))
2744 DIE(aTHX_ "Undefined subroutine called");
2746 /* autoloaded stub? */
2747 if (cv != GvCV(gv)) {
2750 /* should call AUTOLOAD now? */
2753 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2760 sub_name = sv_newmortal();
2761 gv_efullname3(sub_name, gv, Nullch);
2762 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2766 DIE(aTHX_ "Not a CODE reference");
2772 Perl_sub_crush_depth(pTHX_ CV *cv)
2775 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2777 SV* tmpstr = sv_newmortal();
2778 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2779 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2789 IV elem = SvIV(elemsv);
2791 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2792 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2795 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2796 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2798 elem -= PL_curcop->cop_arybase;
2799 if (SvTYPE(av) != SVt_PVAV)
2801 svp = av_fetch(av, elem, lval && !defer);
2803 if (!svp || *svp == &PL_sv_undef) {
2806 DIE(aTHX_ PL_no_aelem, elem);
2807 lv = sv_newmortal();
2808 sv_upgrade(lv, SVt_PVLV);
2810 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2811 LvTARG(lv) = SvREFCNT_inc(av);
2812 LvTARGOFF(lv) = elem;
2817 if (PL_op->op_private & OPpLVAL_INTRO)
2818 save_aelem(av, elem, svp);
2819 else if (PL_op->op_private & OPpDEREF)
2820 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2822 sv = (svp ? *svp : &PL_sv_undef);
2823 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2824 sv = sv_mortalcopy(sv);
2830 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2836 Perl_croak(aTHX_ PL_no_modify);
2837 if (SvTYPE(sv) < SVt_RV)
2838 sv_upgrade(sv, SVt_RV);
2839 else if (SvTYPE(sv) >= SVt_PV) {
2840 (void)SvOOK_off(sv);
2841 Safefree(SvPVX(sv));
2842 SvLEN(sv) = SvCUR(sv) = 0;
2846 SvRV(sv) = NEWSV(355,0);
2849 SvRV(sv) = (SV*)newAV();
2852 SvRV(sv) = (SV*)newHV();
2867 if (SvTYPE(rsv) == SVt_PVCV) {
2873 SETs(method_common(sv, Null(U32*)));
2881 U32 hash = SvUVX(sv);
2883 XPUSHs(method_common(sv, &hash));
2888 S_method_common(pTHX_ SV* meth, U32* hashp)
2897 SV *packsv = Nullsv;
2900 name = SvPV(meth, namelen);
2901 sv = *(PL_stack_base + TOPMARK + 1);
2904 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2913 /* this isn't a reference */
2916 !(packname = SvPV(sv, packlen)) ||
2917 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2918 !(ob=(SV*)GvIO(iogv)))
2920 /* this isn't the name of a filehandle either */
2922 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2923 ? !isIDFIRST_utf8((U8*)packname)
2924 : !isIDFIRST(*packname)
2927 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2928 SvOK(sv) ? "without a package or object reference"
2929 : "on an undefined value");
2931 /* assume it's a package name */
2932 stash = gv_stashpvn(packname, packlen, FALSE);
2937 /* it _is_ a filehandle name -- replace with a reference */
2938 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2941 /* if we got here, ob should be a reference or a glob */
2942 if (!ob || !(SvOBJECT(ob)
2943 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2946 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2950 stash = SvSTASH(ob);
2953 /* NOTE: stash may be null, hope hv_fetch_ent and
2954 gv_fetchmethod can cope (it seems they can) */
2956 /* shortcut for simple names */
2958 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2960 gv = (GV*)HeVAL(he);
2961 if (isGV(gv) && GvCV(gv) &&
2962 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2963 return (SV*)GvCV(gv);
2967 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
2970 /* This code tries to figure out just what went wrong with
2971 gv_fetchmethod. It therefore needs to duplicate a lot of
2972 the internals of that function. We can't move it inside
2973 Perl_gv_fetchmethod_autoload(), however, since that would
2974 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
2981 for (p = name; *p; p++) {
2983 sep = p, leaf = p + 1;
2984 else if (*p == ':' && *(p + 1) == ':')
2985 sep = p, leaf = p + 2;
2987 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
2988 /* the method name is unqualified or starts with SUPER:: */
2989 packname = sep ? CopSTASHPV(PL_curcop) :
2990 stash ? HvNAME(stash) : packname;
2991 packlen = strlen(packname);
2994 /* the method name is qualified */
2996 packlen = sep - name;
2999 /* we're relying on gv_fetchmethod not autovivifying the stash */
3000 if (gv_stashpvn(packname, packlen, FALSE)) {
3002 "Can't locate object method \"%s\" via package \"%.*s\"",
3003 leaf, (int)packlen, packname);
3007 "Can't locate object method \"%s\" via package \"%.*s\""
3008 " (perhaps you forgot to load \"%.*s\"?)",
3009 leaf, (int)packlen, packname, (int)packlen, packname);
3012 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;