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
24 #ifdef USE_5005THREADS
25 static void unset_cvowner(pTHX_ void *cvarg);
26 #endif /* USE_5005THREADS */
37 PL_curcop = (COP*)PL_op;
38 TAINT_NOT; /* Each statement is presumed innocent */
39 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
48 if (PL_op->op_private & OPpLVAL_INTRO)
49 PUSHs(save_scalar(cGVOP_gv));
51 PUSHs(GvSV(cGVOP_gv));
62 PL_curcop = (COP*)PL_op;
68 PUSHMARK(PL_stack_sp);
83 XPUSHs((SV*)cGVOP_gv);
94 RETURNOP(cLOGOP->op_other);
102 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
104 temp = left; left = right; right = temp;
106 if (PL_tainting && PL_tainted && !SvTAINTED(left))
108 SvSetMagicSV(right, left);
117 RETURNOP(cLOGOP->op_other);
119 RETURNOP(cLOGOP->op_next);
125 TAINT_NOT; /* Each statement is presumed innocent */
126 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
128 oldsave = PL_scopestack[PL_scopestack_ix - 1];
129 LEAVE_SCOPE(oldsave);
135 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
142 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
143 bool rbyte = !SvUTF8(right);
145 if (TARG == right && right != left) {
146 right = sv_2mortal(newSVpvn(rpv, rlen));
147 rpv = SvPV(right, rlen); /* no point setting UTF8 here */
151 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
152 lbyte = !SvUTF8(left);
153 sv_setpvn(TARG, lpv, llen);
159 else { /* TARG == left */
160 if (SvGMAGICAL(left))
161 mg_get(left); /* or mg_get(left) may happen here */
164 lpv = SvPV_nomg(left, llen);
165 lbyte = !SvUTF8(left);
168 #if defined(PERL_Y2KWARN)
169 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
170 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
171 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
173 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
174 "about to append an integer to '19'");
179 if (lbyte != rbyte) {
181 sv_utf8_upgrade_nomg(TARG);
183 sv_utf8_upgrade_nomg(right);
184 rpv = SvPV(right, rlen);
187 sv_catpvn_nomg(TARG, rpv, rlen);
198 if (PL_op->op_flags & OPf_MOD) {
199 if (PL_op->op_private & OPpLVAL_INTRO)
200 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
201 else if (PL_op->op_private & OPpDEREF) {
203 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
212 tryAMAGICunTARGET(iter, 0);
213 PL_last_in_gv = (GV*)(*PL_stack_sp--);
214 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
215 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
216 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
219 XPUSHs((SV*)PL_last_in_gv);
222 PL_last_in_gv = (GV*)(*PL_stack_sp--);
225 return do_readline();
230 dSP; tryAMAGICbinSET(eq,0);
231 #ifndef NV_PRESERVES_UV
232 if (SvROK(TOPs) && SvROK(TOPm1s)) {
234 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
238 #ifdef PERL_PRESERVE_IVUV
241 /* Unless the left argument is integer in range we are going
242 to have to use NV maths. Hence only attempt to coerce the
243 right argument if we know the left is integer. */
246 bool auvok = SvUOK(TOPm1s);
247 bool buvok = SvUOK(TOPs);
249 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
250 /* Casting IV to UV before comparison isn't going to matter
251 on 2s complement. On 1s complement or sign&magnitude
252 (if we have any of them) it could to make negative zero
253 differ from normal zero. As I understand it. (Need to
254 check - is negative zero implementation defined behaviour
256 UV buv = SvUVX(POPs);
257 UV auv = SvUVX(TOPs);
259 SETs(boolSV(auv == buv));
262 { /* ## Mixed IV,UV ## */
266 /* == is commutative so doesn't matter which is left or right */
268 /* top of stack (b) is the iv */
277 /* As uv is a UV, it's >0, so it cannot be == */
281 /* we know iv is >= 0 */
282 SETs(boolSV((UV)iv == SvUVX(uvp)));
290 SETs(boolSV(TOPn == value));
298 if (SvTYPE(TOPs) > SVt_PVLV)
299 DIE(aTHX_ PL_no_modify);
300 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
301 && SvIVX(TOPs) != IV_MAX)
304 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
306 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
319 RETURNOP(cLOGOP->op_other);
325 /* Most of this is lifted straight from pp_defined */
330 if (!sv || !SvANY(sv)) {
332 RETURNOP(cLOGOP->op_other);
335 switch (SvTYPE(sv)) {
337 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
341 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
345 if (CvROOT(sv) || CvXSUB(sv))
356 RETURNOP(cLOGOP->op_other);
361 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
362 useleft = USE_LEFT(TOPm1s);
363 #ifdef PERL_PRESERVE_IVUV
364 /* We must see if we can perform the addition with integers if possible,
365 as the integer code detects overflow while the NV code doesn't.
366 If either argument hasn't had a numeric conversion yet attempt to get
367 the IV. It's important to do this now, rather than just assuming that
368 it's not IOK as a PV of "9223372036854775806" may not take well to NV
369 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
370 integer in case the second argument is IV=9223372036854775806
371 We can (now) rely on sv_2iv to do the right thing, only setting the
372 public IOK flag if the value in the NV (or PV) slot is truly integer.
374 A side effect is that this also aggressively prefers integer maths over
375 fp maths for integer values.
377 How to detect overflow?
379 C 99 section 6.2.6.1 says
381 The range of nonnegative values of a signed integer type is a subrange
382 of the corresponding unsigned integer type, and the representation of
383 the same value in each type is the same. A computation involving
384 unsigned operands can never overflow, because a result that cannot be
385 represented by the resulting unsigned integer type is reduced modulo
386 the number that is one greater than the largest value that can be
387 represented by the resulting type.
391 which I read as "unsigned ints wrap."
393 signed integer overflow seems to be classed as "exception condition"
395 If an exceptional condition occurs during the evaluation of an
396 expression (that is, if the result is not mathematically defined or not
397 in the range of representable values for its type), the behavior is
400 (6.5, the 5th paragraph)
402 I had assumed that on 2s complement machines signed arithmetic would
403 wrap, hence coded pp_add and pp_subtract on the assumption that
404 everything perl builds on would be happy. After much wailing and
405 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
406 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
407 unsigned code below is actually shorter than the old code. :-)
412 /* Unless the left argument is integer in range we are going to have to
413 use NV maths. Hence only attempt to coerce the right argument if
414 we know the left is integer. */
422 /* left operand is undef, treat as zero. + 0 is identity,
423 Could SETi or SETu right now, but space optimise by not adding
424 lots of code to speed up what is probably a rarish case. */
426 /* Left operand is defined, so is it IV? */
429 if ((auvok = SvUOK(TOPm1s)))
432 register IV aiv = SvIVX(TOPm1s);
435 auvok = 1; /* Now acting as a sign flag. */
436 } else { /* 2s complement assumption for IV_MIN */
444 bool result_good = 0;
447 bool buvok = SvUOK(TOPs);
452 register IV biv = SvIVX(TOPs);
459 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
460 else "IV" now, independent of how it came in.
461 if a, b represents positive, A, B negative, a maps to -A etc
466 all UV maths. negate result if A negative.
467 add if signs same, subtract if signs differ. */
473 /* Must get smaller */
479 /* result really should be -(auv-buv). as its negation
480 of true value, need to swap our result flag */
497 if (result <= (UV)IV_MIN)
500 /* result valid, but out of range for IV. */
505 } /* Overflow, drop through to NVs. */
512 /* left operand is undef, treat as zero. + 0.0 is identity. */
516 SETn( value + TOPn );
524 AV *av = GvAV(cGVOP_gv);
525 U32 lval = PL_op->op_flags & OPf_MOD;
526 SV** svp = av_fetch(av, PL_op->op_private, lval);
527 SV *sv = (svp ? *svp : &PL_sv_undef);
529 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
530 sv = sv_mortalcopy(sv);
539 do_join(TARG, *MARK, MARK, SP);
550 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
551 * will be enough to hold an OP*.
553 SV* sv = sv_newmortal();
554 sv_upgrade(sv, SVt_PVLV);
556 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
564 /* Oversized hot code. */
568 dSP; dMARK; dORIGMARK;
574 if (PL_op->op_flags & OPf_STACKED)
579 if (gv && (io = GvIO(gv))
580 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
583 if (MARK == ORIGMARK) {
584 /* If using default handle then we need to make space to
585 * pass object as 1st arg, so move other args up ...
589 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
593 *MARK = SvTIED_obj((SV*)io, mg);
596 call_method("PRINT", G_SCALAR);
604 if (!(io = GvIO(gv))) {
605 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
606 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
608 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
609 report_evil_fh(gv, io, PL_op->op_type);
610 SETERRNO(EBADF,RMS$_IFI);
613 else if (!(fp = IoOFP(io))) {
614 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
616 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
617 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
618 report_evil_fh(gv, io, PL_op->op_type);
620 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
625 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
627 if (!do_print(*MARK, fp))
631 if (!do_print(PL_ofs_sv, fp)) { /* $, */
640 if (!do_print(*MARK, fp))
648 if (PL_ors_sv && SvOK(PL_ors_sv))
649 if (!do_print(PL_ors_sv, fp)) /* $\ */
652 if (IoFLAGS(io) & IOf_FLUSH)
653 if (PerlIO_flush(fp) == EOF)
674 tryAMAGICunDEREF(to_av);
677 if (SvTYPE(av) != SVt_PVAV)
678 DIE(aTHX_ "Not an ARRAY reference");
679 if (PL_op->op_flags & OPf_REF) {
684 if (GIMME == G_SCALAR)
685 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
691 if (SvTYPE(sv) == SVt_PVAV) {
693 if (PL_op->op_flags & OPf_REF) {
698 if (GIMME == G_SCALAR)
699 Perl_croak(aTHX_ "Can't return array to lvalue"
708 if (SvTYPE(sv) != SVt_PVGV) {
712 if (SvGMAGICAL(sv)) {
718 if (PL_op->op_flags & OPf_REF ||
719 PL_op->op_private & HINT_STRICT_REFS)
720 DIE(aTHX_ PL_no_usym, "an ARRAY");
721 if (ckWARN(WARN_UNINITIALIZED))
723 if (GIMME == G_ARRAY) {
730 if ((PL_op->op_flags & OPf_SPECIAL) &&
731 !(PL_op->op_flags & OPf_MOD))
733 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
735 && (!is_gv_magical(sym,len,0)
736 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
742 if (PL_op->op_private & HINT_STRICT_REFS)
743 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
744 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
751 if (PL_op->op_private & OPpLVAL_INTRO)
753 if (PL_op->op_flags & OPf_REF) {
758 if (GIMME == G_SCALAR)
759 Perl_croak(aTHX_ "Can't return array to lvalue"
767 if (GIMME == G_ARRAY) {
768 I32 maxarg = AvFILL(av) + 1;
769 (void)POPs; /* XXXX May be optimized away? */
771 if (SvRMAGICAL(av)) {
773 for (i=0; i < (U32)maxarg; i++) {
774 SV **svp = av_fetch(av, i, FALSE);
775 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
779 Copy(AvARRAY(av), SP+1, maxarg, SV*);
785 I32 maxarg = AvFILL(av) + 1;
798 tryAMAGICunDEREF(to_hv);
801 if (SvTYPE(hv) != SVt_PVHV)
802 DIE(aTHX_ "Not a HASH reference");
803 if (PL_op->op_flags & OPf_REF) {
808 if (GIMME == G_SCALAR)
809 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
815 if (SvTYPE(sv) == SVt_PVHV) {
817 if (PL_op->op_flags & OPf_REF) {
822 if (GIMME == G_SCALAR)
823 Perl_croak(aTHX_ "Can't return hash to lvalue"
832 if (SvTYPE(sv) != SVt_PVGV) {
836 if (SvGMAGICAL(sv)) {
842 if (PL_op->op_flags & OPf_REF ||
843 PL_op->op_private & HINT_STRICT_REFS)
844 DIE(aTHX_ PL_no_usym, "a HASH");
845 if (ckWARN(WARN_UNINITIALIZED))
847 if (GIMME == G_ARRAY) {
854 if ((PL_op->op_flags & OPf_SPECIAL) &&
855 !(PL_op->op_flags & OPf_MOD))
857 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
859 && (!is_gv_magical(sym,len,0)
860 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
866 if (PL_op->op_private & HINT_STRICT_REFS)
867 DIE(aTHX_ PL_no_symref, sym, "a HASH");
868 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
875 if (PL_op->op_private & OPpLVAL_INTRO)
877 if (PL_op->op_flags & OPf_REF) {
882 if (GIMME == G_SCALAR)
883 Perl_croak(aTHX_ "Can't return hash to lvalue"
891 if (GIMME == G_ARRAY) { /* array wanted */
892 *PL_stack_sp = (SV*)hv;
898 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
899 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
909 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
915 if (ckWARN(WARN_MISC)) {
916 if (relem == firstrelem &&
918 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
919 SvTYPE(SvRV(*relem)) == SVt_PVHV))
921 Perl_warner(aTHX_ packWARN(WARN_MISC),
922 "Reference found where even-sized list expected");
925 Perl_warner(aTHX_ packWARN(WARN_MISC),
926 "Odd number of elements in hash assignment");
929 tmpstr = NEWSV(29,0);
930 didstore = hv_store_ent(hash,*relem,tmpstr,0);
931 if (SvMAGICAL(hash)) {
932 if (SvSMAGICAL(tmpstr))
944 SV **lastlelem = PL_stack_sp;
945 SV **lastrelem = PL_stack_base + POPMARK;
946 SV **firstrelem = PL_stack_base + POPMARK + 1;
947 SV **firstlelem = lastrelem + 1;
960 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
962 /* If there's a common identifier on both sides we have to take
963 * special care that assigning the identifier on the left doesn't
964 * clobber a value on the right that's used later in the list.
966 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
967 EXTEND_MORTAL(lastrelem - firstrelem + 1);
968 for (relem = firstrelem; relem <= lastrelem; relem++) {
971 TAINT_NOT; /* Each item is independent */
972 *relem = sv_mortalcopy(sv);
982 while (lelem <= lastlelem) {
983 TAINT_NOT; /* Each item stands on its own, taintwise. */
985 switch (SvTYPE(sv)) {
988 magic = SvMAGICAL(ary) != 0;
990 av_extend(ary, lastrelem - relem);
992 while (relem <= lastrelem) { /* gobble up all the rest */
998 didstore = av_store(ary,i++,sv);
1008 case SVt_PVHV: { /* normal hash */
1012 magic = SvMAGICAL(hash) != 0;
1015 while (relem < lastrelem) { /* gobble up all the rest */
1020 sv = &PL_sv_no, relem++;
1021 tmpstr = NEWSV(29,0);
1023 sv_setsv(tmpstr,*relem); /* value */
1024 *(relem++) = tmpstr;
1025 didstore = hv_store_ent(hash,sv,tmpstr,0);
1027 if (SvSMAGICAL(tmpstr))
1034 if (relem == lastrelem) {
1035 do_oddball(hash, relem, firstrelem);
1041 if (SvIMMORTAL(sv)) {
1042 if (relem <= lastrelem)
1046 if (relem <= lastrelem) {
1047 sv_setsv(sv, *relem);
1051 sv_setsv(sv, &PL_sv_undef);
1056 if (PL_delaymagic & ~DM_DELAY) {
1057 if (PL_delaymagic & DM_UID) {
1058 #ifdef HAS_SETRESUID
1059 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1061 # ifdef HAS_SETREUID
1062 (void)setreuid(PL_uid,PL_euid);
1065 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1066 (void)setruid(PL_uid);
1067 PL_delaymagic &= ~DM_RUID;
1069 # endif /* HAS_SETRUID */
1071 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1072 (void)seteuid(PL_uid);
1073 PL_delaymagic &= ~DM_EUID;
1075 # endif /* HAS_SETEUID */
1076 if (PL_delaymagic & DM_UID) {
1077 if (PL_uid != PL_euid)
1078 DIE(aTHX_ "No setreuid available");
1079 (void)PerlProc_setuid(PL_uid);
1081 # endif /* HAS_SETREUID */
1082 #endif /* HAS_SETRESUID */
1083 PL_uid = PerlProc_getuid();
1084 PL_euid = PerlProc_geteuid();
1086 if (PL_delaymagic & DM_GID) {
1087 #ifdef HAS_SETRESGID
1088 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1090 # ifdef HAS_SETREGID
1091 (void)setregid(PL_gid,PL_egid);
1094 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1095 (void)setrgid(PL_gid);
1096 PL_delaymagic &= ~DM_RGID;
1098 # endif /* HAS_SETRGID */
1100 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1101 (void)setegid(PL_gid);
1102 PL_delaymagic &= ~DM_EGID;
1104 # endif /* HAS_SETEGID */
1105 if (PL_delaymagic & DM_GID) {
1106 if (PL_gid != PL_egid)
1107 DIE(aTHX_ "No setregid available");
1108 (void)PerlProc_setgid(PL_gid);
1110 # endif /* HAS_SETREGID */
1111 #endif /* HAS_SETRESGID */
1112 PL_gid = PerlProc_getgid();
1113 PL_egid = PerlProc_getegid();
1115 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1120 if (gimme == G_VOID)
1121 SP = firstrelem - 1;
1122 else if (gimme == G_SCALAR) {
1125 SETi(lastrelem - firstrelem + 1);
1131 SP = firstrelem + (lastlelem - firstlelem);
1132 lelem = firstlelem + (relem - firstrelem);
1134 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1142 register PMOP *pm = cPMOP;
1143 SV *rv = sv_newmortal();
1144 SV *sv = newSVrv(rv, "Regexp");
1145 if (pm->op_pmdynflags & PMdf_TAINTED)
1147 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1154 register PMOP *pm = cPMOP;
1160 I32 r_flags = REXEC_CHECKED;
1161 char *truebase; /* Start of string */
1162 register REGEXP *rx = PM_GETRE(pm);
1167 I32 oldsave = PL_savestack_ix;
1168 I32 update_minmatch = 1;
1169 I32 had_zerolen = 0;
1171 if (PL_op->op_flags & OPf_STACKED)
1178 PUTBACK; /* EVAL blocks need stack_sp. */
1179 s = SvPV(TARG, len);
1182 DIE(aTHX_ "panic: pp_match");
1183 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1184 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1187 PL_reg_match_utf8 = DO_UTF8(TARG);
1189 /* PMdf_USED is set after a ?? matches once */
1190 if (pm->op_pmdynflags & PMdf_USED) {
1192 if (gimme == G_ARRAY)
1197 /* empty pattern special-cased to use last successful pattern if possible */
1198 if (!rx->prelen && PL_curpm) {
1203 if (rx->minlen > (I32)len)
1208 /* XXXX What part of this is needed with true \G-support? */
1209 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1211 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1212 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1213 if (mg && mg->mg_len >= 0) {
1214 if (!(rx->reganch & ROPT_GPOS_SEEN))
1215 rx->endp[0] = rx->startp[0] = mg->mg_len;
1216 else if (rx->reganch & ROPT_ANCH_GPOS) {
1217 r_flags |= REXEC_IGNOREPOS;
1218 rx->endp[0] = rx->startp[0] = mg->mg_len;
1220 minmatch = (mg->mg_flags & MGf_MINMATCH);
1221 update_minmatch = 0;
1225 if ((!global && rx->nparens)
1226 || SvTEMP(TARG) || PL_sawampersand)
1227 r_flags |= REXEC_COPY_STR;
1229 r_flags |= REXEC_SCREAM;
1231 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1232 SAVEINT(PL_multiline);
1233 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1237 if (global && rx->startp[0] != -1) {
1238 t = s = rx->endp[0] + truebase;
1239 if ((s + rx->minlen) > strend)
1241 if (update_minmatch++)
1242 minmatch = had_zerolen;
1244 if (rx->reganch & RE_USE_INTUIT &&
1245 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1246 PL_bostr = truebase;
1247 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1251 if ( (rx->reganch & ROPT_CHECK_ALL)
1253 && ((rx->reganch & ROPT_NOSCAN)
1254 || !((rx->reganch & RE_INTUIT_TAIL)
1255 && (r_flags & REXEC_SCREAM)))
1256 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1259 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1262 if (dynpm->op_pmflags & PMf_ONCE)
1263 dynpm->op_pmdynflags |= PMdf_USED;
1272 RX_MATCH_TAINTED_on(rx);
1273 TAINT_IF(RX_MATCH_TAINTED(rx));
1274 if (gimme == G_ARRAY) {
1275 I32 nparens, i, len;
1277 nparens = rx->nparens;
1278 if (global && !nparens)
1282 SPAGAIN; /* EVAL blocks could move the stack. */
1283 EXTEND(SP, nparens + i);
1284 EXTEND_MORTAL(nparens + i);
1285 for (i = !i; i <= nparens; i++) {
1286 PUSHs(sv_newmortal());
1288 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1289 len = rx->endp[i] - rx->startp[i];
1290 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1291 len < 0 || len > strend - s)
1292 DIE(aTHX_ "panic: pp_match start/end pointers");
1293 s = rx->startp[i] + truebase;
1294 sv_setpvn(*SP, s, len);
1295 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1300 if (dynpm->op_pmflags & PMf_CONTINUE) {
1302 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1303 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1305 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1306 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1308 if (rx->startp[0] != -1) {
1309 mg->mg_len = rx->endp[0];
1310 if (rx->startp[0] == rx->endp[0])
1311 mg->mg_flags |= MGf_MINMATCH;
1313 mg->mg_flags &= ~MGf_MINMATCH;
1316 had_zerolen = (rx->startp[0] != -1
1317 && rx->startp[0] == rx->endp[0]);
1318 PUTBACK; /* EVAL blocks may use stack */
1319 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1324 LEAVE_SCOPE(oldsave);
1330 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1331 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1333 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1334 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1336 if (rx->startp[0] != -1) {
1337 mg->mg_len = rx->endp[0];
1338 if (rx->startp[0] == rx->endp[0])
1339 mg->mg_flags |= MGf_MINMATCH;
1341 mg->mg_flags &= ~MGf_MINMATCH;
1344 LEAVE_SCOPE(oldsave);
1348 yup: /* Confirmed by INTUIT */
1350 RX_MATCH_TAINTED_on(rx);
1351 TAINT_IF(RX_MATCH_TAINTED(rx));
1353 if (dynpm->op_pmflags & PMf_ONCE)
1354 dynpm->op_pmdynflags |= PMdf_USED;
1355 if (RX_MATCH_COPIED(rx))
1356 Safefree(rx->subbeg);
1357 RX_MATCH_COPIED_off(rx);
1358 rx->subbeg = Nullch;
1360 rx->subbeg = truebase;
1361 rx->startp[0] = s - truebase;
1362 if (PL_reg_match_utf8) {
1363 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1364 rx->endp[0] = t - truebase;
1367 rx->endp[0] = s - truebase + rx->minlen;
1369 rx->sublen = strend - truebase;
1372 if (PL_sawampersand) {
1375 rx->subbeg = savepvn(t, strend - t);
1376 rx->sublen = strend - t;
1377 RX_MATCH_COPIED_on(rx);
1378 off = rx->startp[0] = s - t;
1379 rx->endp[0] = off + rx->minlen;
1381 else { /* startp/endp are used by @- @+. */
1382 rx->startp[0] = s - truebase;
1383 rx->endp[0] = s - truebase + rx->minlen;
1385 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1386 LEAVE_SCOPE(oldsave);
1391 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1392 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1393 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1398 LEAVE_SCOPE(oldsave);
1399 if (gimme == G_ARRAY)
1405 Perl_do_readline(pTHX)
1407 dSP; dTARGETSTACKED;
1412 register IO *io = GvIO(PL_last_in_gv);
1413 register I32 type = PL_op->op_type;
1414 I32 gimme = GIMME_V;
1417 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1419 XPUSHs(SvTIED_obj((SV*)io, mg));
1422 call_method("READLINE", gimme);
1425 if (gimme == G_SCALAR) {
1427 SvSetSV_nosteal(TARG, result);
1436 if (IoFLAGS(io) & IOf_ARGV) {
1437 if (IoFLAGS(io) & IOf_START) {
1439 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1440 IoFLAGS(io) &= ~IOf_START;
1441 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1442 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1443 SvSETMAGIC(GvSV(PL_last_in_gv));
1448 fp = nextargv(PL_last_in_gv);
1449 if (!fp) { /* Note: fp != IoIFP(io) */
1450 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1453 else if (type == OP_GLOB)
1454 fp = Perl_start_glob(aTHX_ POPs, io);
1456 else if (type == OP_GLOB)
1458 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1459 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1463 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1464 && (!io || !(IoFLAGS(io) & IOf_START))) {
1465 if (type == OP_GLOB)
1466 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1467 "glob failed (can't start child: %s)",
1470 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1472 if (gimme == G_SCALAR) {
1473 (void)SvOK_off(TARG);
1479 if (gimme == G_SCALAR) {
1483 (void)SvUPGRADE(sv, SVt_PV);
1484 tmplen = SvLEN(sv); /* remember if already alloced */
1486 Sv_Grow(sv, 80); /* try short-buffering it */
1487 if (type == OP_RCATLINE)
1493 sv = sv_2mortal(NEWSV(57, 80));
1497 /* This should not be marked tainted if the fp is marked clean */
1498 #define MAYBE_TAINT_LINE(io, sv) \
1499 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1504 /* delay EOF state for a snarfed empty file */
1505 #define SNARF_EOF(gimme,rs,io,sv) \
1506 (gimme != G_SCALAR || SvCUR(sv) \
1507 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1511 if (!sv_gets(sv, fp, offset)
1512 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1514 PerlIO_clearerr(fp);
1515 if (IoFLAGS(io) & IOf_ARGV) {
1516 fp = nextargv(PL_last_in_gv);
1519 (void)do_close(PL_last_in_gv, FALSE);
1521 else if (type == OP_GLOB) {
1522 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1523 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1524 "glob failed (child exited with status %d%s)",
1525 (int)(STATUS_CURRENT >> 8),
1526 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1529 if (gimme == G_SCALAR) {
1530 (void)SvOK_off(TARG);
1534 MAYBE_TAINT_LINE(io, sv);
1537 MAYBE_TAINT_LINE(io, sv);
1539 IoFLAGS(io) |= IOf_NOLINE;
1543 if (type == OP_GLOB) {
1546 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1547 tmps = SvEND(sv) - 1;
1548 if (*tmps == *SvPVX(PL_rs)) {
1553 for (tmps = SvPVX(sv); *tmps; tmps++)
1554 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1555 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1557 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1558 (void)POPs; /* Unmatched wildcard? Chuck it... */
1562 if (gimme == G_ARRAY) {
1563 if (SvLEN(sv) - SvCUR(sv) > 20) {
1564 SvLEN_set(sv, SvCUR(sv)+1);
1565 Renew(SvPVX(sv), SvLEN(sv), char);
1567 sv = sv_2mortal(NEWSV(58, 80));
1570 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1571 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1575 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1576 Renew(SvPVX(sv), SvLEN(sv), char);
1585 register PERL_CONTEXT *cx;
1586 I32 gimme = OP_GIMME(PL_op, -1);
1589 if (cxstack_ix >= 0)
1590 gimme = cxstack[cxstack_ix].blk_gimme;
1598 PUSHBLOCK(cx, CXt_BLOCK, SP);
1610 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1611 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1613 #ifdef PERL_COPY_ON_WRITE
1614 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1616 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1620 if (SvTYPE(hv) == SVt_PVHV) {
1621 if (PL_op->op_private & OPpLVAL_INTRO) {
1624 /* does the element we're localizing already exist? */
1626 /* can we determine whether it exists? */
1628 || mg_find((SV*)hv, PERL_MAGIC_env)
1629 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1630 /* Try to preserve the existenceness of a tied hash
1631 * element by using EXISTS and DELETE if possible.
1632 * Fallback to FETCH and STORE otherwise */
1633 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1634 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1635 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1637 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1640 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1641 svp = he ? &HeVAL(he) : 0;
1647 if (!svp || *svp == &PL_sv_undef) {
1652 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1654 lv = sv_newmortal();
1655 sv_upgrade(lv, SVt_PVLV);
1657 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1658 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1659 LvTARG(lv) = SvREFCNT_inc(hv);
1664 if (PL_op->op_private & OPpLVAL_INTRO) {
1665 if (HvNAME(hv) && isGV(*svp))
1666 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1670 char *key = SvPV(keysv, keylen);
1671 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1673 save_helem(hv, keysv, svp);
1676 else if (PL_op->op_private & OPpDEREF)
1677 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1679 sv = (svp ? *svp : &PL_sv_undef);
1680 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1681 * Pushing the magical RHS on to the stack is useless, since
1682 * that magic is soon destined to be misled by the local(),
1683 * and thus the later pp_sassign() will fail to mg_get() the
1684 * old value. This should also cure problems with delayed
1685 * mg_get()s. GSAR 98-07-03 */
1686 if (!lval && SvGMAGICAL(sv))
1687 sv = sv_mortalcopy(sv);
1695 register PERL_CONTEXT *cx;
1701 if (PL_op->op_flags & OPf_SPECIAL) {
1702 cx = &cxstack[cxstack_ix];
1703 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1708 gimme = OP_GIMME(PL_op, -1);
1710 if (cxstack_ix >= 0)
1711 gimme = cxstack[cxstack_ix].blk_gimme;
1717 if (gimme == G_VOID)
1719 else if (gimme == G_SCALAR) {
1722 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1725 *MARK = sv_mortalcopy(TOPs);
1728 *MARK = &PL_sv_undef;
1732 else if (gimme == G_ARRAY) {
1733 /* in case LEAVE wipes old return values */
1734 for (mark = newsp + 1; mark <= SP; mark++) {
1735 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1736 *mark = sv_mortalcopy(*mark);
1737 TAINT_NOT; /* Each item is independent */
1741 PL_curpm = newpm; /* Don't pop $1 et al till now */
1751 register PERL_CONTEXT *cx;
1757 cx = &cxstack[cxstack_ix];
1758 if (CxTYPE(cx) != CXt_LOOP)
1759 DIE(aTHX_ "panic: pp_iter");
1761 itersvp = CxITERVAR(cx);
1762 av = cx->blk_loop.iterary;
1763 if (SvTYPE(av) != SVt_PVAV) {
1764 /* iterate ($min .. $max) */
1765 if (cx->blk_loop.iterlval) {
1766 /* string increment */
1767 register SV* cur = cx->blk_loop.iterlval;
1769 char *max = SvPV((SV*)av, maxlen);
1770 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1771 #ifndef USE_5005THREADS /* don't risk potential race */
1772 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1773 /* safe to reuse old SV */
1774 sv_setsv(*itersvp, cur);
1779 /* we need a fresh SV every time so that loop body sees a
1780 * completely new SV for closures/references to work as
1782 SvREFCNT_dec(*itersvp);
1783 *itersvp = newSVsv(cur);
1785 if (strEQ(SvPVX(cur), max))
1786 sv_setiv(cur, 0); /* terminate next time */
1793 /* integer increment */
1794 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1797 #ifndef USE_5005THREADS /* don't risk potential race */
1798 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1799 /* safe to reuse old SV */
1800 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 PL_reg_match_utf8 = DO_UTF8(TARG);
1914 DIE(aTHX_ "panic: pp_subst");
1917 slen = PL_reg_match_utf8 ? 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);
2132 Safefree(SvPVX(TARG));
2133 SvPVX(TARG) = SvPVX(dstr);
2134 SvCUR_set(TARG, SvCUR(dstr));
2135 SvLEN_set(TARG, SvLEN(dstr));
2136 doutf8 |= DO_UTF8(dstr);
2140 TAINT_IF(rxtainted & 1);
2142 PUSHs(sv_2mortal(newSViv((I32)iters)));
2144 (void)SvPOK_only(TARG);
2147 TAINT_IF(rxtainted);
2150 LEAVE_SCOPE(oldsave);
2159 LEAVE_SCOPE(oldsave);
2168 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2169 ++*PL_markstack_ptr;
2170 LEAVE; /* exit inner scope */
2173 if (PL_stack_base + *PL_markstack_ptr > SP) {
2175 I32 gimme = GIMME_V;
2177 LEAVE; /* exit outer scope */
2178 (void)POPMARK; /* pop src */
2179 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2180 (void)POPMARK; /* pop dst */
2181 SP = PL_stack_base + POPMARK; /* pop original mark */
2182 if (gimme == G_SCALAR) {
2186 else if (gimme == G_ARRAY)
2193 ENTER; /* enter inner scope */
2196 src = PL_stack_base[*PL_markstack_ptr];
2200 RETURNOP(cLOGOP->op_other);
2211 register PERL_CONTEXT *cx;
2217 if (gimme == G_SCALAR) {
2220 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2222 *MARK = SvREFCNT_inc(TOPs);
2227 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2229 *MARK = sv_mortalcopy(sv);
2234 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2238 *MARK = &PL_sv_undef;
2242 else if (gimme == G_ARRAY) {
2243 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2244 if (!SvTEMP(*MARK)) {
2245 *MARK = sv_mortalcopy(*MARK);
2246 TAINT_NOT; /* Each item is independent */
2252 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2253 PL_curpm = newpm; /* ... and pop $1 et al */
2257 return pop_return();
2260 /* This duplicates the above code because the above code must not
2261 * get any slower by more conditions */
2269 register PERL_CONTEXT *cx;
2276 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2277 /* We are an argument to a function or grep().
2278 * This kind of lvalueness was legal before lvalue
2279 * subroutines too, so be backward compatible:
2280 * cannot report errors. */
2282 /* Scalar context *is* possible, on the LHS of -> only,
2283 * as in f()->meth(). But this is not an lvalue. */
2284 if (gimme == G_SCALAR)
2286 if (gimme == G_ARRAY) {
2287 if (!CvLVALUE(cx->blk_sub.cv))
2288 goto temporise_array;
2289 EXTEND_MORTAL(SP - newsp);
2290 for (mark = newsp + 1; mark <= SP; mark++) {
2293 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2294 *mark = sv_mortalcopy(*mark);
2296 /* Can be a localized value subject to deletion. */
2297 PL_tmps_stack[++PL_tmps_ix] = *mark;
2298 (void)SvREFCNT_inc(*mark);
2303 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2304 /* Here we go for robustness, not for speed, so we change all
2305 * the refcounts so the caller gets a live guy. Cannot set
2306 * TEMP, so sv_2mortal is out of question. */
2307 if (!CvLVALUE(cx->blk_sub.cv)) {
2312 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2314 if (gimme == G_SCALAR) {
2318 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2323 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2324 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2326 else { /* Can be a localized value
2327 * subject to deletion. */
2328 PL_tmps_stack[++PL_tmps_ix] = *mark;
2329 (void)SvREFCNT_inc(*mark);
2332 else { /* Should not happen? */
2337 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2338 (MARK > SP ? "Empty array" : "Array"));
2342 else if (gimme == G_ARRAY) {
2343 EXTEND_MORTAL(SP - newsp);
2344 for (mark = newsp + 1; mark <= SP; mark++) {
2345 if (*mark != &PL_sv_undef
2346 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2347 /* Might be flattened array after $#array = */
2353 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2354 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2357 /* Can be a localized value subject to deletion. */
2358 PL_tmps_stack[++PL_tmps_ix] = *mark;
2359 (void)SvREFCNT_inc(*mark);
2365 if (gimme == G_SCALAR) {
2369 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2371 *MARK = SvREFCNT_inc(TOPs);
2376 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2378 *MARK = sv_mortalcopy(sv);
2383 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2387 *MARK = &PL_sv_undef;
2391 else if (gimme == G_ARRAY) {
2393 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2394 if (!SvTEMP(*MARK)) {
2395 *MARK = sv_mortalcopy(*MARK);
2396 TAINT_NOT; /* Each item is independent */
2403 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2404 PL_curpm = newpm; /* ... and pop $1 et al */
2408 return pop_return();
2413 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2415 SV *dbsv = GvSV(PL_DBsub);
2417 if (!PERLDB_SUB_NN) {
2421 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2422 || strEQ(GvNAME(gv), "END")
2423 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2424 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2425 && (gv = (GV*)*svp) ))) {
2426 /* Use GV from the stack as a fallback. */
2427 /* GV is potentially non-unique, or contain different CV. */
2428 SV *tmp = newRV((SV*)cv);
2429 sv_setsv(dbsv, tmp);
2433 gv_efullname3(dbsv, gv, Nullch);
2437 (void)SvUPGRADE(dbsv, SVt_PVIV);
2438 (void)SvIOK_on(dbsv);
2439 SAVEIV(SvIVX(dbsv));
2440 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2444 PL_curcopdb = PL_curcop;
2445 cv = GvCV(PL_DBsub);
2455 register PERL_CONTEXT *cx;
2457 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2460 DIE(aTHX_ "Not a CODE reference");
2461 switch (SvTYPE(sv)) {
2467 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2469 SP = PL_stack_base + POPMARK;
2472 if (SvGMAGICAL(sv)) {
2476 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2479 sym = SvPV(sv, n_a);
2481 DIE(aTHX_ PL_no_usym, "a subroutine");
2482 if (PL_op->op_private & HINT_STRICT_REFS)
2483 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2484 cv = get_cv(sym, TRUE);
2489 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2490 tryAMAGICunDEREF(to_cv);
2493 if (SvTYPE(cv) == SVt_PVCV)
2498 DIE(aTHX_ "Not a CODE reference");
2503 if (!(cv = GvCVu((GV*)sv)))
2504 cv = sv_2cv(sv, &stash, &gv, FALSE);
2517 if (!CvROOT(cv) && !CvXSUB(cv)) {
2521 /* anonymous or undef'd function leaves us no recourse */
2522 if (CvANON(cv) || !(gv = CvGV(cv)))
2523 DIE(aTHX_ "Undefined subroutine called");
2525 /* autoloaded stub? */
2526 if (cv != GvCV(gv)) {
2529 /* should call AUTOLOAD now? */
2532 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2539 sub_name = sv_newmortal();
2540 gv_efullname3(sub_name, gv, Nullch);
2541 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2545 DIE(aTHX_ "Not a CODE reference");
2550 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2551 cv = get_db_sub(&sv, cv);
2553 DIE(aTHX_ "No DBsub routine");
2556 #ifdef USE_5005THREADS
2558 * First we need to check if the sub or method requires locking.
2559 * If so, we gain a lock on the CV, the first argument or the
2560 * stash (for static methods), as appropriate. This has to be
2561 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2562 * reschedule by returning a new op.
2564 MUTEX_LOCK(CvMUTEXP(cv));
2565 if (CvFLAGS(cv) & CVf_LOCKED) {
2567 if (CvFLAGS(cv) & CVf_METHOD) {
2568 if (SP > PL_stack_base + TOPMARK)
2569 sv = *(PL_stack_base + TOPMARK + 1);
2571 AV *av = (AV*)PL_curpad[0];
2572 if (hasargs || !av || AvFILLp(av) < 0
2573 || !(sv = AvARRAY(av)[0]))
2575 MUTEX_UNLOCK(CvMUTEXP(cv));
2576 DIE(aTHX_ "no argument for locked method call");
2583 char *stashname = SvPV(sv, len);
2584 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2590 MUTEX_UNLOCK(CvMUTEXP(cv));
2591 mg = condpair_magic(sv);
2592 MUTEX_LOCK(MgMUTEXP(mg));
2593 if (MgOWNER(mg) == thr)
2594 MUTEX_UNLOCK(MgMUTEXP(mg));
2597 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2599 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2601 MUTEX_UNLOCK(MgMUTEXP(mg));
2602 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2604 MUTEX_LOCK(CvMUTEXP(cv));
2607 * Now we have permission to enter the sub, we must distinguish
2608 * four cases. (0) It's an XSUB (in which case we don't care
2609 * about ownership); (1) it's ours already (and we're recursing);
2610 * (2) it's free (but we may already be using a cached clone);
2611 * (3) another thread owns it. Case (1) is easy: we just use it.
2612 * Case (2) means we look for a clone--if we have one, use it
2613 * otherwise grab ownership of cv. Case (3) means we look for a
2614 * clone (for non-XSUBs) and have to create one if we don't
2616 * Why look for a clone in case (2) when we could just grab
2617 * ownership of cv straight away? Well, we could be recursing,
2618 * i.e. we originally tried to enter cv while another thread
2619 * owned it (hence we used a clone) but it has been freed up
2620 * and we're now recursing into it. It may or may not be "better"
2621 * to use the clone but at least CvDEPTH can be trusted.
2623 if (CvOWNER(cv) == thr || CvXSUB(cv))
2624 MUTEX_UNLOCK(CvMUTEXP(cv));
2626 /* Case (2) or (3) */
2630 * XXX Might it be better to release CvMUTEXP(cv) while we
2631 * do the hv_fetch? We might find someone has pinched it
2632 * when we look again, in which case we would be in case
2633 * (3) instead of (2) so we'd have to clone. Would the fact
2634 * that we released the mutex more quickly make up for this?
2636 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2638 /* We already have a clone to use */
2639 MUTEX_UNLOCK(CvMUTEXP(cv));
2641 DEBUG_S(PerlIO_printf(Perl_debug_log,
2642 "entersub: %p already has clone %p:%s\n",
2643 thr, cv, SvPEEK((SV*)cv)));
2646 if (CvDEPTH(cv) == 0)
2647 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2650 /* (2) => grab ownership of cv. (3) => make clone */
2654 MUTEX_UNLOCK(CvMUTEXP(cv));
2655 DEBUG_S(PerlIO_printf(Perl_debug_log,
2656 "entersub: %p grabbing %p:%s in stash %s\n",
2657 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2658 HvNAME(CvSTASH(cv)) : "(none)"));
2661 /* Make a new clone. */
2663 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2664 MUTEX_UNLOCK(CvMUTEXP(cv));
2665 DEBUG_S((PerlIO_printf(Perl_debug_log,
2666 "entersub: %p cloning %p:%s\n",
2667 thr, cv, SvPEEK((SV*)cv))));
2669 * We're creating a new clone so there's no race
2670 * between the original MUTEX_UNLOCK and the
2671 * SvREFCNT_inc since no one will be trying to undef
2672 * it out from underneath us. At least, I don't think
2675 clonecv = cv_clone(cv);
2676 SvREFCNT_dec(cv); /* finished with this */
2677 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2678 CvOWNER(clonecv) = thr;
2682 DEBUG_S(if (CvDEPTH(cv) != 0)
2683 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2685 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2688 #endif /* USE_5005THREADS */
2691 #ifdef PERL_XSUB_OLDSTYLE
2692 if (CvOLDSTYLE(cv)) {
2693 I32 (*fp3)(int,int,int);
2695 register I32 items = SP - MARK;
2696 /* We dont worry to copy from @_. */
2701 PL_stack_sp = mark + 1;
2702 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2703 items = (*fp3)(CvXSUBANY(cv).any_i32,
2704 MARK - PL_stack_base + 1,
2706 PL_stack_sp = PL_stack_base + items;
2709 #endif /* PERL_XSUB_OLDSTYLE */
2711 I32 markix = TOPMARK;
2716 /* Need to copy @_ to stack. Alternative may be to
2717 * switch stack to @_, and copy return values
2718 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2721 #ifdef USE_5005THREADS
2722 av = (AV*)PL_curpad[0];
2724 av = GvAV(PL_defgv);
2725 #endif /* USE_5005THREADS */
2726 items = AvFILLp(av) + 1; /* @_ is not tieable */
2729 /* Mark is at the end of the stack. */
2731 Copy(AvARRAY(av), SP + 1, items, SV*);
2736 /* We assume first XSUB in &DB::sub is the called one. */
2738 SAVEVPTR(PL_curcop);
2739 PL_curcop = PL_curcopdb;
2742 /* Do we need to open block here? XXXX */
2743 (void)(*CvXSUB(cv))(aTHX_ cv);
2745 /* Enforce some sanity in scalar context. */
2746 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2747 if (markix > PL_stack_sp - PL_stack_base)
2748 *(PL_stack_base + markix) = &PL_sv_undef;
2750 *(PL_stack_base + markix) = *PL_stack_sp;
2751 PL_stack_sp = PL_stack_base + markix;
2759 register I32 items = SP - MARK;
2760 AV* padlist = CvPADLIST(cv);
2761 SV** svp = AvARRAY(padlist);
2762 push_return(PL_op->op_next);
2763 PUSHBLOCK(cx, CXt_SUB, MARK);
2766 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2767 * that eval'' ops within this sub know the correct lexical space.
2768 * Owing the speed considerations, we choose to search for the cv
2769 * in doeval() instead.
2771 if (CvDEPTH(cv) < 2)
2772 (void)SvREFCNT_inc(cv);
2773 else { /* save temporaries on recursion? */
2774 PERL_STACK_OVERFLOW_CHECK();
2775 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2777 AV *newpad = newAV();
2778 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2779 I32 ix = AvFILLp((AV*)svp[1]);
2780 I32 names_fill = AvFILLp((AV*)svp[0]);
2781 svp = AvARRAY(svp[0]);
2782 for ( ;ix > 0; ix--) {
2783 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2784 char *name = SvPVX(svp[ix]);
2785 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2786 || *name == '&') /* anonymous code? */
2788 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2790 else { /* our own lexical */
2792 av_store(newpad, ix, sv = (SV*)newAV());
2793 else if (*name == '%')
2794 av_store(newpad, ix, sv = (SV*)newHV());
2796 av_store(newpad, ix, sv = NEWSV(0,0));
2800 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2801 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2804 av_store(newpad, ix, sv = NEWSV(0,0));
2808 av = newAV(); /* will be @_ */
2810 av_store(newpad, 0, (SV*)av);
2811 AvFLAGS(av) = AVf_REIFY;
2812 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2813 AvFILLp(padlist) = CvDEPTH(cv);
2814 svp = AvARRAY(padlist);
2817 #ifdef USE_5005THREADS
2819 AV* av = (AV*)PL_curpad[0];
2821 items = AvFILLp(av) + 1;
2823 /* Mark is at the end of the stack. */
2825 Copy(AvARRAY(av), SP + 1, items, SV*);
2830 #endif /* USE_5005THREADS */
2831 SAVEVPTR(PL_curpad);
2832 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2833 #ifndef USE_5005THREADS
2835 #endif /* USE_5005THREADS */
2841 DEBUG_S(PerlIO_printf(Perl_debug_log,
2842 "%p entersub preparing @_\n", thr));
2844 av = (AV*)PL_curpad[0];
2846 /* @_ is normally not REAL--this should only ever
2847 * happen when DB::sub() calls things that modify @_ */
2852 #ifndef USE_5005THREADS
2853 cx->blk_sub.savearray = GvAV(PL_defgv);
2854 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2855 #endif /* USE_5005THREADS */
2856 cx->blk_sub.oldcurpad = PL_curpad;
2857 cx->blk_sub.argarray = av;
2860 if (items > AvMAX(av) + 1) {
2862 if (AvARRAY(av) != ary) {
2863 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2864 SvPVX(av) = (char*)ary;
2866 if (items > AvMAX(av) + 1) {
2867 AvMAX(av) = items - 1;
2868 Renew(ary,items,SV*);
2870 SvPVX(av) = (char*)ary;
2873 Copy(MARK,AvARRAY(av),items,SV*);
2874 AvFILLp(av) = items - 1;
2882 /* warning must come *after* we fully set up the context
2883 * stuff so that __WARN__ handlers can safely dounwind()
2886 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2887 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2888 sub_crush_depth(cv);
2890 DEBUG_S(PerlIO_printf(Perl_debug_log,
2891 "%p entersub returning %p\n", thr, CvSTART(cv)));
2893 RETURNOP(CvSTART(cv));
2898 Perl_sub_crush_depth(pTHX_ CV *cv)
2901 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2903 SV* tmpstr = sv_newmortal();
2904 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2905 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
2915 IV elem = SvIV(elemsv);
2917 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2918 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2921 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2922 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2924 elem -= PL_curcop->cop_arybase;
2925 if (SvTYPE(av) != SVt_PVAV)
2927 svp = av_fetch(av, elem, lval && !defer);
2929 if (!svp || *svp == &PL_sv_undef) {
2932 DIE(aTHX_ PL_no_aelem, elem);
2933 lv = sv_newmortal();
2934 sv_upgrade(lv, SVt_PVLV);
2936 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2937 LvTARG(lv) = SvREFCNT_inc(av);
2938 LvTARGOFF(lv) = elem;
2943 if (PL_op->op_private & OPpLVAL_INTRO)
2944 save_aelem(av, elem, svp);
2945 else if (PL_op->op_private & OPpDEREF)
2946 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2948 sv = (svp ? *svp : &PL_sv_undef);
2949 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2950 sv = sv_mortalcopy(sv);
2956 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2962 Perl_croak(aTHX_ PL_no_modify);
2963 if (SvTYPE(sv) < SVt_RV)
2964 sv_upgrade(sv, SVt_RV);
2965 else if (SvTYPE(sv) >= SVt_PV) {
2966 (void)SvOOK_off(sv);
2967 Safefree(SvPVX(sv));
2968 SvLEN(sv) = SvCUR(sv) = 0;
2972 SvRV(sv) = NEWSV(355,0);
2975 SvRV(sv) = (SV*)newAV();
2978 SvRV(sv) = (SV*)newHV();
2993 if (SvTYPE(rsv) == SVt_PVCV) {
2999 SETs(method_common(sv, Null(U32*)));
3006 SV* sv = cSVOP->op_sv;
3007 U32 hash = SvUVX(sv);
3009 XPUSHs(method_common(sv, &hash));
3014 S_method_common(pTHX_ SV* meth, U32* hashp)
3025 name = SvPV(meth, namelen);
3026 sv = *(PL_stack_base + TOPMARK + 1);
3029 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3038 /* this isn't a reference */
3041 !(packname = SvPV(sv, packlen)) ||
3042 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3043 !(ob=(SV*)GvIO(iogv)))
3045 /* this isn't the name of a filehandle either */
3047 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3048 ? !isIDFIRST_utf8((U8*)packname)
3049 : !isIDFIRST(*packname)
3052 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3053 SvOK(sv) ? "without a package or object reference"
3054 : "on an undefined value");
3056 /* assume it's a package name */
3057 stash = gv_stashpvn(packname, packlen, FALSE);
3060 /* it _is_ a filehandle name -- replace with a reference */
3061 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3064 /* if we got here, ob should be a reference or a glob */
3065 if (!ob || !(SvOBJECT(ob)
3066 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3069 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3073 stash = SvSTASH(ob);
3076 /* NOTE: stash may be null, hope hv_fetch_ent and
3077 gv_fetchmethod can cope (it seems they can) */
3079 /* shortcut for simple names */
3081 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3083 gv = (GV*)HeVAL(he);
3084 if (isGV(gv) && GvCV(gv) &&
3085 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3086 return (SV*)GvCV(gv);
3090 gv = gv_fetchmethod(stash, name);
3093 /* This code tries to figure out just what went wrong with
3094 gv_fetchmethod. It therefore needs to duplicate a lot of
3095 the internals of that function. We can't move it inside
3096 Perl_gv_fetchmethod_autoload(), however, since that would
3097 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3104 for (p = name; *p; p++) {
3106 sep = p, leaf = p + 1;
3107 else if (*p == ':' && *(p + 1) == ':')
3108 sep = p, leaf = p + 2;
3110 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3111 /* the method name is unqualified or starts with SUPER:: */
3112 packname = sep ? CopSTASHPV(PL_curcop) :
3113 stash ? HvNAME(stash) : packname;
3114 packlen = strlen(packname);
3117 /* the method name is qualified */
3119 packlen = sep - name;
3122 /* we're relying on gv_fetchmethod not autovivifying the stash */
3123 if (gv_stashpvn(packname, packlen, FALSE)) {
3125 "Can't locate object method \"%s\" via package \"%.*s\"",
3126 leaf, (int)packlen, packname);
3130 "Can't locate object method \"%s\" via package \"%.*s\""
3131 " (perhaps you forgot to load \"%.*s\"?)",
3132 leaf, (int)packlen, packname, (int)packlen, packname);
3135 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3138 #ifdef USE_5005THREADS
3140 unset_cvowner(pTHX_ void *cvarg)
3142 register CV* cv = (CV *) cvarg;
3144 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3145 thr, cv, SvPEEK((SV*)cv))));
3146 MUTEX_LOCK(CvMUTEXP(cv));
3147 DEBUG_S(if (CvDEPTH(cv) != 0)
3148 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3150 assert(thr == CvOWNER(cv));
3152 MUTEX_UNLOCK(CvMUTEXP(cv));
3155 #endif /* USE_5005THREADS */