3 * Copyright (c) 1991-2001, 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);
78 sv_setpvn(TARG,s,len);
90 XPUSHs((SV*)cGVOP_gv);
101 RETURNOP(cLOGOP->op_other);
109 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
111 temp = left; left = right; right = temp;
113 if (PL_tainting && PL_tainted && !SvTAINTED(left))
115 SvSetMagicSV(right, left);
124 RETURNOP(cLOGOP->op_other);
126 RETURNOP(cLOGOP->op_next);
132 TAINT_NOT; /* Each statement is presumed innocent */
133 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
135 oldsave = PL_scopestack[PL_scopestack_ix - 1];
136 LEAVE_SCOPE(oldsave);
142 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
149 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
150 bool rbyte = !SvUTF8(right);
152 if (TARG == right && right != left) {
153 right = sv_2mortal(newSVpvn(rpv, rlen));
154 rpv = SvPV(right, rlen); /* no point setting UTF8 here */
158 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
159 lbyte = !SvUTF8(left);
160 sv_setpvn(TARG, lpv, llen);
166 else { /* TARG == left */
167 if (SvGMAGICAL(left))
168 mg_get(left); /* or mg_get(left) may happen here */
171 lpv = SvPV_nomg(left, llen);
172 lbyte = !SvUTF8(left);
175 #if defined(PERL_Y2KWARN)
176 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
177 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
178 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
180 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
181 "about to append an integer to '19'");
186 if (lbyte != rbyte) {
188 sv_utf8_upgrade_nomg(TARG);
190 sv_utf8_upgrade_nomg(right);
191 rpv = SvPV(right, rlen);
194 sv_catpvn_nomg(TARG, rpv, rlen);
205 if (PL_op->op_flags & OPf_MOD) {
206 if (PL_op->op_private & OPpLVAL_INTRO)
207 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
208 else if (PL_op->op_private & OPpDEREF) {
210 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
219 tryAMAGICunTARGET(iter, 0);
220 PL_last_in_gv = (GV*)(*PL_stack_sp--);
221 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
222 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
223 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
226 XPUSHs((SV*)PL_last_in_gv);
229 PL_last_in_gv = (GV*)(*PL_stack_sp--);
232 return do_readline();
237 dSP; tryAMAGICbinSET(eq,0);
238 #ifndef NV_PRESERVES_UV
239 if (SvROK(TOPs) && SvROK(TOPm1s)) {
241 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
245 #ifdef PERL_PRESERVE_IVUV
248 /* Unless the left argument is integer in range we are going
249 to have to use NV maths. Hence only attempt to coerce the
250 right argument if we know the left is integer. */
253 bool auvok = SvUOK(TOPm1s);
254 bool buvok = SvUOK(TOPs);
256 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
257 /* Casting IV to UV before comparison isn't going to matter
258 on 2s complement. On 1s complement or sign&magnitude
259 (if we have any of them) it could to make negative zero
260 differ from normal zero. As I understand it. (Need to
261 check - is negative zero implementation defined behaviour
263 UV buv = SvUVX(POPs);
264 UV auv = SvUVX(TOPs);
266 SETs(boolSV(auv == buv));
269 { /* ## Mixed IV,UV ## */
273 /* == is commutative so doesn't matter which is left or right */
275 /* top of stack (b) is the iv */
284 /* As uv is a UV, it's >0, so it cannot be == */
288 /* we know iv is >= 0 */
289 SETs(boolSV((UV)iv == SvUVX(uvp)));
297 SETs(boolSV(TOPn == value));
305 if (SvTYPE(TOPs) > SVt_PVLV)
306 DIE(aTHX_ PL_no_modify);
307 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
308 && SvIVX(TOPs) != IV_MAX)
311 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
313 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
326 RETURNOP(cLOGOP->op_other);
332 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
333 useleft = USE_LEFT(TOPm1s);
334 #ifdef PERL_PRESERVE_IVUV
335 /* We must see if we can perform the addition with integers if possible,
336 as the integer code detects overflow while the NV code doesn't.
337 If either argument hasn't had a numeric conversion yet attempt to get
338 the IV. It's important to do this now, rather than just assuming that
339 it's not IOK as a PV of "9223372036854775806" may not take well to NV
340 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
341 integer in case the second argument is IV=9223372036854775806
342 We can (now) rely on sv_2iv to do the right thing, only setting the
343 public IOK flag if the value in the NV (or PV) slot is truly integer.
345 A side effect is that this also aggressively prefers integer maths over
346 fp maths for integer values.
348 How to detect overflow?
350 C 99 section 6.2.6.1 says
352 The range of nonnegative values of a signed integer type is a subrange
353 of the corresponding unsigned integer type, and the representation of
354 the same value in each type is the same. A computation involving
355 unsigned operands can never overflow, because a result that cannot be
356 represented by the resulting unsigned integer type is reduced modulo
357 the number that is one greater than the largest value that can be
358 represented by the resulting type.
362 which I read as "unsigned ints wrap."
364 signed integer overflow seems to be classed as "exception condition"
366 If an exceptional condition occurs during the evaluation of an
367 expression (that is, if the result is not mathematically defined or not
368 in the range of representable values for its type), the behavior is
371 (6.5, the 5th paragraph)
373 I had assumed that on 2s complement machines signed arithmetic would
374 wrap, hence coded pp_add and pp_subtract on the assumption that
375 everything perl builds on would be happy. After much wailing and
376 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
377 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
378 unsigned code below is actually shorter than the old code. :-)
383 /* Unless the left argument is integer in range we are going to have to
384 use NV maths. Hence only attempt to coerce the right argument if
385 we know the left is integer. */
393 /* left operand is undef, treat as zero. + 0 is identity,
394 Could SETi or SETu right now, but space optimise by not adding
395 lots of code to speed up what is probably a rarish case. */
397 /* Left operand is defined, so is it IV? */
400 if ((auvok = SvUOK(TOPm1s)))
403 register IV aiv = SvIVX(TOPm1s);
406 auvok = 1; /* Now acting as a sign flag. */
407 } else { /* 2s complement assumption for IV_MIN */
415 bool result_good = 0;
418 bool buvok = SvUOK(TOPs);
423 register IV biv = SvIVX(TOPs);
430 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
431 else "IV" now, independant of how it came in.
432 if a, b represents positive, A, B negative, a maps to -A etc
437 all UV maths. negate result if A negative.
438 add if signs same, subtract if signs differ. */
444 /* Must get smaller */
450 /* result really should be -(auv-buv). as its negation
451 of true value, need to swap our result flag */
468 if (result <= (UV)IV_MIN)
471 /* result valid, but out of range for IV. */
476 } /* Overflow, drop through to NVs. */
483 /* left operand is undef, treat as zero. + 0.0 is identity. */
487 SETn( value + TOPn );
495 AV *av = GvAV(cGVOP_gv);
496 U32 lval = PL_op->op_flags & OPf_MOD;
497 SV** svp = av_fetch(av, PL_op->op_private, lval);
498 SV *sv = (svp ? *svp : &PL_sv_undef);
500 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
501 sv = sv_mortalcopy(sv);
510 do_join(TARG, *MARK, MARK, SP);
521 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
522 * will be enough to hold an OP*.
524 SV* sv = sv_newmortal();
525 sv_upgrade(sv, SVt_PVLV);
527 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
535 /* Oversized hot code. */
539 dSP; dMARK; dORIGMARK;
545 if (PL_op->op_flags & OPf_STACKED)
550 if (gv && (io = GvIO(gv))
551 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
554 if (MARK == ORIGMARK) {
555 /* If using default handle then we need to make space to
556 * pass object as 1st arg, so move other args up ...
560 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
564 *MARK = SvTIED_obj((SV*)io, mg);
567 call_method("PRINT", G_SCALAR);
575 if (!(io = GvIO(gv))) {
576 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
577 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
579 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
580 report_evil_fh(gv, io, PL_op->op_type);
581 SETERRNO(EBADF,RMS$_IFI);
584 else if (!(fp = IoOFP(io))) {
585 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
587 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
588 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
589 report_evil_fh(gv, io, PL_op->op_type);
591 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
596 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
598 if (!do_print(*MARK, fp))
602 if (!do_print(PL_ofs_sv, fp)) { /* $, */
611 if (!do_print(*MARK, fp))
619 if (PL_ors_sv && SvOK(PL_ors_sv))
620 if (!do_print(PL_ors_sv, fp)) /* $\ */
623 if (IoFLAGS(io) & IOf_FLUSH)
624 if (PerlIO_flush(fp) == EOF)
645 tryAMAGICunDEREF(to_av);
648 if (SvTYPE(av) != SVt_PVAV)
649 DIE(aTHX_ "Not an ARRAY reference");
650 if (PL_op->op_flags & OPf_REF) {
655 if (GIMME == G_SCALAR)
656 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
662 if (SvTYPE(sv) == SVt_PVAV) {
664 if (PL_op->op_flags & OPf_REF) {
669 if (GIMME == G_SCALAR)
670 Perl_croak(aTHX_ "Can't return array to lvalue"
679 if (SvTYPE(sv) != SVt_PVGV) {
683 if (SvGMAGICAL(sv)) {
689 if (PL_op->op_flags & OPf_REF ||
690 PL_op->op_private & HINT_STRICT_REFS)
691 DIE(aTHX_ PL_no_usym, "an ARRAY");
692 if (ckWARN(WARN_UNINITIALIZED))
694 if (GIMME == G_ARRAY) {
701 if ((PL_op->op_flags & OPf_SPECIAL) &&
702 !(PL_op->op_flags & OPf_MOD))
704 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
706 && (!is_gv_magical(sym,len,0)
707 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
713 if (PL_op->op_private & HINT_STRICT_REFS)
714 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
715 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
722 if (PL_op->op_private & OPpLVAL_INTRO)
724 if (PL_op->op_flags & OPf_REF) {
729 if (GIMME == G_SCALAR)
730 Perl_croak(aTHX_ "Can't return array to lvalue"
738 if (GIMME == G_ARRAY) {
739 I32 maxarg = AvFILL(av) + 1;
740 (void)POPs; /* XXXX May be optimized away? */
742 if (SvRMAGICAL(av)) {
744 for (i=0; i < maxarg; i++) {
745 SV **svp = av_fetch(av, i, FALSE);
746 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
750 Copy(AvARRAY(av), SP+1, maxarg, SV*);
756 I32 maxarg = AvFILL(av) + 1;
769 tryAMAGICunDEREF(to_hv);
772 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
773 DIE(aTHX_ "Not a HASH reference");
774 if (PL_op->op_flags & OPf_REF) {
779 if (GIMME == G_SCALAR)
780 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
786 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
788 if (PL_op->op_flags & OPf_REF) {
793 if (GIMME == G_SCALAR)
794 Perl_croak(aTHX_ "Can't return hash to lvalue"
803 if (SvTYPE(sv) != SVt_PVGV) {
807 if (SvGMAGICAL(sv)) {
813 if (PL_op->op_flags & OPf_REF ||
814 PL_op->op_private & HINT_STRICT_REFS)
815 DIE(aTHX_ PL_no_usym, "a HASH");
816 if (ckWARN(WARN_UNINITIALIZED))
818 if (GIMME == G_ARRAY) {
825 if ((PL_op->op_flags & OPf_SPECIAL) &&
826 !(PL_op->op_flags & OPf_MOD))
828 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
830 && (!is_gv_magical(sym,len,0)
831 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
837 if (PL_op->op_private & HINT_STRICT_REFS)
838 DIE(aTHX_ PL_no_symref, sym, "a HASH");
839 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
846 if (PL_op->op_private & OPpLVAL_INTRO)
848 if (PL_op->op_flags & OPf_REF) {
853 if (GIMME == G_SCALAR)
854 Perl_croak(aTHX_ "Can't return hash to lvalue"
862 if (GIMME == G_ARRAY) { /* array wanted */
863 *PL_stack_sp = (SV*)hv;
868 if (SvTYPE(hv) == SVt_PVAV)
869 hv = avhv_keys((AV*)hv);
871 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
872 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
882 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
888 leftop = ((BINOP*)PL_op)->op_last;
890 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
891 leftop = ((LISTOP*)leftop)->op_first;
893 /* Skip PUSHMARK and each element already assigned to. */
894 for (i = lelem - firstlelem; i > 0; i--) {
895 leftop = leftop->op_sibling;
898 if (leftop->op_type != OP_RV2HV)
903 av_fill(ary, 0); /* clear all but the fields hash */
904 if (lastrelem >= relem) {
905 while (relem < lastrelem) { /* gobble up all the rest */
909 /* Avoid a memory leak when avhv_store_ent dies. */
910 tmpstr = sv_newmortal();
911 sv_setsv(tmpstr,relem[1]); /* value */
913 if (avhv_store_ent(ary,relem[0],tmpstr,0))
914 (void)SvREFCNT_inc(tmpstr);
915 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
921 if (relem == lastrelem)
927 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
931 if (ckWARN(WARN_MISC)) {
932 if (relem == firstrelem &&
934 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
935 SvTYPE(SvRV(*relem)) == SVt_PVHV))
937 Perl_warner(aTHX_ WARN_MISC,
938 "Reference found where even-sized list expected");
941 Perl_warner(aTHX_ WARN_MISC,
942 "Odd number of elements in hash assignment");
944 if (SvTYPE(hash) == SVt_PVAV) {
946 tmpstr = sv_newmortal();
947 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
948 (void)SvREFCNT_inc(tmpstr);
949 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
954 tmpstr = NEWSV(29,0);
955 didstore = hv_store_ent(hash,*relem,tmpstr,0);
956 if (SvMAGICAL(hash)) {
957 if (SvSMAGICAL(tmpstr))
970 SV **lastlelem = PL_stack_sp;
971 SV **lastrelem = PL_stack_base + POPMARK;
972 SV **firstrelem = PL_stack_base + POPMARK + 1;
973 SV **firstlelem = lastrelem + 1;
986 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
988 /* If there's a common identifier on both sides we have to take
989 * special care that assigning the identifier on the left doesn't
990 * clobber a value on the right that's used later in the list.
992 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
993 EXTEND_MORTAL(lastrelem - firstrelem + 1);
994 for (relem = firstrelem; relem <= lastrelem; relem++) {
997 TAINT_NOT; /* Each item is independent */
998 *relem = sv_mortalcopy(sv);
1008 while (lelem <= lastlelem) {
1009 TAINT_NOT; /* Each item stands on its own, taintwise. */
1011 switch (SvTYPE(sv)) {
1014 magic = SvMAGICAL(ary) != 0;
1015 if (PL_op->op_private & OPpASSIGN_HASH) {
1016 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1022 do_oddball((HV*)ary, relem, firstrelem);
1024 relem = lastrelem + 1;
1029 av_extend(ary, lastrelem - relem);
1031 while (relem <= lastrelem) { /* gobble up all the rest */
1035 sv_setsv(sv,*relem);
1037 didstore = av_store(ary,i++,sv);
1047 case SVt_PVHV: { /* normal hash */
1051 magic = SvMAGICAL(hash) != 0;
1054 while (relem < lastrelem) { /* gobble up all the rest */
1059 sv = &PL_sv_no, relem++;
1060 tmpstr = NEWSV(29,0);
1062 sv_setsv(tmpstr,*relem); /* value */
1063 *(relem++) = tmpstr;
1064 didstore = hv_store_ent(hash,sv,tmpstr,0);
1066 if (SvSMAGICAL(tmpstr))
1073 if (relem == lastrelem) {
1074 do_oddball(hash, relem, firstrelem);
1080 if (SvIMMORTAL(sv)) {
1081 if (relem <= lastrelem)
1085 if (relem <= lastrelem) {
1086 sv_setsv(sv, *relem);
1090 sv_setsv(sv, &PL_sv_undef);
1095 if (PL_delaymagic & ~DM_DELAY) {
1096 if (PL_delaymagic & DM_UID) {
1097 #ifdef HAS_SETRESUID
1098 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1100 # ifdef HAS_SETREUID
1101 (void)setreuid(PL_uid,PL_euid);
1104 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1105 (void)setruid(PL_uid);
1106 PL_delaymagic &= ~DM_RUID;
1108 # endif /* HAS_SETRUID */
1110 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1111 (void)seteuid(PL_uid);
1112 PL_delaymagic &= ~DM_EUID;
1114 # endif /* HAS_SETEUID */
1115 if (PL_delaymagic & DM_UID) {
1116 if (PL_uid != PL_euid)
1117 DIE(aTHX_ "No setreuid available");
1118 (void)PerlProc_setuid(PL_uid);
1120 # endif /* HAS_SETREUID */
1121 #endif /* HAS_SETRESUID */
1122 PL_uid = PerlProc_getuid();
1123 PL_euid = PerlProc_geteuid();
1125 if (PL_delaymagic & DM_GID) {
1126 #ifdef HAS_SETRESGID
1127 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1129 # ifdef HAS_SETREGID
1130 (void)setregid(PL_gid,PL_egid);
1133 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1134 (void)setrgid(PL_gid);
1135 PL_delaymagic &= ~DM_RGID;
1137 # endif /* HAS_SETRGID */
1139 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1140 (void)setegid(PL_gid);
1141 PL_delaymagic &= ~DM_EGID;
1143 # endif /* HAS_SETEGID */
1144 if (PL_delaymagic & DM_GID) {
1145 if (PL_gid != PL_egid)
1146 DIE(aTHX_ "No setregid available");
1147 (void)PerlProc_setgid(PL_gid);
1149 # endif /* HAS_SETREGID */
1150 #endif /* HAS_SETRESGID */
1151 PL_gid = PerlProc_getgid();
1152 PL_egid = PerlProc_getegid();
1154 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1159 if (gimme == G_VOID)
1160 SP = firstrelem - 1;
1161 else if (gimme == G_SCALAR) {
1164 SETi(lastrelem - firstrelem + 1);
1170 SP = firstrelem + (lastlelem - firstlelem);
1171 lelem = firstlelem + (relem - firstrelem);
1173 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1181 register PMOP *pm = cPMOP;
1182 SV *rv = sv_newmortal();
1183 SV *sv = newSVrv(rv, "Regexp");
1184 if (pm->op_pmdynflags & PMdf_TAINTED)
1186 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1193 register PMOP *pm = cPMOP;
1198 I32 r_flags = REXEC_CHECKED;
1199 char *truebase; /* Start of string */
1200 register REGEXP *rx = PM_GETRE(pm);
1205 I32 oldsave = PL_savestack_ix;
1206 I32 update_minmatch = 1;
1207 I32 had_zerolen = 0;
1209 if (PL_op->op_flags & OPf_STACKED)
1216 PUTBACK; /* EVAL blocks need stack_sp. */
1217 s = SvPV(TARG, len);
1220 DIE(aTHX_ "panic: pp_match");
1221 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1222 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1225 PL_reg_match_utf8 = DO_UTF8(TARG);
1227 if (pm->op_pmdynflags & PMdf_USED) {
1229 if (gimme == G_ARRAY)
1234 if (!rx->prelen && PL_curpm) {
1238 if (rx->minlen > len)
1243 /* XXXX What part of this is needed with true \G-support? */
1244 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1246 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1247 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1248 if (mg && mg->mg_len >= 0) {
1249 if (!(rx->reganch & ROPT_GPOS_SEEN))
1250 rx->endp[0] = rx->startp[0] = mg->mg_len;
1251 else if (rx->reganch & ROPT_ANCH_GPOS) {
1252 r_flags |= REXEC_IGNOREPOS;
1253 rx->endp[0] = rx->startp[0] = mg->mg_len;
1255 minmatch = (mg->mg_flags & MGf_MINMATCH);
1256 update_minmatch = 0;
1260 if ((!global && rx->nparens)
1261 || SvTEMP(TARG) || PL_sawampersand)
1262 r_flags |= REXEC_COPY_STR;
1264 r_flags |= REXEC_SCREAM;
1266 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1267 SAVEINT(PL_multiline);
1268 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1272 if (global && rx->startp[0] != -1) {
1273 t = s = rx->endp[0] + truebase;
1274 if ((s + rx->minlen) > strend)
1276 if (update_minmatch++)
1277 minmatch = had_zerolen;
1279 if (rx->reganch & RE_USE_INTUIT &&
1280 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1281 PL_bostr = truebase;
1282 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1286 if ( (rx->reganch & ROPT_CHECK_ALL)
1288 && ((rx->reganch & ROPT_NOSCAN)
1289 || !((rx->reganch & RE_INTUIT_TAIL)
1290 && (r_flags & REXEC_SCREAM)))
1291 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1294 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1297 if (pm->op_pmflags & PMf_ONCE)
1298 pm->op_pmdynflags |= PMdf_USED;
1307 RX_MATCH_TAINTED_on(rx);
1308 TAINT_IF(RX_MATCH_TAINTED(rx));
1309 if (gimme == G_ARRAY) {
1310 I32 nparens, i, len;
1312 nparens = rx->nparens;
1313 if (global && !nparens)
1317 SPAGAIN; /* EVAL blocks could move the stack. */
1318 EXTEND(SP, nparens + i);
1319 EXTEND_MORTAL(nparens + i);
1320 for (i = !i; i <= nparens; i++) {
1321 PUSHs(sv_newmortal());
1323 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1324 len = rx->endp[i] - rx->startp[i];
1325 s = rx->startp[i] + truebase;
1326 sv_setpvn(*SP, s, len);
1327 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1332 if (pm->op_pmflags & PMf_CONTINUE) {
1334 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1335 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1337 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1338 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1340 if (rx->startp[0] != -1) {
1341 mg->mg_len = rx->endp[0];
1342 if (rx->startp[0] == rx->endp[0])
1343 mg->mg_flags |= MGf_MINMATCH;
1345 mg->mg_flags &= ~MGf_MINMATCH;
1348 had_zerolen = (rx->startp[0] != -1
1349 && rx->startp[0] == rx->endp[0]);
1350 PUTBACK; /* EVAL blocks may use stack */
1351 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1356 LEAVE_SCOPE(oldsave);
1362 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1363 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1365 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1366 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1368 if (rx->startp[0] != -1) {
1369 mg->mg_len = rx->endp[0];
1370 if (rx->startp[0] == rx->endp[0])
1371 mg->mg_flags |= MGf_MINMATCH;
1373 mg->mg_flags &= ~MGf_MINMATCH;
1376 LEAVE_SCOPE(oldsave);
1380 yup: /* Confirmed by INTUIT */
1382 RX_MATCH_TAINTED_on(rx);
1383 TAINT_IF(RX_MATCH_TAINTED(rx));
1385 if (pm->op_pmflags & PMf_ONCE)
1386 pm->op_pmdynflags |= PMdf_USED;
1387 if (RX_MATCH_COPIED(rx))
1388 Safefree(rx->subbeg);
1389 RX_MATCH_COPIED_off(rx);
1390 rx->subbeg = Nullch;
1392 rx->subbeg = truebase;
1393 rx->startp[0] = s - truebase;
1394 if (PL_reg_match_utf8) {
1395 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1396 rx->endp[0] = t - truebase;
1399 rx->endp[0] = s - truebase + rx->minlen;
1401 rx->sublen = strend - truebase;
1404 if (PL_sawampersand) {
1407 rx->subbeg = savepvn(t, strend - t);
1408 rx->sublen = strend - t;
1409 RX_MATCH_COPIED_on(rx);
1410 off = rx->startp[0] = s - t;
1411 rx->endp[0] = off + rx->minlen;
1413 else { /* startp/endp are used by @- @+. */
1414 rx->startp[0] = s - truebase;
1415 rx->endp[0] = s - truebase + rx->minlen;
1417 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1418 LEAVE_SCOPE(oldsave);
1423 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1424 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1425 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1430 LEAVE_SCOPE(oldsave);
1431 if (gimme == G_ARRAY)
1437 Perl_do_readline(pTHX)
1439 dSP; dTARGETSTACKED;
1444 register IO *io = GvIO(PL_last_in_gv);
1445 register I32 type = PL_op->op_type;
1446 I32 gimme = GIMME_V;
1449 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1451 XPUSHs(SvTIED_obj((SV*)io, mg));
1454 call_method("READLINE", gimme);
1457 if (gimme == G_SCALAR)
1458 SvSetMagicSV_nosteal(TARG, TOPs);
1465 if (IoFLAGS(io) & IOf_ARGV) {
1466 if (IoFLAGS(io) & IOf_START) {
1468 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1469 IoFLAGS(io) &= ~IOf_START;
1470 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1471 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1472 SvSETMAGIC(GvSV(PL_last_in_gv));
1477 fp = nextargv(PL_last_in_gv);
1478 if (!fp) { /* Note: fp != IoIFP(io) */
1479 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1482 else if (type == OP_GLOB)
1483 fp = Perl_start_glob(aTHX_ POPs, io);
1485 else if (type == OP_GLOB)
1487 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1488 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1492 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1493 && (!io || !(IoFLAGS(io) & IOf_START))) {
1494 if (type == OP_GLOB)
1495 Perl_warner(aTHX_ WARN_GLOB,
1496 "glob failed (can't start child: %s)",
1499 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1501 if (gimme == G_SCALAR) {
1502 (void)SvOK_off(TARG);
1508 if (gimme == G_SCALAR) {
1512 (void)SvUPGRADE(sv, SVt_PV);
1513 tmplen = SvLEN(sv); /* remember if already alloced */
1515 Sv_Grow(sv, 80); /* try short-buffering it */
1516 if (type == OP_RCATLINE)
1522 sv = sv_2mortal(NEWSV(57, 80));
1526 /* This should not be marked tainted if the fp is marked clean */
1527 #define MAYBE_TAINT_LINE(io, sv) \
1528 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1533 /* delay EOF state for a snarfed empty file */
1534 #define SNARF_EOF(gimme,rs,io,sv) \
1535 (gimme != G_SCALAR || SvCUR(sv) \
1536 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1540 if (!sv_gets(sv, fp, offset)
1541 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1543 PerlIO_clearerr(fp);
1544 if (IoFLAGS(io) & IOf_ARGV) {
1545 fp = nextargv(PL_last_in_gv);
1548 (void)do_close(PL_last_in_gv, FALSE);
1550 else if (type == OP_GLOB) {
1551 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1552 Perl_warner(aTHX_ WARN_GLOB,
1553 "glob failed (child exited with status %d%s)",
1554 (int)(STATUS_CURRENT >> 8),
1555 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1558 if (gimme == G_SCALAR) {
1559 (void)SvOK_off(TARG);
1563 MAYBE_TAINT_LINE(io, sv);
1566 MAYBE_TAINT_LINE(io, sv);
1568 IoFLAGS(io) |= IOf_NOLINE;
1572 if (type == OP_GLOB) {
1575 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1576 tmps = SvEND(sv) - 1;
1577 if (*tmps == *SvPVX(PL_rs)) {
1582 for (tmps = SvPVX(sv); *tmps; tmps++)
1583 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1584 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1586 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1587 (void)POPs; /* Unmatched wildcard? Chuck it... */
1591 if (gimme == G_ARRAY) {
1592 if (SvLEN(sv) - SvCUR(sv) > 20) {
1593 SvLEN_set(sv, SvCUR(sv)+1);
1594 Renew(SvPVX(sv), SvLEN(sv), char);
1596 sv = sv_2mortal(NEWSV(58, 80));
1599 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1600 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1604 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1605 Renew(SvPVX(sv), SvLEN(sv), char);
1614 register PERL_CONTEXT *cx;
1615 I32 gimme = OP_GIMME(PL_op, -1);
1618 if (cxstack_ix >= 0)
1619 gimme = cxstack[cxstack_ix].blk_gimme;
1627 PUSHBLOCK(cx, CXt_BLOCK, SP);
1639 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1640 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1642 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1645 if (SvTYPE(hv) == SVt_PVHV) {
1646 if (PL_op->op_private & OPpLVAL_INTRO)
1647 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1648 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1649 svp = he ? &HeVAL(he) : 0;
1651 else if (SvTYPE(hv) == SVt_PVAV) {
1652 if (PL_op->op_private & OPpLVAL_INTRO)
1653 DIE(aTHX_ "Can't localize pseudo-hash element");
1654 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1660 if (!svp || *svp == &PL_sv_undef) {
1665 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1667 lv = sv_newmortal();
1668 sv_upgrade(lv, SVt_PVLV);
1670 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1671 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1672 LvTARG(lv) = SvREFCNT_inc(hv);
1677 if (PL_op->op_private & OPpLVAL_INTRO) {
1678 if (HvNAME(hv) && isGV(*svp))
1679 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1683 char *key = SvPV(keysv, keylen);
1684 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1686 save_helem(hv, keysv, svp);
1689 else if (PL_op->op_private & OPpDEREF)
1690 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1692 sv = (svp ? *svp : &PL_sv_undef);
1693 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1694 * Pushing the magical RHS on to the stack is useless, since
1695 * that magic is soon destined to be misled by the local(),
1696 * and thus the later pp_sassign() will fail to mg_get() the
1697 * old value. This should also cure problems with delayed
1698 * mg_get()s. GSAR 98-07-03 */
1699 if (!lval && SvGMAGICAL(sv))
1700 sv = sv_mortalcopy(sv);
1708 register PERL_CONTEXT *cx;
1714 if (PL_op->op_flags & OPf_SPECIAL) {
1715 cx = &cxstack[cxstack_ix];
1716 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1721 gimme = OP_GIMME(PL_op, -1);
1723 if (cxstack_ix >= 0)
1724 gimme = cxstack[cxstack_ix].blk_gimme;
1730 if (gimme == G_VOID)
1732 else if (gimme == G_SCALAR) {
1735 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1738 *MARK = sv_mortalcopy(TOPs);
1741 *MARK = &PL_sv_undef;
1745 else if (gimme == G_ARRAY) {
1746 /* in case LEAVE wipes old return values */
1747 for (mark = newsp + 1; mark <= SP; mark++) {
1748 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1749 *mark = sv_mortalcopy(*mark);
1750 TAINT_NOT; /* Each item is independent */
1754 PL_curpm = newpm; /* Don't pop $1 et al till now */
1764 register PERL_CONTEXT *cx;
1770 cx = &cxstack[cxstack_ix];
1771 if (CxTYPE(cx) != CXt_LOOP)
1772 DIE(aTHX_ "panic: pp_iter");
1774 itersvp = CxITERVAR(cx);
1775 av = cx->blk_loop.iterary;
1776 if (SvTYPE(av) != SVt_PVAV) {
1777 /* iterate ($min .. $max) */
1778 if (cx->blk_loop.iterlval) {
1779 /* string increment */
1780 register SV* cur = cx->blk_loop.iterlval;
1782 char *max = SvPV((SV*)av, maxlen);
1783 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1784 #ifndef USE_5005THREADS /* don't risk potential race */
1785 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1786 /* safe to reuse old SV */
1787 sv_setsv(*itersvp, cur);
1792 /* we need a fresh SV every time so that loop body sees a
1793 * completely new SV for closures/references to work as
1795 SvREFCNT_dec(*itersvp);
1796 *itersvp = newSVsv(cur);
1798 if (strEQ(SvPVX(cur), max))
1799 sv_setiv(cur, 0); /* terminate next time */
1806 /* integer increment */
1807 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1810 #ifndef USE_5005THREADS /* don't risk potential race */
1811 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1812 /* safe to reuse old SV */
1813 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1818 /* we need a fresh SV every time so that loop body sees a
1819 * completely new SV for closures/references to work as they
1821 SvREFCNT_dec(*itersvp);
1822 *itersvp = newSViv(cx->blk_loop.iterix++);
1828 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1831 SvREFCNT_dec(*itersvp);
1833 if (SvMAGICAL(av) || AvREIFY(av)) {
1834 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1841 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1847 if (av != PL_curstack && sv == &PL_sv_undef) {
1848 SV *lv = cx->blk_loop.iterlval;
1849 if (lv && SvREFCNT(lv) > 1) {
1854 SvREFCNT_dec(LvTARG(lv));
1856 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1857 sv_upgrade(lv, SVt_PVLV);
1859 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1861 LvTARG(lv) = SvREFCNT_inc(av);
1862 LvTARGOFF(lv) = cx->blk_loop.iterix;
1863 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1867 *itersvp = SvREFCNT_inc(sv);
1874 register PMOP *pm = cPMOP;
1890 register REGEXP *rx = PM_GETRE(pm);
1892 int force_on_match = 0;
1893 I32 oldsave = PL_savestack_ix;
1896 /* known replacement string? */
1897 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1898 if (PL_op->op_flags & OPf_STACKED)
1905 if (SvFAKE(TARG) && SvREADONLY(TARG))
1906 sv_force_normal(TARG);
1907 if (SvREADONLY(TARG)
1908 || (SvTYPE(TARG) > SVt_PVLV
1909 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1910 DIE(aTHX_ PL_no_modify);
1913 s = SvPV(TARG, len);
1914 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1916 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1917 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1922 PL_reg_match_utf8 = DO_UTF8(TARG);
1926 DIE(aTHX_ "panic: pp_subst");
1929 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1930 maxiters = 2 * slen + 10; /* We can match twice at each
1931 position, once with zero-length,
1932 second time with non-zero. */
1934 if (!rx->prelen && PL_curpm) {
1938 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1939 ? REXEC_COPY_STR : 0;
1941 r_flags |= REXEC_SCREAM;
1942 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1943 SAVEINT(PL_multiline);
1944 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1947 if (rx->reganch & RE_USE_INTUIT) {
1949 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1953 /* How to do it in subst? */
1954 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1956 && ((rx->reganch & ROPT_NOSCAN)
1957 || !((rx->reganch & RE_INTUIT_TAIL)
1958 && (r_flags & REXEC_SCREAM))))
1963 /* only replace once? */
1964 once = !(rpm->op_pmflags & PMf_GLOBAL);
1966 /* known replacement string? */
1967 c = dstr ? SvPV(dstr, clen) : Nullch;
1969 /* can do inplace substitution? */
1970 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1971 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1972 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1973 r_flags | REXEC_CHECKED))
1977 LEAVE_SCOPE(oldsave);
1980 if (force_on_match) {
1982 s = SvPV_force(TARG, len);
1987 SvSCREAM_off(TARG); /* disable possible screamer */
1989 rxtainted |= RX_MATCH_TAINTED(rx);
1990 m = orig + rx->startp[0];
1991 d = orig + rx->endp[0];
1993 if (m - s > strend - d) { /* faster to shorten from end */
1995 Copy(c, m, clen, char);
2000 Move(d, m, i, char);
2004 SvCUR_set(TARG, m - s);
2007 else if ((i = m - s)) { /* faster from front */
2015 Copy(c, m, clen, char);
2020 Copy(c, d, clen, char);
2025 TAINT_IF(rxtainted & 1);
2031 if (iters++ > maxiters)
2032 DIE(aTHX_ "Substitution loop");
2033 rxtainted |= RX_MATCH_TAINTED(rx);
2034 m = rx->startp[0] + orig;
2038 Move(s, d, i, char);
2042 Copy(c, d, clen, char);
2045 s = rx->endp[0] + orig;
2046 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2048 /* don't match same null twice */
2049 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2052 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2053 Move(s, d, i+1, char); /* include the NUL */
2055 TAINT_IF(rxtainted & 1);
2057 PUSHs(sv_2mortal(newSViv((I32)iters)));
2059 (void)SvPOK_only_UTF8(TARG);
2060 TAINT_IF(rxtainted);
2061 if (SvSMAGICAL(TARG)) {
2067 LEAVE_SCOPE(oldsave);
2071 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2072 r_flags | REXEC_CHECKED))
2076 if (force_on_match) {
2078 s = SvPV_force(TARG, len);
2081 rxtainted |= RX_MATCH_TAINTED(rx);
2082 dstr = NEWSV(25, len);
2083 sv_setpvn(dstr, m, s-m);
2088 register PERL_CONTEXT *cx;
2091 RETURNOP(cPMOP->op_pmreplroot);
2093 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2095 if (iters++ > maxiters)
2096 DIE(aTHX_ "Substitution loop");
2097 rxtainted |= RX_MATCH_TAINTED(rx);
2098 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2103 strend = s + (strend - m);
2105 m = rx->startp[0] + orig;
2106 sv_catpvn(dstr, s, m-s);
2107 s = rx->endp[0] + orig;
2109 sv_catpvn(dstr, c, clen);
2112 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2113 TARG, NULL, r_flags));
2114 sv_catpvn(dstr, s, strend - s);
2116 (void)SvOOK_off(TARG);
2117 Safefree(SvPVX(TARG));
2118 SvPVX(TARG) = SvPVX(dstr);
2119 SvCUR_set(TARG, SvCUR(dstr));
2120 SvLEN_set(TARG, SvLEN(dstr));
2121 isutf8 = DO_UTF8(dstr);
2125 TAINT_IF(rxtainted & 1);
2127 PUSHs(sv_2mortal(newSViv((I32)iters)));
2129 (void)SvPOK_only(TARG);
2132 TAINT_IF(rxtainted);
2135 LEAVE_SCOPE(oldsave);
2144 LEAVE_SCOPE(oldsave);
2153 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2154 ++*PL_markstack_ptr;
2155 LEAVE; /* exit inner scope */
2158 if (PL_stack_base + *PL_markstack_ptr > SP) {
2160 I32 gimme = GIMME_V;
2162 LEAVE; /* exit outer scope */
2163 (void)POPMARK; /* pop src */
2164 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2165 (void)POPMARK; /* pop dst */
2166 SP = PL_stack_base + POPMARK; /* pop original mark */
2167 if (gimme == G_SCALAR) {
2171 else if (gimme == G_ARRAY)
2178 ENTER; /* enter inner scope */
2181 src = PL_stack_base[*PL_markstack_ptr];
2185 RETURNOP(cLOGOP->op_other);
2196 register PERL_CONTEXT *cx;
2202 if (gimme == G_SCALAR) {
2205 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2207 *MARK = SvREFCNT_inc(TOPs);
2212 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2214 *MARK = sv_mortalcopy(sv);
2219 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2223 *MARK = &PL_sv_undef;
2227 else if (gimme == G_ARRAY) {
2228 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2229 if (!SvTEMP(*MARK)) {
2230 *MARK = sv_mortalcopy(*MARK);
2231 TAINT_NOT; /* Each item is independent */
2237 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2238 PL_curpm = newpm; /* ... and pop $1 et al */
2242 return pop_return();
2245 /* This duplicates the above code because the above code must not
2246 * get any slower by more conditions */
2254 register PERL_CONTEXT *cx;
2261 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2262 /* We are an argument to a function or grep().
2263 * This kind of lvalueness was legal before lvalue
2264 * subroutines too, so be backward compatible:
2265 * cannot report errors. */
2267 /* Scalar context *is* possible, on the LHS of -> only,
2268 * as in f()->meth(). But this is not an lvalue. */
2269 if (gimme == G_SCALAR)
2271 if (gimme == G_ARRAY) {
2272 if (!CvLVALUE(cx->blk_sub.cv))
2273 goto temporise_array;
2274 EXTEND_MORTAL(SP - newsp);
2275 for (mark = newsp + 1; mark <= SP; mark++) {
2278 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2279 *mark = sv_mortalcopy(*mark);
2281 /* Can be a localized value subject to deletion. */
2282 PL_tmps_stack[++PL_tmps_ix] = *mark;
2283 (void)SvREFCNT_inc(*mark);
2288 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2289 /* Here we go for robustness, not for speed, so we change all
2290 * the refcounts so the caller gets a live guy. Cannot set
2291 * TEMP, so sv_2mortal is out of question. */
2292 if (!CvLVALUE(cx->blk_sub.cv)) {
2297 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2299 if (gimme == G_SCALAR) {
2303 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2308 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2309 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2311 else { /* Can be a localized value
2312 * subject to deletion. */
2313 PL_tmps_stack[++PL_tmps_ix] = *mark;
2314 (void)SvREFCNT_inc(*mark);
2317 else { /* Should not happen? */
2322 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2323 (MARK > SP ? "Empty array" : "Array"));
2327 else if (gimme == G_ARRAY) {
2328 EXTEND_MORTAL(SP - newsp);
2329 for (mark = newsp + 1; mark <= SP; mark++) {
2330 if (*mark != &PL_sv_undef
2331 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2332 /* Might be flattened array after $#array = */
2338 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2339 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2342 /* Can be a localized value subject to deletion. */
2343 PL_tmps_stack[++PL_tmps_ix] = *mark;
2344 (void)SvREFCNT_inc(*mark);
2350 if (gimme == G_SCALAR) {
2354 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2356 *MARK = SvREFCNT_inc(TOPs);
2361 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2363 *MARK = sv_mortalcopy(sv);
2368 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2372 *MARK = &PL_sv_undef;
2376 else if (gimme == G_ARRAY) {
2378 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2379 if (!SvTEMP(*MARK)) {
2380 *MARK = sv_mortalcopy(*MARK);
2381 TAINT_NOT; /* Each item is independent */
2388 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2389 PL_curpm = newpm; /* ... and pop $1 et al */
2393 return pop_return();
2398 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2400 SV *dbsv = GvSV(PL_DBsub);
2402 if (!PERLDB_SUB_NN) {
2406 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2407 || strEQ(GvNAME(gv), "END")
2408 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2409 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2410 && (gv = (GV*)*svp) ))) {
2411 /* Use GV from the stack as a fallback. */
2412 /* GV is potentially non-unique, or contain different CV. */
2413 SV *tmp = newRV((SV*)cv);
2414 sv_setsv(dbsv, tmp);
2418 gv_efullname3(dbsv, gv, Nullch);
2422 (void)SvUPGRADE(dbsv, SVt_PVIV);
2423 (void)SvIOK_on(dbsv);
2424 SAVEIV(SvIVX(dbsv));
2425 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2429 PL_curcopdb = PL_curcop;
2430 cv = GvCV(PL_DBsub);
2440 register PERL_CONTEXT *cx;
2442 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2445 DIE(aTHX_ "Not a CODE reference");
2446 switch (SvTYPE(sv)) {
2452 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2454 SP = PL_stack_base + POPMARK;
2457 if (SvGMAGICAL(sv)) {
2461 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2464 sym = SvPV(sv, n_a);
2466 DIE(aTHX_ PL_no_usym, "a subroutine");
2467 if (PL_op->op_private & HINT_STRICT_REFS)
2468 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2469 cv = get_cv(sym, TRUE);
2474 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2475 tryAMAGICunDEREF(to_cv);
2478 if (SvTYPE(cv) == SVt_PVCV)
2483 DIE(aTHX_ "Not a CODE reference");
2488 if (!(cv = GvCVu((GV*)sv)))
2489 cv = sv_2cv(sv, &stash, &gv, FALSE);
2502 if (!CvROOT(cv) && !CvXSUB(cv)) {
2506 /* anonymous or undef'd function leaves us no recourse */
2507 if (CvANON(cv) || !(gv = CvGV(cv)))
2508 DIE(aTHX_ "Undefined subroutine called");
2510 /* autoloaded stub? */
2511 if (cv != GvCV(gv)) {
2514 /* should call AUTOLOAD now? */
2517 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2524 sub_name = sv_newmortal();
2525 gv_efullname3(sub_name, gv, Nullch);
2526 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2530 DIE(aTHX_ "Not a CODE reference");
2535 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2536 cv = get_db_sub(&sv, cv);
2538 DIE(aTHX_ "No DBsub routine");
2541 #ifdef USE_5005THREADS
2543 * First we need to check if the sub or method requires locking.
2544 * If so, we gain a lock on the CV, the first argument or the
2545 * stash (for static methods), as appropriate. This has to be
2546 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2547 * reschedule by returning a new op.
2549 MUTEX_LOCK(CvMUTEXP(cv));
2550 if (CvFLAGS(cv) & CVf_LOCKED) {
2552 if (CvFLAGS(cv) & CVf_METHOD) {
2553 if (SP > PL_stack_base + TOPMARK)
2554 sv = *(PL_stack_base + TOPMARK + 1);
2556 AV *av = (AV*)PL_curpad[0];
2557 if (hasargs || !av || AvFILLp(av) < 0
2558 || !(sv = AvARRAY(av)[0]))
2560 MUTEX_UNLOCK(CvMUTEXP(cv));
2561 DIE(aTHX_ "no argument for locked method call");
2568 char *stashname = SvPV(sv, len);
2569 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2575 MUTEX_UNLOCK(CvMUTEXP(cv));
2576 mg = condpair_magic(sv);
2577 MUTEX_LOCK(MgMUTEXP(mg));
2578 if (MgOWNER(mg) == thr)
2579 MUTEX_UNLOCK(MgMUTEXP(mg));
2582 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2584 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2586 MUTEX_UNLOCK(MgMUTEXP(mg));
2587 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2589 MUTEX_LOCK(CvMUTEXP(cv));
2592 * Now we have permission to enter the sub, we must distinguish
2593 * four cases. (0) It's an XSUB (in which case we don't care
2594 * about ownership); (1) it's ours already (and we're recursing);
2595 * (2) it's free (but we may already be using a cached clone);
2596 * (3) another thread owns it. Case (1) is easy: we just use it.
2597 * Case (2) means we look for a clone--if we have one, use it
2598 * otherwise grab ownership of cv. Case (3) means we look for a
2599 * clone (for non-XSUBs) and have to create one if we don't
2601 * Why look for a clone in case (2) when we could just grab
2602 * ownership of cv straight away? Well, we could be recursing,
2603 * i.e. we originally tried to enter cv while another thread
2604 * owned it (hence we used a clone) but it has been freed up
2605 * and we're now recursing into it. It may or may not be "better"
2606 * to use the clone but at least CvDEPTH can be trusted.
2608 if (CvOWNER(cv) == thr || CvXSUB(cv))
2609 MUTEX_UNLOCK(CvMUTEXP(cv));
2611 /* Case (2) or (3) */
2615 * XXX Might it be better to release CvMUTEXP(cv) while we
2616 * do the hv_fetch? We might find someone has pinched it
2617 * when we look again, in which case we would be in case
2618 * (3) instead of (2) so we'd have to clone. Would the fact
2619 * that we released the mutex more quickly make up for this?
2621 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2623 /* We already have a clone to use */
2624 MUTEX_UNLOCK(CvMUTEXP(cv));
2626 DEBUG_S(PerlIO_printf(Perl_debug_log,
2627 "entersub: %p already has clone %p:%s\n",
2628 thr, cv, SvPEEK((SV*)cv)));
2631 if (CvDEPTH(cv) == 0)
2632 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2635 /* (2) => grab ownership of cv. (3) => make clone */
2639 MUTEX_UNLOCK(CvMUTEXP(cv));
2640 DEBUG_S(PerlIO_printf(Perl_debug_log,
2641 "entersub: %p grabbing %p:%s in stash %s\n",
2642 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2643 HvNAME(CvSTASH(cv)) : "(none)"));
2646 /* Make a new clone. */
2648 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2649 MUTEX_UNLOCK(CvMUTEXP(cv));
2650 DEBUG_S((PerlIO_printf(Perl_debug_log,
2651 "entersub: %p cloning %p:%s\n",
2652 thr, cv, SvPEEK((SV*)cv))));
2654 * We're creating a new clone so there's no race
2655 * between the original MUTEX_UNLOCK and the
2656 * SvREFCNT_inc since no one will be trying to undef
2657 * it out from underneath us. At least, I don't think
2660 clonecv = cv_clone(cv);
2661 SvREFCNT_dec(cv); /* finished with this */
2662 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2663 CvOWNER(clonecv) = thr;
2667 DEBUG_S(if (CvDEPTH(cv) != 0)
2668 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2670 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2673 #endif /* USE_5005THREADS */
2676 #ifdef PERL_XSUB_OLDSTYLE
2677 if (CvOLDSTYLE(cv)) {
2678 I32 (*fp3)(int,int,int);
2680 register I32 items = SP - MARK;
2681 /* We dont worry to copy from @_. */
2686 PL_stack_sp = mark + 1;
2687 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2688 items = (*fp3)(CvXSUBANY(cv).any_i32,
2689 MARK - PL_stack_base + 1,
2691 PL_stack_sp = PL_stack_base + items;
2694 #endif /* PERL_XSUB_OLDSTYLE */
2696 I32 markix = TOPMARK;
2701 /* Need to copy @_ to stack. Alternative may be to
2702 * switch stack to @_, and copy return values
2703 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2706 #ifdef USE_5005THREADS
2707 av = (AV*)PL_curpad[0];
2709 av = GvAV(PL_defgv);
2710 #endif /* USE_5005THREADS */
2711 items = AvFILLp(av) + 1; /* @_ is not tieable */
2714 /* Mark is at the end of the stack. */
2716 Copy(AvARRAY(av), SP + 1, items, SV*);
2721 /* We assume first XSUB in &DB::sub is the called one. */
2723 SAVEVPTR(PL_curcop);
2724 PL_curcop = PL_curcopdb;
2727 /* Do we need to open block here? XXXX */
2728 (void)(*CvXSUB(cv))(aTHX_ cv);
2730 /* Enforce some sanity in scalar context. */
2731 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2732 if (markix > PL_stack_sp - PL_stack_base)
2733 *(PL_stack_base + markix) = &PL_sv_undef;
2735 *(PL_stack_base + markix) = *PL_stack_sp;
2736 PL_stack_sp = PL_stack_base + markix;
2744 register I32 items = SP - MARK;
2745 AV* padlist = CvPADLIST(cv);
2746 SV** svp = AvARRAY(padlist);
2747 push_return(PL_op->op_next);
2748 PUSHBLOCK(cx, CXt_SUB, MARK);
2751 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2752 * that eval'' ops within this sub know the correct lexical space.
2753 * Owing the speed considerations, we choose to search for the cv
2754 * in doeval() instead.
2756 if (CvDEPTH(cv) < 2)
2757 (void)SvREFCNT_inc(cv);
2758 else { /* save temporaries on recursion? */
2759 PERL_STACK_OVERFLOW_CHECK();
2760 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2762 AV *newpad = newAV();
2763 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2764 I32 ix = AvFILLp((AV*)svp[1]);
2765 I32 names_fill = AvFILLp((AV*)svp[0]);
2766 svp = AvARRAY(svp[0]);
2767 for ( ;ix > 0; ix--) {
2768 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2769 char *name = SvPVX(svp[ix]);
2770 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2771 || *name == '&') /* anonymous code? */
2773 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2775 else { /* our own lexical */
2777 av_store(newpad, ix, sv = (SV*)newAV());
2778 else if (*name == '%')
2779 av_store(newpad, ix, sv = (SV*)newHV());
2781 av_store(newpad, ix, sv = NEWSV(0,0));
2785 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2786 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2789 av_store(newpad, ix, sv = NEWSV(0,0));
2793 av = newAV(); /* will be @_ */
2795 av_store(newpad, 0, (SV*)av);
2796 AvFLAGS(av) = AVf_REIFY;
2797 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2798 AvFILLp(padlist) = CvDEPTH(cv);
2799 svp = AvARRAY(padlist);
2802 #ifdef USE_5005THREADS
2804 AV* av = (AV*)PL_curpad[0];
2806 items = AvFILLp(av) + 1;
2808 /* Mark is at the end of the stack. */
2810 Copy(AvARRAY(av), SP + 1, items, SV*);
2815 #endif /* USE_5005THREADS */
2816 SAVEVPTR(PL_curpad);
2817 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2818 #ifndef USE_5005THREADS
2820 #endif /* USE_5005THREADS */
2826 DEBUG_S(PerlIO_printf(Perl_debug_log,
2827 "%p entersub preparing @_\n", thr));
2829 av = (AV*)PL_curpad[0];
2831 /* @_ is normally not REAL--this should only ever
2832 * happen when DB::sub() calls things that modify @_ */
2837 #ifndef USE_5005THREADS
2838 cx->blk_sub.savearray = GvAV(PL_defgv);
2839 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2840 #endif /* USE_5005THREADS */
2841 cx->blk_sub.oldcurpad = PL_curpad;
2842 cx->blk_sub.argarray = av;
2845 if (items > AvMAX(av) + 1) {
2847 if (AvARRAY(av) != ary) {
2848 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2849 SvPVX(av) = (char*)ary;
2851 if (items > AvMAX(av) + 1) {
2852 AvMAX(av) = items - 1;
2853 Renew(ary,items,SV*);
2855 SvPVX(av) = (char*)ary;
2858 Copy(MARK,AvARRAY(av),items,SV*);
2859 AvFILLp(av) = items - 1;
2867 /* warning must come *after* we fully set up the context
2868 * stuff so that __WARN__ handlers can safely dounwind()
2871 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2872 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2873 sub_crush_depth(cv);
2875 DEBUG_S(PerlIO_printf(Perl_debug_log,
2876 "%p entersub returning %p\n", thr, CvSTART(cv)));
2878 RETURNOP(CvSTART(cv));
2883 Perl_sub_crush_depth(pTHX_ CV *cv)
2886 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2888 SV* tmpstr = sv_newmortal();
2889 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2890 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2900 IV elem = SvIV(elemsv);
2902 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2903 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2906 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2907 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2909 elem -= PL_curcop->cop_arybase;
2910 if (SvTYPE(av) != SVt_PVAV)
2912 svp = av_fetch(av, elem, lval && !defer);
2914 if (!svp || *svp == &PL_sv_undef) {
2917 DIE(aTHX_ PL_no_aelem, elem);
2918 lv = sv_newmortal();
2919 sv_upgrade(lv, SVt_PVLV);
2921 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2922 LvTARG(lv) = SvREFCNT_inc(av);
2923 LvTARGOFF(lv) = elem;
2928 if (PL_op->op_private & OPpLVAL_INTRO)
2929 save_aelem(av, elem, svp);
2930 else if (PL_op->op_private & OPpDEREF)
2931 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2933 sv = (svp ? *svp : &PL_sv_undef);
2934 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2935 sv = sv_mortalcopy(sv);
2941 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2947 Perl_croak(aTHX_ PL_no_modify);
2948 if (SvTYPE(sv) < SVt_RV)
2949 sv_upgrade(sv, SVt_RV);
2950 else if (SvTYPE(sv) >= SVt_PV) {
2951 (void)SvOOK_off(sv);
2952 Safefree(SvPVX(sv));
2953 SvLEN(sv) = SvCUR(sv) = 0;
2957 SvRV(sv) = NEWSV(355,0);
2960 SvRV(sv) = (SV*)newAV();
2963 SvRV(sv) = (SV*)newHV();
2978 if (SvTYPE(rsv) == SVt_PVCV) {
2984 SETs(method_common(sv, Null(U32*)));
2991 SV* sv = cSVOP->op_sv;
2992 U32 hash = SvUVX(sv);
2994 XPUSHs(method_common(sv, &hash));
2999 S_method_common(pTHX_ SV* meth, U32* hashp)
3010 name = SvPV(meth, namelen);
3011 sv = *(PL_stack_base + TOPMARK + 1);
3014 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3023 /* this isn't a reference */
3026 !(packname = SvPV(sv, packlen)) ||
3027 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3028 !(ob=(SV*)GvIO(iogv)))
3030 /* this isn't the name of a filehandle either */
3032 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3033 ? !isIDFIRST_utf8((U8*)packname)
3034 : !isIDFIRST(*packname)
3037 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3038 SvOK(sv) ? "without a package or object reference"
3039 : "on an undefined value");
3041 /* assume it's a package name */
3042 stash = gv_stashpvn(packname, packlen, FALSE);
3045 /* it _is_ a filehandle name -- replace with a reference */
3046 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3049 /* if we got here, ob should be a reference or a glob */
3050 if (!ob || !(SvOBJECT(ob)
3051 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3054 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3058 stash = SvSTASH(ob);
3061 /* NOTE: stash may be null, hope hv_fetch_ent and
3062 gv_fetchmethod can cope (it seems they can) */
3064 /* shortcut for simple names */
3066 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3068 gv = (GV*)HeVAL(he);
3069 if (isGV(gv) && GvCV(gv) &&
3070 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3071 return (SV*)GvCV(gv);
3075 gv = gv_fetchmethod(stash, name);
3078 /* This code tries to figure out just what went wrong with
3079 gv_fetchmethod. It therefore needs to duplicate a lot of
3080 the internals of that function. We can't move it inside
3081 Perl_gv_fetchmethod_autoload(), however, since that would
3082 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3089 for (p = name; *p; p++) {
3091 sep = p, leaf = p + 1;
3092 else if (*p == ':' && *(p + 1) == ':')
3093 sep = p, leaf = p + 2;
3095 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3096 /* the method name is unqualified or starts with SUPER:: */
3097 packname = sep ? CopSTASHPV(PL_curcop) :
3098 stash ? HvNAME(stash) : packname;
3099 packlen = strlen(packname);
3102 /* the method name is qualified */
3104 packlen = sep - name;
3107 /* we're relying on gv_fetchmethod not autovivifying the stash */
3108 if (gv_stashpvn(packname, packlen, FALSE)) {
3110 "Can't locate object method \"%s\" via package \"%.*s\"",
3111 leaf, (int)packlen, packname);
3115 "Can't locate object method \"%s\" via package \"%.*s\""
3116 " (perhaps you forgot to load \"%.*s\"?)",
3117 leaf, (int)packlen, packname, (int)packlen, packname);
3120 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3123 #ifdef USE_5005THREADS
3125 unset_cvowner(pTHX_ void *cvarg)
3127 register CV* cv = (CV *) cvarg;
3129 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3130 thr, cv, SvPEEK((SV*)cv))));
3131 MUTEX_LOCK(CvMUTEXP(cv));
3132 DEBUG_S(if (CvDEPTH(cv) != 0)
3133 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3135 assert(thr == CvOWNER(cv));
3137 MUTEX_UNLOCK(CvMUTEXP(cv));
3140 #endif /* USE_5005THREADS */