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 (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
306 DIE(aTHX_ PL_no_modify);
307 if (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) goto failure;
1242 /* XXXX What part of this is needed with true \G-support? */
1243 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1245 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1246 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1247 if (mg && mg->mg_len >= 0) {
1248 if (!(rx->reganch & ROPT_GPOS_SEEN))
1249 rx->endp[0] = rx->startp[0] = mg->mg_len;
1250 else if (rx->reganch & ROPT_ANCH_GPOS) {
1251 r_flags |= REXEC_IGNOREPOS;
1252 rx->endp[0] = rx->startp[0] = mg->mg_len;
1254 minmatch = (mg->mg_flags & MGf_MINMATCH);
1255 update_minmatch = 0;
1259 if ((!global && rx->nparens)
1260 || SvTEMP(TARG) || PL_sawampersand)
1261 r_flags |= REXEC_COPY_STR;
1263 r_flags |= REXEC_SCREAM;
1265 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1266 SAVEINT(PL_multiline);
1267 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1271 if (global && rx->startp[0] != -1) {
1272 t = s = rx->endp[0] + truebase;
1273 if ((s + rx->minlen) > strend)
1275 if (update_minmatch++)
1276 minmatch = had_zerolen;
1278 if (rx->reganch & RE_USE_INTUIT &&
1279 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1280 PL_bostr = truebase;
1281 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1285 if ( (rx->reganch & ROPT_CHECK_ALL)
1287 && ((rx->reganch & ROPT_NOSCAN)
1288 || !((rx->reganch & RE_INTUIT_TAIL)
1289 && (r_flags & REXEC_SCREAM)))
1290 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1293 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1296 if (pm->op_pmflags & PMf_ONCE)
1297 pm->op_pmdynflags |= PMdf_USED;
1306 RX_MATCH_TAINTED_on(rx);
1307 TAINT_IF(RX_MATCH_TAINTED(rx));
1308 if (gimme == G_ARRAY) {
1309 I32 nparens, i, len;
1311 nparens = rx->nparens;
1312 if (global && !nparens)
1316 SPAGAIN; /* EVAL blocks could move the stack. */
1317 EXTEND(SP, nparens + i);
1318 EXTEND_MORTAL(nparens + i);
1319 for (i = !i; i <= nparens; i++) {
1320 PUSHs(sv_newmortal());
1322 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1323 len = rx->endp[i] - rx->startp[i];
1324 s = rx->startp[i] + truebase;
1325 sv_setpvn(*SP, s, len);
1326 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1331 if (pm->op_pmflags & PMf_CONTINUE) {
1333 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1334 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1336 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1337 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1339 if (rx->startp[0] != -1) {
1340 mg->mg_len = rx->endp[0];
1341 if (rx->startp[0] == rx->endp[0])
1342 mg->mg_flags |= MGf_MINMATCH;
1344 mg->mg_flags &= ~MGf_MINMATCH;
1347 had_zerolen = (rx->startp[0] != -1
1348 && rx->startp[0] == rx->endp[0]);
1349 PUTBACK; /* EVAL blocks may use stack */
1350 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1355 LEAVE_SCOPE(oldsave);
1361 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1362 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1364 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1365 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1367 if (rx->startp[0] != -1) {
1368 mg->mg_len = rx->endp[0];
1369 if (rx->startp[0] == rx->endp[0])
1370 mg->mg_flags |= MGf_MINMATCH;
1372 mg->mg_flags &= ~MGf_MINMATCH;
1375 LEAVE_SCOPE(oldsave);
1379 yup: /* Confirmed by INTUIT */
1381 RX_MATCH_TAINTED_on(rx);
1382 TAINT_IF(RX_MATCH_TAINTED(rx));
1384 if (pm->op_pmflags & PMf_ONCE)
1385 pm->op_pmdynflags |= PMdf_USED;
1386 if (RX_MATCH_COPIED(rx))
1387 Safefree(rx->subbeg);
1388 RX_MATCH_COPIED_off(rx);
1389 rx->subbeg = Nullch;
1391 rx->subbeg = truebase;
1392 rx->startp[0] = s - truebase;
1393 if (PL_reg_match_utf8) {
1394 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1395 rx->endp[0] = t - truebase;
1398 rx->endp[0] = s - truebase + rx->minlen;
1400 rx->sublen = strend - truebase;
1403 if (PL_sawampersand) {
1406 rx->subbeg = savepvn(t, strend - t);
1407 rx->sublen = strend - t;
1408 RX_MATCH_COPIED_on(rx);
1409 off = rx->startp[0] = s - t;
1410 rx->endp[0] = off + rx->minlen;
1412 else { /* startp/endp are used by @- @+. */
1413 rx->startp[0] = s - truebase;
1414 rx->endp[0] = s - truebase + rx->minlen;
1416 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1417 LEAVE_SCOPE(oldsave);
1422 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1423 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1424 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1429 LEAVE_SCOPE(oldsave);
1430 if (gimme == G_ARRAY)
1436 Perl_do_readline(pTHX)
1438 dSP; dTARGETSTACKED;
1443 register IO *io = GvIO(PL_last_in_gv);
1444 register I32 type = PL_op->op_type;
1445 I32 gimme = GIMME_V;
1448 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1450 XPUSHs(SvTIED_obj((SV*)io, mg));
1453 call_method("READLINE", gimme);
1456 if (gimme == G_SCALAR)
1457 SvSetMagicSV_nosteal(TARG, TOPs);
1464 if (IoFLAGS(io) & IOf_ARGV) {
1465 if (IoFLAGS(io) & IOf_START) {
1467 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1468 IoFLAGS(io) &= ~IOf_START;
1469 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1470 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1471 SvSETMAGIC(GvSV(PL_last_in_gv));
1476 fp = nextargv(PL_last_in_gv);
1477 if (!fp) { /* Note: fp != IoIFP(io) */
1478 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1481 else if (type == OP_GLOB)
1482 fp = Perl_start_glob(aTHX_ POPs, io);
1484 else if (type == OP_GLOB)
1486 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1487 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1491 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1492 && (!io || !(IoFLAGS(io) & IOf_START))) {
1493 if (type == OP_GLOB)
1494 Perl_warner(aTHX_ WARN_GLOB,
1495 "glob failed (can't start child: %s)",
1498 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1500 if (gimme == G_SCALAR) {
1501 (void)SvOK_off(TARG);
1507 if (gimme == G_SCALAR) {
1511 (void)SvUPGRADE(sv, SVt_PV);
1512 tmplen = SvLEN(sv); /* remember if already alloced */
1514 Sv_Grow(sv, 80); /* try short-buffering it */
1515 if (type == OP_RCATLINE)
1521 sv = sv_2mortal(NEWSV(57, 80));
1525 /* This should not be marked tainted if the fp is marked clean */
1526 #define MAYBE_TAINT_LINE(io, sv) \
1527 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1532 /* delay EOF state for a snarfed empty file */
1533 #define SNARF_EOF(gimme,rs,io,sv) \
1534 (gimme != G_SCALAR || SvCUR(sv) \
1535 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1539 if (!sv_gets(sv, fp, offset)
1540 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1542 PerlIO_clearerr(fp);
1543 if (IoFLAGS(io) & IOf_ARGV) {
1544 fp = nextargv(PL_last_in_gv);
1547 (void)do_close(PL_last_in_gv, FALSE);
1549 else if (type == OP_GLOB) {
1550 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1551 Perl_warner(aTHX_ WARN_GLOB,
1552 "glob failed (child exited with status %d%s)",
1553 (int)(STATUS_CURRENT >> 8),
1554 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1557 if (gimme == G_SCALAR) {
1558 (void)SvOK_off(TARG);
1562 MAYBE_TAINT_LINE(io, sv);
1565 MAYBE_TAINT_LINE(io, sv);
1567 IoFLAGS(io) |= IOf_NOLINE;
1571 if (type == OP_GLOB) {
1574 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1575 tmps = SvEND(sv) - 1;
1576 if (*tmps == *SvPVX(PL_rs)) {
1581 for (tmps = SvPVX(sv); *tmps; tmps++)
1582 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1583 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1585 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1586 (void)POPs; /* Unmatched wildcard? Chuck it... */
1590 if (gimme == G_ARRAY) {
1591 if (SvLEN(sv) - SvCUR(sv) > 20) {
1592 SvLEN_set(sv, SvCUR(sv)+1);
1593 Renew(SvPVX(sv), SvLEN(sv), char);
1595 sv = sv_2mortal(NEWSV(58, 80));
1598 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1599 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1603 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1604 Renew(SvPVX(sv), SvLEN(sv), char);
1613 register PERL_CONTEXT *cx;
1614 I32 gimme = OP_GIMME(PL_op, -1);
1617 if (cxstack_ix >= 0)
1618 gimme = cxstack[cxstack_ix].blk_gimme;
1626 PUSHBLOCK(cx, CXt_BLOCK, SP);
1638 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1639 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1641 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1644 if (SvTYPE(hv) == SVt_PVHV) {
1645 if (PL_op->op_private & OPpLVAL_INTRO)
1646 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1647 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1648 svp = he ? &HeVAL(he) : 0;
1650 else if (SvTYPE(hv) == SVt_PVAV) {
1651 if (PL_op->op_private & OPpLVAL_INTRO)
1652 DIE(aTHX_ "Can't localize pseudo-hash element");
1653 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1659 if (!svp || *svp == &PL_sv_undef) {
1664 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1666 lv = sv_newmortal();
1667 sv_upgrade(lv, SVt_PVLV);
1669 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1670 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1671 LvTARG(lv) = SvREFCNT_inc(hv);
1676 if (PL_op->op_private & OPpLVAL_INTRO) {
1677 if (HvNAME(hv) && isGV(*svp))
1678 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1682 char *key = SvPV(keysv, keylen);
1683 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1685 save_helem(hv, keysv, svp);
1688 else if (PL_op->op_private & OPpDEREF)
1689 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1691 sv = (svp ? *svp : &PL_sv_undef);
1692 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1693 * Pushing the magical RHS on to the stack is useless, since
1694 * that magic is soon destined to be misled by the local(),
1695 * and thus the later pp_sassign() will fail to mg_get() the
1696 * old value. This should also cure problems with delayed
1697 * mg_get()s. GSAR 98-07-03 */
1698 if (!lval && SvGMAGICAL(sv))
1699 sv = sv_mortalcopy(sv);
1707 register PERL_CONTEXT *cx;
1713 if (PL_op->op_flags & OPf_SPECIAL) {
1714 cx = &cxstack[cxstack_ix];
1715 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1720 gimme = OP_GIMME(PL_op, -1);
1722 if (cxstack_ix >= 0)
1723 gimme = cxstack[cxstack_ix].blk_gimme;
1729 if (gimme == G_VOID)
1731 else if (gimme == G_SCALAR) {
1734 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1737 *MARK = sv_mortalcopy(TOPs);
1740 *MARK = &PL_sv_undef;
1744 else if (gimme == G_ARRAY) {
1745 /* in case LEAVE wipes old return values */
1746 for (mark = newsp + 1; mark <= SP; mark++) {
1747 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1748 *mark = sv_mortalcopy(*mark);
1749 TAINT_NOT; /* Each item is independent */
1753 PL_curpm = newpm; /* Don't pop $1 et al till now */
1763 register PERL_CONTEXT *cx;
1769 cx = &cxstack[cxstack_ix];
1770 if (CxTYPE(cx) != CXt_LOOP)
1771 DIE(aTHX_ "panic: pp_iter");
1773 itersvp = CxITERVAR(cx);
1774 av = cx->blk_loop.iterary;
1775 if (SvTYPE(av) != SVt_PVAV) {
1776 /* iterate ($min .. $max) */
1777 if (cx->blk_loop.iterlval) {
1778 /* string increment */
1779 register SV* cur = cx->blk_loop.iterlval;
1781 char *max = SvPV((SV*)av, maxlen);
1782 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1783 #ifndef USE_5005THREADS /* don't risk potential race */
1784 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1785 /* safe to reuse old SV */
1786 sv_setsv(*itersvp, cur);
1791 /* we need a fresh SV every time so that loop body sees a
1792 * completely new SV for closures/references to work as
1794 SvREFCNT_dec(*itersvp);
1795 *itersvp = newSVsv(cur);
1797 if (strEQ(SvPVX(cur), max))
1798 sv_setiv(cur, 0); /* terminate next time */
1805 /* integer increment */
1806 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1809 #ifndef USE_5005THREADS /* don't risk potential race */
1810 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1811 /* safe to reuse old SV */
1812 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1817 /* we need a fresh SV every time so that loop body sees a
1818 * completely new SV for closures/references to work as they
1820 SvREFCNT_dec(*itersvp);
1821 *itersvp = newSViv(cx->blk_loop.iterix++);
1827 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1830 SvREFCNT_dec(*itersvp);
1832 if (SvMAGICAL(av) || AvREIFY(av)) {
1833 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1840 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1846 if (av != PL_curstack && sv == &PL_sv_undef) {
1847 SV *lv = cx->blk_loop.iterlval;
1848 if (lv && SvREFCNT(lv) > 1) {
1853 SvREFCNT_dec(LvTARG(lv));
1855 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1856 sv_upgrade(lv, SVt_PVLV);
1858 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1860 LvTARG(lv) = SvREFCNT_inc(av);
1861 LvTARGOFF(lv) = cx->blk_loop.iterix;
1862 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1866 *itersvp = SvREFCNT_inc(sv);
1873 register PMOP *pm = cPMOP;
1889 register REGEXP *rx = PM_GETRE(pm);
1891 int force_on_match = 0;
1892 I32 oldsave = PL_savestack_ix;
1895 /* known replacement string? */
1896 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1897 if (PL_op->op_flags & OPf_STACKED)
1904 if (SvFAKE(TARG) && SvREADONLY(TARG))
1905 sv_force_normal(TARG);
1906 if (SvREADONLY(TARG)
1907 || (SvTYPE(TARG) > SVt_PVLV
1908 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1909 DIE(aTHX_ PL_no_modify);
1912 s = SvPV(TARG, len);
1913 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1915 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1916 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1921 PL_reg_match_utf8 = DO_UTF8(TARG);
1925 DIE(aTHX_ "panic: pp_subst");
1928 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1929 maxiters = 2 * slen + 10; /* We can match twice at each
1930 position, once with zero-length,
1931 second time with non-zero. */
1933 if (!rx->prelen && PL_curpm) {
1937 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1938 ? REXEC_COPY_STR : 0;
1940 r_flags |= REXEC_SCREAM;
1941 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1942 SAVEINT(PL_multiline);
1943 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1946 if (rx->reganch & RE_USE_INTUIT) {
1948 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1952 /* How to do it in subst? */
1953 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1955 && ((rx->reganch & ROPT_NOSCAN)
1956 || !((rx->reganch & RE_INTUIT_TAIL)
1957 && (r_flags & REXEC_SCREAM))))
1962 /* only replace once? */
1963 once = !(rpm->op_pmflags & PMf_GLOBAL);
1965 /* known replacement string? */
1966 c = dstr ? SvPV(dstr, clen) : Nullch;
1968 /* can do inplace substitution? */
1969 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1970 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1971 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1972 r_flags | REXEC_CHECKED))
1976 LEAVE_SCOPE(oldsave);
1979 if (force_on_match) {
1981 s = SvPV_force(TARG, len);
1986 SvSCREAM_off(TARG); /* disable possible screamer */
1988 rxtainted |= RX_MATCH_TAINTED(rx);
1989 m = orig + rx->startp[0];
1990 d = orig + rx->endp[0];
1992 if (m - s > strend - d) { /* faster to shorten from end */
1994 Copy(c, m, clen, char);
1999 Move(d, m, i, char);
2003 SvCUR_set(TARG, m - s);
2006 else if ((i = m - s)) { /* faster from front */
2014 Copy(c, m, clen, char);
2019 Copy(c, d, clen, char);
2024 TAINT_IF(rxtainted & 1);
2030 if (iters++ > maxiters)
2031 DIE(aTHX_ "Substitution loop");
2032 rxtainted |= RX_MATCH_TAINTED(rx);
2033 m = rx->startp[0] + orig;
2037 Move(s, d, i, char);
2041 Copy(c, d, clen, char);
2044 s = rx->endp[0] + orig;
2045 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2047 /* don't match same null twice */
2048 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2051 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2052 Move(s, d, i+1, char); /* include the NUL */
2054 TAINT_IF(rxtainted & 1);
2056 PUSHs(sv_2mortal(newSViv((I32)iters)));
2058 (void)SvPOK_only_UTF8(TARG);
2059 TAINT_IF(rxtainted);
2060 if (SvSMAGICAL(TARG)) {
2066 LEAVE_SCOPE(oldsave);
2070 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2071 r_flags | REXEC_CHECKED))
2075 if (force_on_match) {
2077 s = SvPV_force(TARG, len);
2080 rxtainted |= RX_MATCH_TAINTED(rx);
2081 dstr = NEWSV(25, len);
2082 sv_setpvn(dstr, m, s-m);
2087 register PERL_CONTEXT *cx;
2090 RETURNOP(cPMOP->op_pmreplroot);
2092 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2094 if (iters++ > maxiters)
2095 DIE(aTHX_ "Substitution loop");
2096 rxtainted |= RX_MATCH_TAINTED(rx);
2097 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2102 strend = s + (strend - m);
2104 m = rx->startp[0] + orig;
2105 sv_catpvn(dstr, s, m-s);
2106 s = rx->endp[0] + orig;
2108 sv_catpvn(dstr, c, clen);
2111 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2112 TARG, NULL, r_flags));
2113 sv_catpvn(dstr, s, strend - s);
2115 (void)SvOOK_off(TARG);
2116 Safefree(SvPVX(TARG));
2117 SvPVX(TARG) = SvPVX(dstr);
2118 SvCUR_set(TARG, SvCUR(dstr));
2119 SvLEN_set(TARG, SvLEN(dstr));
2120 isutf8 = DO_UTF8(dstr);
2124 TAINT_IF(rxtainted & 1);
2126 PUSHs(sv_2mortal(newSViv((I32)iters)));
2128 (void)SvPOK_only(TARG);
2131 TAINT_IF(rxtainted);
2134 LEAVE_SCOPE(oldsave);
2143 LEAVE_SCOPE(oldsave);
2152 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2153 ++*PL_markstack_ptr;
2154 LEAVE; /* exit inner scope */
2157 if (PL_stack_base + *PL_markstack_ptr > SP) {
2159 I32 gimme = GIMME_V;
2161 LEAVE; /* exit outer scope */
2162 (void)POPMARK; /* pop src */
2163 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2164 (void)POPMARK; /* pop dst */
2165 SP = PL_stack_base + POPMARK; /* pop original mark */
2166 if (gimme == G_SCALAR) {
2170 else if (gimme == G_ARRAY)
2177 ENTER; /* enter inner scope */
2180 src = PL_stack_base[*PL_markstack_ptr];
2184 RETURNOP(cLOGOP->op_other);
2195 register PERL_CONTEXT *cx;
2201 if (gimme == G_SCALAR) {
2204 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2206 *MARK = SvREFCNT_inc(TOPs);
2211 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2213 *MARK = sv_mortalcopy(sv);
2218 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2222 *MARK = &PL_sv_undef;
2226 else if (gimme == G_ARRAY) {
2227 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2228 if (!SvTEMP(*MARK)) {
2229 *MARK = sv_mortalcopy(*MARK);
2230 TAINT_NOT; /* Each item is independent */
2236 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2237 PL_curpm = newpm; /* ... and pop $1 et al */
2241 return pop_return();
2244 /* This duplicates the above code because the above code must not
2245 * get any slower by more conditions */
2253 register PERL_CONTEXT *cx;
2260 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2261 /* We are an argument to a function or grep().
2262 * This kind of lvalueness was legal before lvalue
2263 * subroutines too, so be backward compatible:
2264 * cannot report errors. */
2266 /* Scalar context *is* possible, on the LHS of -> only,
2267 * as in f()->meth(). But this is not an lvalue. */
2268 if (gimme == G_SCALAR)
2270 if (gimme == G_ARRAY) {
2271 if (!CvLVALUE(cx->blk_sub.cv))
2272 goto temporise_array;
2273 EXTEND_MORTAL(SP - newsp);
2274 for (mark = newsp + 1; mark <= SP; mark++) {
2277 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2278 *mark = sv_mortalcopy(*mark);
2280 /* Can be a localized value subject to deletion. */
2281 PL_tmps_stack[++PL_tmps_ix] = *mark;
2282 (void)SvREFCNT_inc(*mark);
2287 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2288 /* Here we go for robustness, not for speed, so we change all
2289 * the refcounts so the caller gets a live guy. Cannot set
2290 * TEMP, so sv_2mortal is out of question. */
2291 if (!CvLVALUE(cx->blk_sub.cv)) {
2296 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2298 if (gimme == G_SCALAR) {
2302 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2307 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2308 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2310 else { /* Can be a localized value
2311 * subject to deletion. */
2312 PL_tmps_stack[++PL_tmps_ix] = *mark;
2313 (void)SvREFCNT_inc(*mark);
2316 else { /* Should not happen? */
2321 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2322 (MARK > SP ? "Empty array" : "Array"));
2326 else if (gimme == G_ARRAY) {
2327 EXTEND_MORTAL(SP - newsp);
2328 for (mark = newsp + 1; mark <= SP; mark++) {
2329 if (*mark != &PL_sv_undef
2330 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2331 /* Might be flattened array after $#array = */
2337 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2338 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2341 /* Can be a localized value subject to deletion. */
2342 PL_tmps_stack[++PL_tmps_ix] = *mark;
2343 (void)SvREFCNT_inc(*mark);
2349 if (gimme == G_SCALAR) {
2353 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2355 *MARK = SvREFCNT_inc(TOPs);
2360 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2362 *MARK = sv_mortalcopy(sv);
2367 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2371 *MARK = &PL_sv_undef;
2375 else if (gimme == G_ARRAY) {
2377 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2378 if (!SvTEMP(*MARK)) {
2379 *MARK = sv_mortalcopy(*MARK);
2380 TAINT_NOT; /* Each item is independent */
2387 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2388 PL_curpm = newpm; /* ... and pop $1 et al */
2392 return pop_return();
2397 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2399 SV *dbsv = GvSV(PL_DBsub);
2401 if (!PERLDB_SUB_NN) {
2405 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2406 || strEQ(GvNAME(gv), "END")
2407 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2408 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2409 && (gv = (GV*)*svp) ))) {
2410 /* Use GV from the stack as a fallback. */
2411 /* GV is potentially non-unique, or contain different CV. */
2412 SV *tmp = newRV((SV*)cv);
2413 sv_setsv(dbsv, tmp);
2417 gv_efullname3(dbsv, gv, Nullch);
2421 (void)SvUPGRADE(dbsv, SVt_PVIV);
2422 (void)SvIOK_on(dbsv);
2423 SAVEIV(SvIVX(dbsv));
2424 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2428 PL_curcopdb = PL_curcop;
2429 cv = GvCV(PL_DBsub);
2439 register PERL_CONTEXT *cx;
2441 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2444 DIE(aTHX_ "Not a CODE reference");
2445 switch (SvTYPE(sv)) {
2451 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2453 SP = PL_stack_base + POPMARK;
2456 if (SvGMAGICAL(sv)) {
2460 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2463 sym = SvPV(sv, n_a);
2465 DIE(aTHX_ PL_no_usym, "a subroutine");
2466 if (PL_op->op_private & HINT_STRICT_REFS)
2467 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2468 cv = get_cv(sym, TRUE);
2473 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2474 tryAMAGICunDEREF(to_cv);
2477 if (SvTYPE(cv) == SVt_PVCV)
2482 DIE(aTHX_ "Not a CODE reference");
2487 if (!(cv = GvCVu((GV*)sv)))
2488 cv = sv_2cv(sv, &stash, &gv, FALSE);
2501 if (!CvROOT(cv) && !CvXSUB(cv)) {
2505 /* anonymous or undef'd function leaves us no recourse */
2506 if (CvANON(cv) || !(gv = CvGV(cv)))
2507 DIE(aTHX_ "Undefined subroutine called");
2509 /* autoloaded stub? */
2510 if (cv != GvCV(gv)) {
2513 /* should call AUTOLOAD now? */
2516 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2523 sub_name = sv_newmortal();
2524 gv_efullname3(sub_name, gv, Nullch);
2525 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2529 DIE(aTHX_ "Not a CODE reference");
2534 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2535 cv = get_db_sub(&sv, cv);
2537 DIE(aTHX_ "No DBsub routine");
2540 #ifdef USE_5005THREADS
2542 * First we need to check if the sub or method requires locking.
2543 * If so, we gain a lock on the CV, the first argument or the
2544 * stash (for static methods), as appropriate. This has to be
2545 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2546 * reschedule by returning a new op.
2548 MUTEX_LOCK(CvMUTEXP(cv));
2549 if (CvFLAGS(cv) & CVf_LOCKED) {
2551 if (CvFLAGS(cv) & CVf_METHOD) {
2552 if (SP > PL_stack_base + TOPMARK)
2553 sv = *(PL_stack_base + TOPMARK + 1);
2555 AV *av = (AV*)PL_curpad[0];
2556 if (hasargs || !av || AvFILLp(av) < 0
2557 || !(sv = AvARRAY(av)[0]))
2559 MUTEX_UNLOCK(CvMUTEXP(cv));
2560 DIE(aTHX_ "no argument for locked method call");
2567 char *stashname = SvPV(sv, len);
2568 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2574 MUTEX_UNLOCK(CvMUTEXP(cv));
2575 mg = condpair_magic(sv);
2576 MUTEX_LOCK(MgMUTEXP(mg));
2577 if (MgOWNER(mg) == thr)
2578 MUTEX_UNLOCK(MgMUTEXP(mg));
2581 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2583 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2585 MUTEX_UNLOCK(MgMUTEXP(mg));
2586 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2588 MUTEX_LOCK(CvMUTEXP(cv));
2591 * Now we have permission to enter the sub, we must distinguish
2592 * four cases. (0) It's an XSUB (in which case we don't care
2593 * about ownership); (1) it's ours already (and we're recursing);
2594 * (2) it's free (but we may already be using a cached clone);
2595 * (3) another thread owns it. Case (1) is easy: we just use it.
2596 * Case (2) means we look for a clone--if we have one, use it
2597 * otherwise grab ownership of cv. Case (3) means we look for a
2598 * clone (for non-XSUBs) and have to create one if we don't
2600 * Why look for a clone in case (2) when we could just grab
2601 * ownership of cv straight away? Well, we could be recursing,
2602 * i.e. we originally tried to enter cv while another thread
2603 * owned it (hence we used a clone) but it has been freed up
2604 * and we're now recursing into it. It may or may not be "better"
2605 * to use the clone but at least CvDEPTH can be trusted.
2607 if (CvOWNER(cv) == thr || CvXSUB(cv))
2608 MUTEX_UNLOCK(CvMUTEXP(cv));
2610 /* Case (2) or (3) */
2614 * XXX Might it be better to release CvMUTEXP(cv) while we
2615 * do the hv_fetch? We might find someone has pinched it
2616 * when we look again, in which case we would be in case
2617 * (3) instead of (2) so we'd have to clone. Would the fact
2618 * that we released the mutex more quickly make up for this?
2620 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2622 /* We already have a clone to use */
2623 MUTEX_UNLOCK(CvMUTEXP(cv));
2625 DEBUG_S(PerlIO_printf(Perl_debug_log,
2626 "entersub: %p already has clone %p:%s\n",
2627 thr, cv, SvPEEK((SV*)cv)));
2630 if (CvDEPTH(cv) == 0)
2631 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2634 /* (2) => grab ownership of cv. (3) => make clone */
2638 MUTEX_UNLOCK(CvMUTEXP(cv));
2639 DEBUG_S(PerlIO_printf(Perl_debug_log,
2640 "entersub: %p grabbing %p:%s in stash %s\n",
2641 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2642 HvNAME(CvSTASH(cv)) : "(none)"));
2645 /* Make a new clone. */
2647 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2648 MUTEX_UNLOCK(CvMUTEXP(cv));
2649 DEBUG_S((PerlIO_printf(Perl_debug_log,
2650 "entersub: %p cloning %p:%s\n",
2651 thr, cv, SvPEEK((SV*)cv))));
2653 * We're creating a new clone so there's no race
2654 * between the original MUTEX_UNLOCK and the
2655 * SvREFCNT_inc since no one will be trying to undef
2656 * it out from underneath us. At least, I don't think
2659 clonecv = cv_clone(cv);
2660 SvREFCNT_dec(cv); /* finished with this */
2661 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2662 CvOWNER(clonecv) = thr;
2666 DEBUG_S(if (CvDEPTH(cv) != 0)
2667 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2669 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2672 #endif /* USE_5005THREADS */
2675 #ifdef PERL_XSUB_OLDSTYLE
2676 if (CvOLDSTYLE(cv)) {
2677 I32 (*fp3)(int,int,int);
2679 register I32 items = SP - MARK;
2680 /* We dont worry to copy from @_. */
2685 PL_stack_sp = mark + 1;
2686 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2687 items = (*fp3)(CvXSUBANY(cv).any_i32,
2688 MARK - PL_stack_base + 1,
2690 PL_stack_sp = PL_stack_base + items;
2693 #endif /* PERL_XSUB_OLDSTYLE */
2695 I32 markix = TOPMARK;
2700 /* Need to copy @_ to stack. Alternative may be to
2701 * switch stack to @_, and copy return values
2702 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2705 #ifdef USE_5005THREADS
2706 av = (AV*)PL_curpad[0];
2708 av = GvAV(PL_defgv);
2709 #endif /* USE_5005THREADS */
2710 items = AvFILLp(av) + 1; /* @_ is not tieable */
2713 /* Mark is at the end of the stack. */
2715 Copy(AvARRAY(av), SP + 1, items, SV*);
2720 /* We assume first XSUB in &DB::sub is the called one. */
2722 SAVEVPTR(PL_curcop);
2723 PL_curcop = PL_curcopdb;
2726 /* Do we need to open block here? XXXX */
2727 (void)(*CvXSUB(cv))(aTHX_ cv);
2729 /* Enforce some sanity in scalar context. */
2730 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2731 if (markix > PL_stack_sp - PL_stack_base)
2732 *(PL_stack_base + markix) = &PL_sv_undef;
2734 *(PL_stack_base + markix) = *PL_stack_sp;
2735 PL_stack_sp = PL_stack_base + markix;
2743 register I32 items = SP - MARK;
2744 AV* padlist = CvPADLIST(cv);
2745 SV** svp = AvARRAY(padlist);
2746 push_return(PL_op->op_next);
2747 PUSHBLOCK(cx, CXt_SUB, MARK);
2750 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2751 * that eval'' ops within this sub know the correct lexical space.
2752 * Owing the speed considerations, we choose to search for the cv
2753 * in doeval() instead.
2755 if (CvDEPTH(cv) < 2)
2756 (void)SvREFCNT_inc(cv);
2757 else { /* save temporaries on recursion? */
2758 PERL_STACK_OVERFLOW_CHECK();
2759 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2761 AV *newpad = newAV();
2762 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2763 I32 ix = AvFILLp((AV*)svp[1]);
2764 I32 names_fill = AvFILLp((AV*)svp[0]);
2765 svp = AvARRAY(svp[0]);
2766 for ( ;ix > 0; ix--) {
2767 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2768 char *name = SvPVX(svp[ix]);
2769 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2770 || *name == '&') /* anonymous code? */
2772 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2774 else { /* our own lexical */
2776 av_store(newpad, ix, sv = (SV*)newAV());
2777 else if (*name == '%')
2778 av_store(newpad, ix, sv = (SV*)newHV());
2780 av_store(newpad, ix, sv = NEWSV(0,0));
2784 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2785 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2788 av_store(newpad, ix, sv = NEWSV(0,0));
2792 av = newAV(); /* will be @_ */
2794 av_store(newpad, 0, (SV*)av);
2795 AvFLAGS(av) = AVf_REIFY;
2796 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2797 AvFILLp(padlist) = CvDEPTH(cv);
2798 svp = AvARRAY(padlist);
2801 #ifdef USE_5005THREADS
2803 AV* av = (AV*)PL_curpad[0];
2805 items = AvFILLp(av) + 1;
2807 /* Mark is at the end of the stack. */
2809 Copy(AvARRAY(av), SP + 1, items, SV*);
2814 #endif /* USE_5005THREADS */
2815 SAVEVPTR(PL_curpad);
2816 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2817 #ifndef USE_5005THREADS
2819 #endif /* USE_5005THREADS */
2825 DEBUG_S(PerlIO_printf(Perl_debug_log,
2826 "%p entersub preparing @_\n", thr));
2828 av = (AV*)PL_curpad[0];
2830 /* @_ is normally not REAL--this should only ever
2831 * happen when DB::sub() calls things that modify @_ */
2836 #ifndef USE_5005THREADS
2837 cx->blk_sub.savearray = GvAV(PL_defgv);
2838 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2839 #endif /* USE_5005THREADS */
2840 cx->blk_sub.oldcurpad = PL_curpad;
2841 cx->blk_sub.argarray = av;
2844 if (items > AvMAX(av) + 1) {
2846 if (AvARRAY(av) != ary) {
2847 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2848 SvPVX(av) = (char*)ary;
2850 if (items > AvMAX(av) + 1) {
2851 AvMAX(av) = items - 1;
2852 Renew(ary,items,SV*);
2854 SvPVX(av) = (char*)ary;
2857 Copy(MARK,AvARRAY(av),items,SV*);
2858 AvFILLp(av) = items - 1;
2866 /* warning must come *after* we fully set up the context
2867 * stuff so that __WARN__ handlers can safely dounwind()
2870 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2871 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2872 sub_crush_depth(cv);
2874 DEBUG_S(PerlIO_printf(Perl_debug_log,
2875 "%p entersub returning %p\n", thr, CvSTART(cv)));
2877 RETURNOP(CvSTART(cv));
2882 Perl_sub_crush_depth(pTHX_ CV *cv)
2885 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2887 SV* tmpstr = sv_newmortal();
2888 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2889 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2899 IV elem = SvIV(elemsv);
2901 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2902 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2905 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2906 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2908 elem -= PL_curcop->cop_arybase;
2909 if (SvTYPE(av) != SVt_PVAV)
2911 svp = av_fetch(av, elem, lval && !defer);
2913 if (!svp || *svp == &PL_sv_undef) {
2916 DIE(aTHX_ PL_no_aelem, elem);
2917 lv = sv_newmortal();
2918 sv_upgrade(lv, SVt_PVLV);
2920 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2921 LvTARG(lv) = SvREFCNT_inc(av);
2922 LvTARGOFF(lv) = elem;
2927 if (PL_op->op_private & OPpLVAL_INTRO)
2928 save_aelem(av, elem, svp);
2929 else if (PL_op->op_private & OPpDEREF)
2930 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2932 sv = (svp ? *svp : &PL_sv_undef);
2933 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2934 sv = sv_mortalcopy(sv);
2940 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2946 Perl_croak(aTHX_ PL_no_modify);
2947 if (SvTYPE(sv) < SVt_RV)
2948 sv_upgrade(sv, SVt_RV);
2949 else if (SvTYPE(sv) >= SVt_PV) {
2950 (void)SvOOK_off(sv);
2951 Safefree(SvPVX(sv));
2952 SvLEN(sv) = SvCUR(sv) = 0;
2956 SvRV(sv) = NEWSV(355,0);
2959 SvRV(sv) = (SV*)newAV();
2962 SvRV(sv) = (SV*)newHV();
2977 if (SvTYPE(rsv) == SVt_PVCV) {
2983 SETs(method_common(sv, Null(U32*)));
2990 SV* sv = cSVOP->op_sv;
2991 U32 hash = SvUVX(sv);
2993 XPUSHs(method_common(sv, &hash));
2998 S_method_common(pTHX_ SV* meth, U32* hashp)
3009 name = SvPV(meth, namelen);
3010 sv = *(PL_stack_base + TOPMARK + 1);
3013 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3022 /* this isn't a reference */
3025 !(packname = SvPV(sv, packlen)) ||
3026 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3027 !(ob=(SV*)GvIO(iogv)))
3029 /* this isn't the name of a filehandle either */
3031 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3032 ? !isIDFIRST_utf8((U8*)packname)
3033 : !isIDFIRST(*packname)
3036 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3037 SvOK(sv) ? "without a package or object reference"
3038 : "on an undefined value");
3040 /* assume it's a package name */
3041 stash = gv_stashpvn(packname, packlen, FALSE);
3044 /* it _is_ a filehandle name -- replace with a reference */
3045 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3048 /* if we got here, ob should be a reference or a glob */
3049 if (!ob || !(SvOBJECT(ob)
3050 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3053 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3057 stash = SvSTASH(ob);
3060 /* NOTE: stash may be null, hope hv_fetch_ent and
3061 gv_fetchmethod can cope (it seems they can) */
3063 /* shortcut for simple names */
3065 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3067 gv = (GV*)HeVAL(he);
3068 if (isGV(gv) && GvCV(gv) &&
3069 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3070 return (SV*)GvCV(gv);
3074 gv = gv_fetchmethod(stash, name);
3077 /* This code tries to figure out just what went wrong with
3078 gv_fetchmethod. It therefore needs to duplicate a lot of
3079 the internals of that function. We can't move it inside
3080 Perl_gv_fetchmethod_autoload(), however, since that would
3081 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3088 for (p = name; *p; p++) {
3090 sep = p, leaf = p + 1;
3091 else if (*p == ':' && *(p + 1) == ':')
3092 sep = p, leaf = p + 2;
3094 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3095 /* the method name is unqualified or starts with SUPER:: */
3096 packname = sep ? CopSTASHPV(PL_curcop) :
3097 stash ? HvNAME(stash) : packname;
3098 packlen = strlen(packname);
3101 /* the method name is qualified */
3103 packlen = sep - name;
3106 /* we're relying on gv_fetchmethod not autovivifying the stash */
3107 if (gv_stashpvn(packname, packlen, FALSE)) {
3109 "Can't locate object method \"%s\" via package \"%.*s\"",
3110 leaf, (int)packlen, packname);
3114 "Can't locate object method \"%s\" via package \"%.*s\""
3115 " (perhaps you forgot to load \"%.*s\"?)",
3116 leaf, (int)packlen, packname, (int)packlen, packname);
3119 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3122 #ifdef USE_5005THREADS
3124 unset_cvowner(pTHX_ void *cvarg)
3126 register CV* cv = (CV *) cvarg;
3128 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3129 thr, cv, SvPEEK((SV*)cv))));
3130 MUTEX_LOCK(CvMUTEXP(cv));
3131 DEBUG_S(if (CvDEPTH(cv) != 0)
3132 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3134 assert(thr == CvOWNER(cv));
3136 MUTEX_UNLOCK(CvMUTEXP(cv));
3139 #endif /* USE_5005THREADS */