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) {
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 /* undef TARG, and push that undefined value */
1470 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1471 (void)SvOK_off(TARG);
1477 if (gimme == G_SCALAR) {
1481 (void)SvUPGRADE(sv, SVt_PV);
1482 tmplen = SvLEN(sv); /* remember if already alloced */
1484 Sv_Grow(sv, 80); /* try short-buffering it */
1486 if (type == OP_RCATLINE && SvOK(sv)) {
1489 (void)SvPV_force(sv, n_a);
1495 sv = sv_2mortal(NEWSV(57, 80));
1499 /* This should not be marked tainted if the fp is marked clean */
1500 #define MAYBE_TAINT_LINE(io, sv) \
1501 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1506 /* delay EOF state for a snarfed empty file */
1507 #define SNARF_EOF(gimme,rs,io,sv) \
1508 (gimme != G_SCALAR || SvCUR(sv) \
1509 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1513 if (!sv_gets(sv, fp, offset)
1514 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1516 PerlIO_clearerr(fp);
1517 if (IoFLAGS(io) & IOf_ARGV) {
1518 fp = nextargv(PL_last_in_gv);
1521 (void)do_close(PL_last_in_gv, FALSE);
1523 else if (type == OP_GLOB) {
1524 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1525 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1526 "glob failed (child exited with status %d%s)",
1527 (int)(STATUS_CURRENT >> 8),
1528 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1531 if (gimme == G_SCALAR) {
1532 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1533 (void)SvOK_off(TARG);
1537 MAYBE_TAINT_LINE(io, sv);
1540 MAYBE_TAINT_LINE(io, sv);
1542 IoFLAGS(io) |= IOf_NOLINE;
1546 if (type == OP_GLOB) {
1549 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1550 tmps = SvEND(sv) - 1;
1551 if (*tmps == *SvPVX(PL_rs)) {
1556 for (tmps = SvPVX(sv); *tmps; tmps++)
1557 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1558 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1560 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1561 (void)POPs; /* Unmatched wildcard? Chuck it... */
1565 if (gimme == G_ARRAY) {
1566 if (SvLEN(sv) - SvCUR(sv) > 20) {
1567 SvLEN_set(sv, SvCUR(sv)+1);
1568 Renew(SvPVX(sv), SvLEN(sv), char);
1570 sv = sv_2mortal(NEWSV(58, 80));
1573 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1574 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1578 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1579 Renew(SvPVX(sv), SvLEN(sv), char);
1588 register PERL_CONTEXT *cx;
1589 I32 gimme = OP_GIMME(PL_op, -1);
1592 if (cxstack_ix >= 0)
1593 gimme = cxstack[cxstack_ix].blk_gimme;
1601 PUSHBLOCK(cx, CXt_BLOCK, SP);
1613 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1614 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1616 #ifdef PERL_COPY_ON_WRITE
1617 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1619 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1623 if (SvTYPE(hv) == SVt_PVHV) {
1624 if (PL_op->op_private & OPpLVAL_INTRO) {
1627 /* does the element we're localizing already exist? */
1629 /* can we determine whether it exists? */
1631 || mg_find((SV*)hv, PERL_MAGIC_env)
1632 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1633 /* Try to preserve the existenceness of a tied hash
1634 * element by using EXISTS and DELETE if possible.
1635 * Fallback to FETCH and STORE otherwise */
1636 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1637 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1638 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1640 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1643 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1644 svp = he ? &HeVAL(he) : 0;
1650 if (!svp || *svp == &PL_sv_undef) {
1655 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1657 lv = sv_newmortal();
1658 sv_upgrade(lv, SVt_PVLV);
1660 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1661 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1662 LvTARG(lv) = SvREFCNT_inc(hv);
1667 if (PL_op->op_private & OPpLVAL_INTRO) {
1668 if (HvNAME(hv) && isGV(*svp))
1669 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1673 char *key = SvPV(keysv, keylen);
1674 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1676 save_helem(hv, keysv, svp);
1679 else if (PL_op->op_private & OPpDEREF)
1680 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1682 sv = (svp ? *svp : &PL_sv_undef);
1683 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1684 * Pushing the magical RHS on to the stack is useless, since
1685 * that magic is soon destined to be misled by the local(),
1686 * and thus the later pp_sassign() will fail to mg_get() the
1687 * old value. This should also cure problems with delayed
1688 * mg_get()s. GSAR 98-07-03 */
1689 if (!lval && SvGMAGICAL(sv))
1690 sv = sv_mortalcopy(sv);
1698 register PERL_CONTEXT *cx;
1704 if (PL_op->op_flags & OPf_SPECIAL) {
1705 cx = &cxstack[cxstack_ix];
1706 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1711 gimme = OP_GIMME(PL_op, -1);
1713 if (cxstack_ix >= 0)
1714 gimme = cxstack[cxstack_ix].blk_gimme;
1720 if (gimme == G_VOID)
1722 else if (gimme == G_SCALAR) {
1725 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1728 *MARK = sv_mortalcopy(TOPs);
1731 *MARK = &PL_sv_undef;
1735 else if (gimme == G_ARRAY) {
1736 /* in case LEAVE wipes old return values */
1737 for (mark = newsp + 1; mark <= SP; mark++) {
1738 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1739 *mark = sv_mortalcopy(*mark);
1740 TAINT_NOT; /* Each item is independent */
1744 PL_curpm = newpm; /* Don't pop $1 et al till now */
1754 register PERL_CONTEXT *cx;
1760 cx = &cxstack[cxstack_ix];
1761 if (CxTYPE(cx) != CXt_LOOP)
1762 DIE(aTHX_ "panic: pp_iter");
1764 itersvp = CxITERVAR(cx);
1765 av = cx->blk_loop.iterary;
1766 if (SvTYPE(av) != SVt_PVAV) {
1767 /* iterate ($min .. $max) */
1768 if (cx->blk_loop.iterlval) {
1769 /* string increment */
1770 register SV* cur = cx->blk_loop.iterlval;
1772 char *max = SvPV((SV*)av, maxlen);
1773 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1774 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1775 /* safe to reuse old SV */
1776 sv_setsv(*itersvp, cur);
1780 /* we need a fresh SV every time so that loop body sees a
1781 * completely new SV for closures/references to work as
1783 SvREFCNT_dec(*itersvp);
1784 *itersvp = newSVsv(cur);
1786 if (strEQ(SvPVX(cur), max))
1787 sv_setiv(cur, 0); /* terminate next time */
1794 /* integer increment */
1795 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1798 /* don't risk potential race */
1799 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1800 /* safe to reuse old SV */
1801 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1805 /* we need a fresh SV every time so that loop body sees a
1806 * completely new SV for closures/references to work as they
1808 SvREFCNT_dec(*itersvp);
1809 *itersvp = newSViv(cx->blk_loop.iterix++);
1815 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1818 SvREFCNT_dec(*itersvp);
1820 if (SvMAGICAL(av) || AvREIFY(av)) {
1821 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1828 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1834 if (av != PL_curstack && sv == &PL_sv_undef) {
1835 SV *lv = cx->blk_loop.iterlval;
1836 if (lv && SvREFCNT(lv) > 1) {
1841 SvREFCNT_dec(LvTARG(lv));
1843 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1844 sv_upgrade(lv, SVt_PVLV);
1846 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1848 LvTARG(lv) = SvREFCNT_inc(av);
1849 LvTARGOFF(lv) = cx->blk_loop.iterix;
1850 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1854 *itersvp = SvREFCNT_inc(sv);
1861 register PMOP *pm = cPMOP;
1877 register REGEXP *rx = PM_GETRE(pm);
1879 int force_on_match = 0;
1880 I32 oldsave = PL_savestack_ix;
1882 bool doutf8 = FALSE;
1884 /* known replacement string? */
1885 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1886 if (PL_op->op_flags & OPf_STACKED)
1894 sv_force_normal_flags(TARG,0);
1895 if (SvREADONLY(TARG)
1896 || (SvTYPE(TARG) > SVt_PVLV
1897 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1898 DIE(aTHX_ PL_no_modify);
1901 s = SvPV(TARG, len);
1902 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1904 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1905 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1910 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1914 DIE(aTHX_ "panic: pp_subst");
1917 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
1918 maxiters = 2 * slen + 10; /* We can match twice at each
1919 position, once with zero-length,
1920 second time with non-zero. */
1922 if (!rx->prelen && PL_curpm) {
1926 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1927 ? REXEC_COPY_STR : 0;
1929 r_flags |= REXEC_SCREAM;
1930 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1931 SAVEINT(PL_multiline);
1932 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1935 if (rx->reganch & RE_USE_INTUIT) {
1937 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1941 /* How to do it in subst? */
1942 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1944 && ((rx->reganch & ROPT_NOSCAN)
1945 || !((rx->reganch & RE_INTUIT_TAIL)
1946 && (r_flags & REXEC_SCREAM))))
1951 /* only replace once? */
1952 once = !(rpm->op_pmflags & PMf_GLOBAL);
1954 /* known replacement string? */
1956 /* replacement needing upgrading? */
1957 if (DO_UTF8(TARG) && !doutf8) {
1958 SV *nsv = sv_newmortal();
1961 sv_recode_to_utf8(nsv, PL_encoding);
1963 sv_utf8_upgrade(nsv);
1964 c = SvPV(nsv, clen);
1968 c = SvPV(dstr, clen);
1969 doutf8 = DO_UTF8(dstr);
1977 /* can do inplace substitution? */
1978 if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1979 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1980 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1981 r_flags | REXEC_CHECKED))
1985 LEAVE_SCOPE(oldsave);
1988 if (force_on_match) {
1990 s = SvPV_force(TARG, len);
1995 SvSCREAM_off(TARG); /* disable possible screamer */
1997 rxtainted |= RX_MATCH_TAINTED(rx);
1998 m = orig + rx->startp[0];
1999 d = orig + rx->endp[0];
2001 if (m - s > strend - d) { /* faster to shorten from end */
2003 Copy(c, m, clen, char);
2008 Move(d, m, i, char);
2012 SvCUR_set(TARG, m - s);
2015 else if ((i = m - s)) { /* faster from front */
2023 Copy(c, m, clen, char);
2028 Copy(c, d, clen, char);
2033 TAINT_IF(rxtainted & 1);
2039 if (iters++ > maxiters)
2040 DIE(aTHX_ "Substitution loop");
2041 rxtainted |= RX_MATCH_TAINTED(rx);
2042 m = rx->startp[0] + orig;
2046 Move(s, d, i, char);
2050 Copy(c, d, clen, char);
2053 s = rx->endp[0] + orig;
2054 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2056 /* don't match same null twice */
2057 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2060 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2061 Move(s, d, i+1, char); /* include the NUL */
2063 TAINT_IF(rxtainted & 1);
2065 PUSHs(sv_2mortal(newSViv((I32)iters)));
2067 (void)SvPOK_only_UTF8(TARG);
2068 TAINT_IF(rxtainted);
2069 if (SvSMAGICAL(TARG)) {
2077 LEAVE_SCOPE(oldsave);
2081 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2082 r_flags | REXEC_CHECKED))
2084 if (force_on_match) {
2086 s = SvPV_force(TARG, len);
2089 rxtainted |= RX_MATCH_TAINTED(rx);
2090 dstr = NEWSV(25, len);
2091 sv_setpvn(dstr, m, s-m);
2096 register PERL_CONTEXT *cx;
2099 RETURNOP(cPMOP->op_pmreplroot);
2101 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2103 if (iters++ > maxiters)
2104 DIE(aTHX_ "Substitution loop");
2105 rxtainted |= RX_MATCH_TAINTED(rx);
2106 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2111 strend = s + (strend - m);
2113 m = rx->startp[0] + orig;
2114 sv_catpvn(dstr, s, m-s);
2115 s = rx->endp[0] + orig;
2117 sv_catpvn(dstr, c, clen);
2120 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2121 TARG, NULL, r_flags));
2122 if (doutf8 && !DO_UTF8(dstr)) {
2123 SV* nsv = sv_2mortal(newSVpvn(s, strend - s));
2125 sv_utf8_upgrade(nsv);
2126 sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv));
2129 sv_catpvn(dstr, s, strend - s);
2131 (void)SvOOK_off(TARG);
2133 Safefree(SvPVX(TARG));
2134 SvPVX(TARG) = SvPVX(dstr);
2135 SvCUR_set(TARG, SvCUR(dstr));
2136 SvLEN_set(TARG, SvLEN(dstr));
2137 doutf8 |= DO_UTF8(dstr);
2141 TAINT_IF(rxtainted & 1);
2143 PUSHs(sv_2mortal(newSViv((I32)iters)));
2145 (void)SvPOK_only(TARG);
2148 TAINT_IF(rxtainted);
2151 LEAVE_SCOPE(oldsave);
2160 LEAVE_SCOPE(oldsave);
2169 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2170 ++*PL_markstack_ptr;
2171 LEAVE; /* exit inner scope */
2174 if (PL_stack_base + *PL_markstack_ptr > SP) {
2176 I32 gimme = GIMME_V;
2178 LEAVE; /* exit outer scope */
2179 (void)POPMARK; /* pop src */
2180 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2181 (void)POPMARK; /* pop dst */
2182 SP = PL_stack_base + POPMARK; /* pop original mark */
2183 if (gimme == G_SCALAR) {
2187 else if (gimme == G_ARRAY)
2194 ENTER; /* enter inner scope */
2197 src = PL_stack_base[*PL_markstack_ptr];
2201 RETURNOP(cLOGOP->op_other);
2212 register PERL_CONTEXT *cx;
2218 if (gimme == G_SCALAR) {
2221 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2223 *MARK = SvREFCNT_inc(TOPs);
2228 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2230 *MARK = sv_mortalcopy(sv);
2235 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2239 *MARK = &PL_sv_undef;
2243 else if (gimme == G_ARRAY) {
2244 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2245 if (!SvTEMP(*MARK)) {
2246 *MARK = sv_mortalcopy(*MARK);
2247 TAINT_NOT; /* Each item is independent */
2253 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2254 PL_curpm = newpm; /* ... and pop $1 et al */
2258 return pop_return();
2261 /* This duplicates the above code because the above code must not
2262 * get any slower by more conditions */
2270 register PERL_CONTEXT *cx;
2277 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2278 /* We are an argument to a function or grep().
2279 * This kind of lvalueness was legal before lvalue
2280 * subroutines too, so be backward compatible:
2281 * cannot report errors. */
2283 /* Scalar context *is* possible, on the LHS of -> only,
2284 * as in f()->meth(). But this is not an lvalue. */
2285 if (gimme == G_SCALAR)
2287 if (gimme == G_ARRAY) {
2288 if (!CvLVALUE(cx->blk_sub.cv))
2289 goto temporise_array;
2290 EXTEND_MORTAL(SP - newsp);
2291 for (mark = newsp + 1; mark <= SP; mark++) {
2294 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2295 *mark = sv_mortalcopy(*mark);
2297 /* Can be a localized value subject to deletion. */
2298 PL_tmps_stack[++PL_tmps_ix] = *mark;
2299 (void)SvREFCNT_inc(*mark);
2304 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2305 /* Here we go for robustness, not for speed, so we change all
2306 * the refcounts so the caller gets a live guy. Cannot set
2307 * TEMP, so sv_2mortal is out of question. */
2308 if (!CvLVALUE(cx->blk_sub.cv)) {
2313 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2315 if (gimme == G_SCALAR) {
2319 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2324 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2325 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2326 : "a readonly value" : "a temporary");
2328 else { /* Can be a localized value
2329 * subject to deletion. */
2330 PL_tmps_stack[++PL_tmps_ix] = *mark;
2331 (void)SvREFCNT_inc(*mark);
2334 else { /* Should not happen? */
2339 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2340 (MARK > SP ? "Empty array" : "Array"));
2344 else if (gimme == G_ARRAY) {
2345 EXTEND_MORTAL(SP - newsp);
2346 for (mark = newsp + 1; mark <= SP; mark++) {
2347 if (*mark != &PL_sv_undef
2348 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2349 /* Might be flattened array after $#array = */
2355 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2356 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2359 /* Can be a localized value subject to deletion. */
2360 PL_tmps_stack[++PL_tmps_ix] = *mark;
2361 (void)SvREFCNT_inc(*mark);
2367 if (gimme == G_SCALAR) {
2371 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2373 *MARK = SvREFCNT_inc(TOPs);
2378 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2380 *MARK = sv_mortalcopy(sv);
2385 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2389 *MARK = &PL_sv_undef;
2393 else if (gimme == G_ARRAY) {
2395 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2396 if (!SvTEMP(*MARK)) {
2397 *MARK = sv_mortalcopy(*MARK);
2398 TAINT_NOT; /* Each item is independent */
2405 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2406 PL_curpm = newpm; /* ... and pop $1 et al */
2410 return pop_return();
2415 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2417 SV *dbsv = GvSV(PL_DBsub);
2419 if (!PERLDB_SUB_NN) {
2423 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2424 || strEQ(GvNAME(gv), "END")
2425 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2426 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2427 && (gv = (GV*)*svp) ))) {
2428 /* Use GV from the stack as a fallback. */
2429 /* GV is potentially non-unique, or contain different CV. */
2430 SV *tmp = newRV((SV*)cv);
2431 sv_setsv(dbsv, tmp);
2435 gv_efullname3(dbsv, gv, Nullch);
2439 (void)SvUPGRADE(dbsv, SVt_PVIV);
2440 (void)SvIOK_on(dbsv);
2441 SAVEIV(SvIVX(dbsv));
2442 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2446 PL_curcopdb = PL_curcop;
2447 cv = GvCV(PL_DBsub);
2457 register PERL_CONTEXT *cx;
2459 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2462 DIE(aTHX_ "Not a CODE reference");
2463 switch (SvTYPE(sv)) {
2464 /* This is overwhelming the most common case: */
2466 if (!(cv = GvCVu((GV*)sv)))
2467 cv = sv_2cv(sv, &stash, &gv, FALSE);
2479 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2481 SP = PL_stack_base + POPMARK;
2484 if (SvGMAGICAL(sv)) {
2488 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2491 sym = SvPV(sv, n_a);
2493 DIE(aTHX_ PL_no_usym, "a subroutine");
2494 if (PL_op->op_private & HINT_STRICT_REFS)
2495 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2496 cv = get_cv(sym, TRUE);
2501 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2502 tryAMAGICunDEREF(to_cv);
2505 if (SvTYPE(cv) == SVt_PVCV)
2510 DIE(aTHX_ "Not a CODE reference");
2511 /* This is the second most common case: */
2521 if (!CvROOT(cv) && !CvXSUB(cv)) {
2526 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2527 cv = get_db_sub(&sv, cv);
2529 DIE(aTHX_ "No DBsub routine");
2532 if (!(CvXSUB(cv))) {
2533 /* This path taken at least 75% of the time */
2535 register I32 items = SP - MARK;
2536 AV* padlist = CvPADLIST(cv);
2537 push_return(PL_op->op_next);
2538 PUSHBLOCK(cx, CXt_SUB, MARK);
2541 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2542 * that eval'' ops within this sub know the correct lexical space.
2543 * Owing the speed considerations, we choose instead to search for
2544 * the cv using find_runcv() when calling doeval().
2546 if (CvDEPTH(cv) < 2)
2547 (void)SvREFCNT_inc(cv);
2549 PERL_STACK_OVERFLOW_CHECK();
2550 pad_push(padlist, CvDEPTH(cv), 1);
2552 PAD_SET_CUR(padlist, CvDEPTH(cv));
2559 DEBUG_S(PerlIO_printf(Perl_debug_log,
2560 "%p entersub preparing @_\n", thr));
2562 av = (AV*)PAD_SVl(0);
2564 /* @_ is normally not REAL--this should only ever
2565 * happen when DB::sub() calls things that modify @_ */
2570 cx->blk_sub.savearray = GvAV(PL_defgv);
2571 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2572 CX_CURPAD_SAVE(cx->blk_sub);
2573 cx->blk_sub.argarray = av;
2576 if (items > AvMAX(av) + 1) {
2578 if (AvARRAY(av) != ary) {
2579 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2580 SvPVX(av) = (char*)ary;
2582 if (items > AvMAX(av) + 1) {
2583 AvMAX(av) = items - 1;
2584 Renew(ary,items,SV*);
2586 SvPVX(av) = (char*)ary;
2589 Copy(MARK,AvARRAY(av),items,SV*);
2590 AvFILLp(av) = items - 1;
2598 /* warning must come *after* we fully set up the context
2599 * stuff so that __WARN__ handlers can safely dounwind()
2602 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2603 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2604 sub_crush_depth(cv);
2606 DEBUG_S(PerlIO_printf(Perl_debug_log,
2607 "%p entersub returning %p\n", thr, CvSTART(cv)));
2609 RETURNOP(CvSTART(cv));
2612 #ifdef PERL_XSUB_OLDSTYLE
2613 if (CvOLDSTYLE(cv)) {
2614 I32 (*fp3)(int,int,int);
2616 register I32 items = SP - MARK;
2617 /* We dont worry to copy from @_. */
2622 PL_stack_sp = mark + 1;
2623 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2624 items = (*fp3)(CvXSUBANY(cv).any_i32,
2625 MARK - PL_stack_base + 1,
2627 PL_stack_sp = PL_stack_base + items;
2630 #endif /* PERL_XSUB_OLDSTYLE */
2632 I32 markix = TOPMARK;
2637 /* Need to copy @_ to stack. Alternative may be to
2638 * switch stack to @_, and copy return values
2639 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2642 av = GvAV(PL_defgv);
2643 items = AvFILLp(av) + 1; /* @_ is not tieable */
2646 /* Mark is at the end of the stack. */
2648 Copy(AvARRAY(av), SP + 1, items, SV*);
2653 /* We assume first XSUB in &DB::sub is the called one. */
2655 SAVEVPTR(PL_curcop);
2656 PL_curcop = PL_curcopdb;
2659 /* Do we need to open block here? XXXX */
2660 (void)(*CvXSUB(cv))(aTHX_ cv);
2662 /* Enforce some sanity in scalar context. */
2663 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2664 if (markix > PL_stack_sp - PL_stack_base)
2665 *(PL_stack_base + markix) = &PL_sv_undef;
2667 *(PL_stack_base + markix) = *PL_stack_sp;
2668 PL_stack_sp = PL_stack_base + markix;
2675 assert (0); /* Cannot get here. */
2676 /* This is deliberately moved here as spaghetti code to keep it out of the
2683 /* anonymous or undef'd function leaves us no recourse */
2684 if (CvANON(cv) || !(gv = CvGV(cv)))
2685 DIE(aTHX_ "Undefined subroutine called");
2687 /* autoloaded stub? */
2688 if (cv != GvCV(gv)) {
2691 /* should call AUTOLOAD now? */
2694 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2701 sub_name = sv_newmortal();
2702 gv_efullname3(sub_name, gv, Nullch);
2703 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2707 DIE(aTHX_ "Not a CODE reference");
2713 Perl_sub_crush_depth(pTHX_ CV *cv)
2716 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2718 SV* tmpstr = sv_newmortal();
2719 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2720 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2730 IV elem = SvIV(elemsv);
2732 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2733 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2736 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2737 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2739 elem -= PL_curcop->cop_arybase;
2740 if (SvTYPE(av) != SVt_PVAV)
2742 svp = av_fetch(av, elem, lval && !defer);
2744 if (!svp || *svp == &PL_sv_undef) {
2747 DIE(aTHX_ PL_no_aelem, elem);
2748 lv = sv_newmortal();
2749 sv_upgrade(lv, SVt_PVLV);
2751 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2752 LvTARG(lv) = SvREFCNT_inc(av);
2753 LvTARGOFF(lv) = elem;
2758 if (PL_op->op_private & OPpLVAL_INTRO)
2759 save_aelem(av, elem, svp);
2760 else if (PL_op->op_private & OPpDEREF)
2761 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2763 sv = (svp ? *svp : &PL_sv_undef);
2764 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2765 sv = sv_mortalcopy(sv);
2771 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2777 Perl_croak(aTHX_ PL_no_modify);
2778 if (SvTYPE(sv) < SVt_RV)
2779 sv_upgrade(sv, SVt_RV);
2780 else if (SvTYPE(sv) >= SVt_PV) {
2781 (void)SvOOK_off(sv);
2782 Safefree(SvPVX(sv));
2783 SvLEN(sv) = SvCUR(sv) = 0;
2787 SvRV(sv) = NEWSV(355,0);
2790 SvRV(sv) = (SV*)newAV();
2793 SvRV(sv) = (SV*)newHV();
2808 if (SvTYPE(rsv) == SVt_PVCV) {
2814 SETs(method_common(sv, Null(U32*)));
2821 SV* sv = cSVOP->op_sv;
2822 U32 hash = SvUVX(sv);
2824 XPUSHs(method_common(sv, &hash));
2829 S_method_common(pTHX_ SV* meth, U32* hashp)
2838 SV *packsv = Nullsv;
2841 name = SvPV(meth, namelen);
2842 sv = *(PL_stack_base + TOPMARK + 1);
2845 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2854 /* this isn't a reference */
2857 !(packname = SvPV(sv, packlen)) ||
2858 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2859 !(ob=(SV*)GvIO(iogv)))
2861 /* this isn't the name of a filehandle either */
2863 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2864 ? !isIDFIRST_utf8((U8*)packname)
2865 : !isIDFIRST(*packname)
2868 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2869 SvOK(sv) ? "without a package or object reference"
2870 : "on an undefined value");
2872 /* assume it's a package name */
2873 stash = gv_stashpvn(packname, packlen, FALSE);
2878 /* it _is_ a filehandle name -- replace with a reference */
2879 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2882 /* if we got here, ob should be a reference or a glob */
2883 if (!ob || !(SvOBJECT(ob)
2884 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2887 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2891 stash = SvSTASH(ob);
2894 /* NOTE: stash may be null, hope hv_fetch_ent and
2895 gv_fetchmethod can cope (it seems they can) */
2897 /* shortcut for simple names */
2899 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2901 gv = (GV*)HeVAL(he);
2902 if (isGV(gv) && GvCV(gv) &&
2903 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2904 return (SV*)GvCV(gv);
2908 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
2911 /* This code tries to figure out just what went wrong with
2912 gv_fetchmethod. It therefore needs to duplicate a lot of
2913 the internals of that function. We can't move it inside
2914 Perl_gv_fetchmethod_autoload(), however, since that would
2915 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
2922 for (p = name; *p; p++) {
2924 sep = p, leaf = p + 1;
2925 else if (*p == ':' && *(p + 1) == ':')
2926 sep = p, leaf = p + 2;
2928 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
2929 /* the method name is unqualified or starts with SUPER:: */
2930 packname = sep ? CopSTASHPV(PL_curcop) :
2931 stash ? HvNAME(stash) : packname;
2932 packlen = strlen(packname);
2935 /* the method name is qualified */
2937 packlen = sep - name;
2940 /* we're relying on gv_fetchmethod not autovivifying the stash */
2941 if (gv_stashpvn(packname, packlen, FALSE)) {
2943 "Can't locate object method \"%s\" via package \"%.*s\"",
2944 leaf, (int)packlen, packname);
2948 "Can't locate object method \"%s\" via package \"%.*s\""
2949 " (perhaps you forgot to load \"%.*s\"?)",
2950 leaf, (int)packlen, packname, (int)packlen, packname);
2953 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;