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 &&
1239 !PL_reg_match_utf8 /* ANYOFs can balloon to EXACTFs */
1245 /* XXXX What part of this is needed with true \G-support? */
1246 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1248 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1249 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1250 if (mg && mg->mg_len >= 0) {
1251 if (!(rx->reganch & ROPT_GPOS_SEEN))
1252 rx->endp[0] = rx->startp[0] = mg->mg_len;
1253 else if (rx->reganch & ROPT_ANCH_GPOS) {
1254 r_flags |= REXEC_IGNOREPOS;
1255 rx->endp[0] = rx->startp[0] = mg->mg_len;
1257 minmatch = (mg->mg_flags & MGf_MINMATCH);
1258 update_minmatch = 0;
1262 if ((!global && rx->nparens)
1263 || SvTEMP(TARG) || PL_sawampersand)
1264 r_flags |= REXEC_COPY_STR;
1266 r_flags |= REXEC_SCREAM;
1268 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1269 SAVEINT(PL_multiline);
1270 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1274 if (global && rx->startp[0] != -1) {
1275 t = s = rx->endp[0] + truebase;
1276 if ((s + rx->minlen) > strend)
1278 if (update_minmatch++)
1279 minmatch = had_zerolen;
1281 if (rx->reganch & RE_USE_INTUIT &&
1282 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1283 PL_bostr = truebase;
1284 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1288 if ( (rx->reganch & ROPT_CHECK_ALL)
1290 && ((rx->reganch & ROPT_NOSCAN)
1291 || !((rx->reganch & RE_INTUIT_TAIL)
1292 && (r_flags & REXEC_SCREAM)))
1293 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1296 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1299 if (pm->op_pmflags & PMf_ONCE)
1300 pm->op_pmdynflags |= PMdf_USED;
1309 RX_MATCH_TAINTED_on(rx);
1310 TAINT_IF(RX_MATCH_TAINTED(rx));
1311 if (gimme == G_ARRAY) {
1312 I32 nparens, i, len;
1314 nparens = rx->nparens;
1315 if (global && !nparens)
1319 SPAGAIN; /* EVAL blocks could move the stack. */
1320 EXTEND(SP, nparens + i);
1321 EXTEND_MORTAL(nparens + i);
1322 for (i = !i; i <= nparens; i++) {
1323 PUSHs(sv_newmortal());
1325 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1326 len = rx->endp[i] - rx->startp[i];
1327 s = rx->startp[i] + truebase;
1328 sv_setpvn(*SP, s, len);
1329 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1334 if (pm->op_pmflags & PMf_CONTINUE) {
1336 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1337 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1339 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1340 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1342 if (rx->startp[0] != -1) {
1343 mg->mg_len = rx->endp[0];
1344 if (rx->startp[0] == rx->endp[0])
1345 mg->mg_flags |= MGf_MINMATCH;
1347 mg->mg_flags &= ~MGf_MINMATCH;
1350 had_zerolen = (rx->startp[0] != -1
1351 && rx->startp[0] == rx->endp[0]);
1352 PUTBACK; /* EVAL blocks may use stack */
1353 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1358 LEAVE_SCOPE(oldsave);
1364 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1365 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1367 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1368 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1370 if (rx->startp[0] != -1) {
1371 mg->mg_len = rx->endp[0];
1372 if (rx->startp[0] == rx->endp[0])
1373 mg->mg_flags |= MGf_MINMATCH;
1375 mg->mg_flags &= ~MGf_MINMATCH;
1378 LEAVE_SCOPE(oldsave);
1382 yup: /* Confirmed by INTUIT */
1384 RX_MATCH_TAINTED_on(rx);
1385 TAINT_IF(RX_MATCH_TAINTED(rx));
1387 if (pm->op_pmflags & PMf_ONCE)
1388 pm->op_pmdynflags |= PMdf_USED;
1389 if (RX_MATCH_COPIED(rx))
1390 Safefree(rx->subbeg);
1391 RX_MATCH_COPIED_off(rx);
1392 rx->subbeg = Nullch;
1394 rx->subbeg = truebase;
1395 rx->startp[0] = s - truebase;
1396 if (PL_reg_match_utf8) {
1397 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1398 rx->endp[0] = t - truebase;
1401 rx->endp[0] = s - truebase + rx->minlen;
1403 rx->sublen = strend - truebase;
1406 if (PL_sawampersand) {
1409 rx->subbeg = savepvn(t, strend - t);
1410 rx->sublen = strend - t;
1411 RX_MATCH_COPIED_on(rx);
1412 off = rx->startp[0] = s - t;
1413 rx->endp[0] = off + rx->minlen;
1415 else { /* startp/endp are used by @- @+. */
1416 rx->startp[0] = s - truebase;
1417 rx->endp[0] = s - truebase + rx->minlen;
1419 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1420 LEAVE_SCOPE(oldsave);
1425 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1426 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1427 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1432 LEAVE_SCOPE(oldsave);
1433 if (gimme == G_ARRAY)
1439 Perl_do_readline(pTHX)
1441 dSP; dTARGETSTACKED;
1446 register IO *io = GvIO(PL_last_in_gv);
1447 register I32 type = PL_op->op_type;
1448 I32 gimme = GIMME_V;
1451 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1453 XPUSHs(SvTIED_obj((SV*)io, mg));
1456 call_method("READLINE", gimme);
1459 if (gimme == G_SCALAR)
1460 SvSetMagicSV_nosteal(TARG, TOPs);
1467 if (IoFLAGS(io) & IOf_ARGV) {
1468 if (IoFLAGS(io) & IOf_START) {
1470 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1471 IoFLAGS(io) &= ~IOf_START;
1472 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1473 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1474 SvSETMAGIC(GvSV(PL_last_in_gv));
1479 fp = nextargv(PL_last_in_gv);
1480 if (!fp) { /* Note: fp != IoIFP(io) */
1481 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1484 else if (type == OP_GLOB)
1485 fp = Perl_start_glob(aTHX_ POPs, io);
1487 else if (type == OP_GLOB)
1489 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1490 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1494 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1495 && (!io || !(IoFLAGS(io) & IOf_START))) {
1496 if (type == OP_GLOB)
1497 Perl_warner(aTHX_ WARN_GLOB,
1498 "glob failed (can't start child: %s)",
1501 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1503 if (gimme == G_SCALAR) {
1504 (void)SvOK_off(TARG);
1510 if (gimme == G_SCALAR) {
1514 (void)SvUPGRADE(sv, SVt_PV);
1515 tmplen = SvLEN(sv); /* remember if already alloced */
1517 Sv_Grow(sv, 80); /* try short-buffering it */
1518 if (type == OP_RCATLINE)
1524 sv = sv_2mortal(NEWSV(57, 80));
1528 /* This should not be marked tainted if the fp is marked clean */
1529 #define MAYBE_TAINT_LINE(io, sv) \
1530 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1535 /* delay EOF state for a snarfed empty file */
1536 #define SNARF_EOF(gimme,rs,io,sv) \
1537 (gimme != G_SCALAR || SvCUR(sv) \
1538 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1542 if (!sv_gets(sv, fp, offset)
1543 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1545 PerlIO_clearerr(fp);
1546 if (IoFLAGS(io) & IOf_ARGV) {
1547 fp = nextargv(PL_last_in_gv);
1550 (void)do_close(PL_last_in_gv, FALSE);
1552 else if (type == OP_GLOB) {
1553 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1554 Perl_warner(aTHX_ WARN_GLOB,
1555 "glob failed (child exited with status %d%s)",
1556 (int)(STATUS_CURRENT >> 8),
1557 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1560 if (gimme == G_SCALAR) {
1561 (void)SvOK_off(TARG);
1565 MAYBE_TAINT_LINE(io, sv);
1568 MAYBE_TAINT_LINE(io, sv);
1570 IoFLAGS(io) |= IOf_NOLINE;
1574 if (type == OP_GLOB) {
1577 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1578 tmps = SvEND(sv) - 1;
1579 if (*tmps == *SvPVX(PL_rs)) {
1584 for (tmps = SvPVX(sv); *tmps; tmps++)
1585 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1586 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1588 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1589 (void)POPs; /* Unmatched wildcard? Chuck it... */
1593 if (gimme == G_ARRAY) {
1594 if (SvLEN(sv) - SvCUR(sv) > 20) {
1595 SvLEN_set(sv, SvCUR(sv)+1);
1596 Renew(SvPVX(sv), SvLEN(sv), char);
1598 sv = sv_2mortal(NEWSV(58, 80));
1601 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1602 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1606 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1607 Renew(SvPVX(sv), SvLEN(sv), char);
1616 register PERL_CONTEXT *cx;
1617 I32 gimme = OP_GIMME(PL_op, -1);
1620 if (cxstack_ix >= 0)
1621 gimme = cxstack[cxstack_ix].blk_gimme;
1629 PUSHBLOCK(cx, CXt_BLOCK, SP);
1641 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1642 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1644 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1647 if (SvTYPE(hv) == SVt_PVHV) {
1648 if (PL_op->op_private & OPpLVAL_INTRO)
1649 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1650 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1651 svp = he ? &HeVAL(he) : 0;
1653 else if (SvTYPE(hv) == SVt_PVAV) {
1654 if (PL_op->op_private & OPpLVAL_INTRO)
1655 DIE(aTHX_ "Can't localize pseudo-hash element");
1656 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1662 if (!svp || *svp == &PL_sv_undef) {
1667 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1669 lv = sv_newmortal();
1670 sv_upgrade(lv, SVt_PVLV);
1672 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1673 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1674 LvTARG(lv) = SvREFCNT_inc(hv);
1679 if (PL_op->op_private & OPpLVAL_INTRO) {
1680 if (HvNAME(hv) && isGV(*svp))
1681 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1685 char *key = SvPV(keysv, keylen);
1686 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1688 save_helem(hv, keysv, svp);
1691 else if (PL_op->op_private & OPpDEREF)
1692 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1694 sv = (svp ? *svp : &PL_sv_undef);
1695 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1696 * Pushing the magical RHS on to the stack is useless, since
1697 * that magic is soon destined to be misled by the local(),
1698 * and thus the later pp_sassign() will fail to mg_get() the
1699 * old value. This should also cure problems with delayed
1700 * mg_get()s. GSAR 98-07-03 */
1701 if (!lval && SvGMAGICAL(sv))
1702 sv = sv_mortalcopy(sv);
1710 register PERL_CONTEXT *cx;
1716 if (PL_op->op_flags & OPf_SPECIAL) {
1717 cx = &cxstack[cxstack_ix];
1718 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1723 gimme = OP_GIMME(PL_op, -1);
1725 if (cxstack_ix >= 0)
1726 gimme = cxstack[cxstack_ix].blk_gimme;
1732 if (gimme == G_VOID)
1734 else if (gimme == G_SCALAR) {
1737 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1740 *MARK = sv_mortalcopy(TOPs);
1743 *MARK = &PL_sv_undef;
1747 else if (gimme == G_ARRAY) {
1748 /* in case LEAVE wipes old return values */
1749 for (mark = newsp + 1; mark <= SP; mark++) {
1750 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1751 *mark = sv_mortalcopy(*mark);
1752 TAINT_NOT; /* Each item is independent */
1756 PL_curpm = newpm; /* Don't pop $1 et al till now */
1766 register PERL_CONTEXT *cx;
1772 cx = &cxstack[cxstack_ix];
1773 if (CxTYPE(cx) != CXt_LOOP)
1774 DIE(aTHX_ "panic: pp_iter");
1776 itersvp = CxITERVAR(cx);
1777 av = cx->blk_loop.iterary;
1778 if (SvTYPE(av) != SVt_PVAV) {
1779 /* iterate ($min .. $max) */
1780 if (cx->blk_loop.iterlval) {
1781 /* string increment */
1782 register SV* cur = cx->blk_loop.iterlval;
1784 char *max = SvPV((SV*)av, maxlen);
1785 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1786 #ifndef USE_5005THREADS /* don't risk potential race */
1787 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1788 /* safe to reuse old SV */
1789 sv_setsv(*itersvp, cur);
1794 /* we need a fresh SV every time so that loop body sees a
1795 * completely new SV for closures/references to work as
1797 SvREFCNT_dec(*itersvp);
1798 *itersvp = newSVsv(cur);
1800 if (strEQ(SvPVX(cur), max))
1801 sv_setiv(cur, 0); /* terminate next time */
1808 /* integer increment */
1809 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1812 #ifndef USE_5005THREADS /* don't risk potential race */
1813 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1814 /* safe to reuse old SV */
1815 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1820 /* we need a fresh SV every time so that loop body sees a
1821 * completely new SV for closures/references to work as they
1823 SvREFCNT_dec(*itersvp);
1824 *itersvp = newSViv(cx->blk_loop.iterix++);
1830 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1833 SvREFCNT_dec(*itersvp);
1835 if (SvMAGICAL(av) || AvREIFY(av)) {
1836 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1843 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1849 if (av != PL_curstack && sv == &PL_sv_undef) {
1850 SV *lv = cx->blk_loop.iterlval;
1851 if (lv && SvREFCNT(lv) > 1) {
1856 SvREFCNT_dec(LvTARG(lv));
1858 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1859 sv_upgrade(lv, SVt_PVLV);
1861 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1863 LvTARG(lv) = SvREFCNT_inc(av);
1864 LvTARGOFF(lv) = cx->blk_loop.iterix;
1865 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1869 *itersvp = SvREFCNT_inc(sv);
1876 register PMOP *pm = cPMOP;
1892 register REGEXP *rx = PM_GETRE(pm);
1894 int force_on_match = 0;
1895 I32 oldsave = PL_savestack_ix;
1898 /* known replacement string? */
1899 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1900 if (PL_op->op_flags & OPf_STACKED)
1907 if (SvFAKE(TARG) && SvREADONLY(TARG))
1908 sv_force_normal(TARG);
1909 if (SvREADONLY(TARG)
1910 || (SvTYPE(TARG) > SVt_PVLV
1911 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1912 DIE(aTHX_ PL_no_modify);
1915 s = SvPV(TARG, len);
1916 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1918 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1919 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1924 PL_reg_match_utf8 = DO_UTF8(TARG);
1928 DIE(aTHX_ "panic: pp_subst");
1931 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1932 maxiters = 2 * slen + 10; /* We can match twice at each
1933 position, once with zero-length,
1934 second time with non-zero. */
1936 if (!rx->prelen && PL_curpm) {
1940 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1941 ? REXEC_COPY_STR : 0;
1943 r_flags |= REXEC_SCREAM;
1944 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1945 SAVEINT(PL_multiline);
1946 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1949 if (rx->reganch & RE_USE_INTUIT) {
1951 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1955 /* How to do it in subst? */
1956 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1958 && ((rx->reganch & ROPT_NOSCAN)
1959 || !((rx->reganch & RE_INTUIT_TAIL)
1960 && (r_flags & REXEC_SCREAM))))
1965 /* only replace once? */
1966 once = !(rpm->op_pmflags & PMf_GLOBAL);
1968 /* known replacement string? */
1969 c = dstr ? SvPV(dstr, clen) : Nullch;
1971 /* can do inplace substitution? */
1972 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1973 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1974 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1975 r_flags | REXEC_CHECKED))
1979 LEAVE_SCOPE(oldsave);
1982 if (force_on_match) {
1984 s = SvPV_force(TARG, len);
1989 SvSCREAM_off(TARG); /* disable possible screamer */
1991 rxtainted |= RX_MATCH_TAINTED(rx);
1992 m = orig + rx->startp[0];
1993 d = orig + rx->endp[0];
1995 if (m - s > strend - d) { /* faster to shorten from end */
1997 Copy(c, m, clen, char);
2002 Move(d, m, i, char);
2006 SvCUR_set(TARG, m - s);
2009 else if ((i = m - s)) { /* faster from front */
2017 Copy(c, m, clen, char);
2022 Copy(c, d, clen, char);
2027 TAINT_IF(rxtainted & 1);
2033 if (iters++ > maxiters)
2034 DIE(aTHX_ "Substitution loop");
2035 rxtainted |= RX_MATCH_TAINTED(rx);
2036 m = rx->startp[0] + orig;
2040 Move(s, d, i, char);
2044 Copy(c, d, clen, char);
2047 s = rx->endp[0] + orig;
2048 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2050 /* don't match same null twice */
2051 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2054 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2055 Move(s, d, i+1, char); /* include the NUL */
2057 TAINT_IF(rxtainted & 1);
2059 PUSHs(sv_2mortal(newSViv((I32)iters)));
2061 (void)SvPOK_only_UTF8(TARG);
2062 TAINT_IF(rxtainted);
2063 if (SvSMAGICAL(TARG)) {
2069 LEAVE_SCOPE(oldsave);
2073 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2074 r_flags | REXEC_CHECKED))
2078 if (force_on_match) {
2080 s = SvPV_force(TARG, len);
2083 rxtainted |= RX_MATCH_TAINTED(rx);
2084 dstr = NEWSV(25, len);
2085 sv_setpvn(dstr, m, s-m);
2090 register PERL_CONTEXT *cx;
2093 RETURNOP(cPMOP->op_pmreplroot);
2095 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2097 if (iters++ > maxiters)
2098 DIE(aTHX_ "Substitution loop");
2099 rxtainted |= RX_MATCH_TAINTED(rx);
2100 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2105 strend = s + (strend - m);
2107 m = rx->startp[0] + orig;
2108 sv_catpvn(dstr, s, m-s);
2109 s = rx->endp[0] + orig;
2111 sv_catpvn(dstr, c, clen);
2114 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2115 TARG, NULL, r_flags));
2116 sv_catpvn(dstr, s, strend - s);
2118 (void)SvOOK_off(TARG);
2119 Safefree(SvPVX(TARG));
2120 SvPVX(TARG) = SvPVX(dstr);
2121 SvCUR_set(TARG, SvCUR(dstr));
2122 SvLEN_set(TARG, SvLEN(dstr));
2123 isutf8 = DO_UTF8(dstr);
2127 TAINT_IF(rxtainted & 1);
2129 PUSHs(sv_2mortal(newSViv((I32)iters)));
2131 (void)SvPOK_only(TARG);
2134 TAINT_IF(rxtainted);
2137 LEAVE_SCOPE(oldsave);
2146 LEAVE_SCOPE(oldsave);
2155 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2156 ++*PL_markstack_ptr;
2157 LEAVE; /* exit inner scope */
2160 if (PL_stack_base + *PL_markstack_ptr > SP) {
2162 I32 gimme = GIMME_V;
2164 LEAVE; /* exit outer scope */
2165 (void)POPMARK; /* pop src */
2166 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2167 (void)POPMARK; /* pop dst */
2168 SP = PL_stack_base + POPMARK; /* pop original mark */
2169 if (gimme == G_SCALAR) {
2173 else if (gimme == G_ARRAY)
2180 ENTER; /* enter inner scope */
2183 src = PL_stack_base[*PL_markstack_ptr];
2187 RETURNOP(cLOGOP->op_other);
2198 register PERL_CONTEXT *cx;
2204 if (gimme == G_SCALAR) {
2207 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2209 *MARK = SvREFCNT_inc(TOPs);
2214 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2216 *MARK = sv_mortalcopy(sv);
2221 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2225 *MARK = &PL_sv_undef;
2229 else if (gimme == G_ARRAY) {
2230 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2231 if (!SvTEMP(*MARK)) {
2232 *MARK = sv_mortalcopy(*MARK);
2233 TAINT_NOT; /* Each item is independent */
2239 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2240 PL_curpm = newpm; /* ... and pop $1 et al */
2244 return pop_return();
2247 /* This duplicates the above code because the above code must not
2248 * get any slower by more conditions */
2256 register PERL_CONTEXT *cx;
2263 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2264 /* We are an argument to a function or grep().
2265 * This kind of lvalueness was legal before lvalue
2266 * subroutines too, so be backward compatible:
2267 * cannot report errors. */
2269 /* Scalar context *is* possible, on the LHS of -> only,
2270 * as in f()->meth(). But this is not an lvalue. */
2271 if (gimme == G_SCALAR)
2273 if (gimme == G_ARRAY) {
2274 if (!CvLVALUE(cx->blk_sub.cv))
2275 goto temporise_array;
2276 EXTEND_MORTAL(SP - newsp);
2277 for (mark = newsp + 1; mark <= SP; mark++) {
2280 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2281 *mark = sv_mortalcopy(*mark);
2283 /* Can be a localized value subject to deletion. */
2284 PL_tmps_stack[++PL_tmps_ix] = *mark;
2285 (void)SvREFCNT_inc(*mark);
2290 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2291 /* Here we go for robustness, not for speed, so we change all
2292 * the refcounts so the caller gets a live guy. Cannot set
2293 * TEMP, so sv_2mortal is out of question. */
2294 if (!CvLVALUE(cx->blk_sub.cv)) {
2299 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2301 if (gimme == G_SCALAR) {
2305 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2310 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2311 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2313 else { /* Can be a localized value
2314 * subject to deletion. */
2315 PL_tmps_stack[++PL_tmps_ix] = *mark;
2316 (void)SvREFCNT_inc(*mark);
2319 else { /* Should not happen? */
2324 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2325 (MARK > SP ? "Empty array" : "Array"));
2329 else if (gimme == G_ARRAY) {
2330 EXTEND_MORTAL(SP - newsp);
2331 for (mark = newsp + 1; mark <= SP; mark++) {
2332 if (*mark != &PL_sv_undef
2333 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2334 /* Might be flattened array after $#array = */
2340 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2341 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2344 /* Can be a localized value subject to deletion. */
2345 PL_tmps_stack[++PL_tmps_ix] = *mark;
2346 (void)SvREFCNT_inc(*mark);
2352 if (gimme == G_SCALAR) {
2356 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2358 *MARK = SvREFCNT_inc(TOPs);
2363 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2365 *MARK = sv_mortalcopy(sv);
2370 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2374 *MARK = &PL_sv_undef;
2378 else if (gimme == G_ARRAY) {
2380 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2381 if (!SvTEMP(*MARK)) {
2382 *MARK = sv_mortalcopy(*MARK);
2383 TAINT_NOT; /* Each item is independent */
2390 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2391 PL_curpm = newpm; /* ... and pop $1 et al */
2395 return pop_return();
2400 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2402 SV *dbsv = GvSV(PL_DBsub);
2404 if (!PERLDB_SUB_NN) {
2408 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2409 || strEQ(GvNAME(gv), "END")
2410 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2411 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2412 && (gv = (GV*)*svp) ))) {
2413 /* Use GV from the stack as a fallback. */
2414 /* GV is potentially non-unique, or contain different CV. */
2415 SV *tmp = newRV((SV*)cv);
2416 sv_setsv(dbsv, tmp);
2420 gv_efullname3(dbsv, gv, Nullch);
2424 (void)SvUPGRADE(dbsv, SVt_PVIV);
2425 (void)SvIOK_on(dbsv);
2426 SAVEIV(SvIVX(dbsv));
2427 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2431 PL_curcopdb = PL_curcop;
2432 cv = GvCV(PL_DBsub);
2442 register PERL_CONTEXT *cx;
2444 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2447 DIE(aTHX_ "Not a CODE reference");
2448 switch (SvTYPE(sv)) {
2454 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2456 SP = PL_stack_base + POPMARK;
2459 if (SvGMAGICAL(sv)) {
2463 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2466 sym = SvPV(sv, n_a);
2468 DIE(aTHX_ PL_no_usym, "a subroutine");
2469 if (PL_op->op_private & HINT_STRICT_REFS)
2470 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2471 cv = get_cv(sym, TRUE);
2476 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2477 tryAMAGICunDEREF(to_cv);
2480 if (SvTYPE(cv) == SVt_PVCV)
2485 DIE(aTHX_ "Not a CODE reference");
2490 if (!(cv = GvCVu((GV*)sv)))
2491 cv = sv_2cv(sv, &stash, &gv, FALSE);
2504 if (!CvROOT(cv) && !CvXSUB(cv)) {
2508 /* anonymous or undef'd function leaves us no recourse */
2509 if (CvANON(cv) || !(gv = CvGV(cv)))
2510 DIE(aTHX_ "Undefined subroutine called");
2512 /* autoloaded stub? */
2513 if (cv != GvCV(gv)) {
2516 /* should call AUTOLOAD now? */
2519 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2526 sub_name = sv_newmortal();
2527 gv_efullname3(sub_name, gv, Nullch);
2528 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2532 DIE(aTHX_ "Not a CODE reference");
2537 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2538 cv = get_db_sub(&sv, cv);
2540 DIE(aTHX_ "No DBsub routine");
2543 #ifdef USE_5005THREADS
2545 * First we need to check if the sub or method requires locking.
2546 * If so, we gain a lock on the CV, the first argument or the
2547 * stash (for static methods), as appropriate. This has to be
2548 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2549 * reschedule by returning a new op.
2551 MUTEX_LOCK(CvMUTEXP(cv));
2552 if (CvFLAGS(cv) & CVf_LOCKED) {
2554 if (CvFLAGS(cv) & CVf_METHOD) {
2555 if (SP > PL_stack_base + TOPMARK)
2556 sv = *(PL_stack_base + TOPMARK + 1);
2558 AV *av = (AV*)PL_curpad[0];
2559 if (hasargs || !av || AvFILLp(av) < 0
2560 || !(sv = AvARRAY(av)[0]))
2562 MUTEX_UNLOCK(CvMUTEXP(cv));
2563 DIE(aTHX_ "no argument for locked method call");
2570 char *stashname = SvPV(sv, len);
2571 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2577 MUTEX_UNLOCK(CvMUTEXP(cv));
2578 mg = condpair_magic(sv);
2579 MUTEX_LOCK(MgMUTEXP(mg));
2580 if (MgOWNER(mg) == thr)
2581 MUTEX_UNLOCK(MgMUTEXP(mg));
2584 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2586 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2588 MUTEX_UNLOCK(MgMUTEXP(mg));
2589 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2591 MUTEX_LOCK(CvMUTEXP(cv));
2594 * Now we have permission to enter the sub, we must distinguish
2595 * four cases. (0) It's an XSUB (in which case we don't care
2596 * about ownership); (1) it's ours already (and we're recursing);
2597 * (2) it's free (but we may already be using a cached clone);
2598 * (3) another thread owns it. Case (1) is easy: we just use it.
2599 * Case (2) means we look for a clone--if we have one, use it
2600 * otherwise grab ownership of cv. Case (3) means we look for a
2601 * clone (for non-XSUBs) and have to create one if we don't
2603 * Why look for a clone in case (2) when we could just grab
2604 * ownership of cv straight away? Well, we could be recursing,
2605 * i.e. we originally tried to enter cv while another thread
2606 * owned it (hence we used a clone) but it has been freed up
2607 * and we're now recursing into it. It may or may not be "better"
2608 * to use the clone but at least CvDEPTH can be trusted.
2610 if (CvOWNER(cv) == thr || CvXSUB(cv))
2611 MUTEX_UNLOCK(CvMUTEXP(cv));
2613 /* Case (2) or (3) */
2617 * XXX Might it be better to release CvMUTEXP(cv) while we
2618 * do the hv_fetch? We might find someone has pinched it
2619 * when we look again, in which case we would be in case
2620 * (3) instead of (2) so we'd have to clone. Would the fact
2621 * that we released the mutex more quickly make up for this?
2623 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2625 /* We already have a clone to use */
2626 MUTEX_UNLOCK(CvMUTEXP(cv));
2628 DEBUG_S(PerlIO_printf(Perl_debug_log,
2629 "entersub: %p already has clone %p:%s\n",
2630 thr, cv, SvPEEK((SV*)cv)));
2633 if (CvDEPTH(cv) == 0)
2634 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2637 /* (2) => grab ownership of cv. (3) => make clone */
2641 MUTEX_UNLOCK(CvMUTEXP(cv));
2642 DEBUG_S(PerlIO_printf(Perl_debug_log,
2643 "entersub: %p grabbing %p:%s in stash %s\n",
2644 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2645 HvNAME(CvSTASH(cv)) : "(none)"));
2648 /* Make a new clone. */
2650 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2651 MUTEX_UNLOCK(CvMUTEXP(cv));
2652 DEBUG_S((PerlIO_printf(Perl_debug_log,
2653 "entersub: %p cloning %p:%s\n",
2654 thr, cv, SvPEEK((SV*)cv))));
2656 * We're creating a new clone so there's no race
2657 * between the original MUTEX_UNLOCK and the
2658 * SvREFCNT_inc since no one will be trying to undef
2659 * it out from underneath us. At least, I don't think
2662 clonecv = cv_clone(cv);
2663 SvREFCNT_dec(cv); /* finished with this */
2664 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2665 CvOWNER(clonecv) = thr;
2669 DEBUG_S(if (CvDEPTH(cv) != 0)
2670 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2672 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2675 #endif /* USE_5005THREADS */
2678 #ifdef PERL_XSUB_OLDSTYLE
2679 if (CvOLDSTYLE(cv)) {
2680 I32 (*fp3)(int,int,int);
2682 register I32 items = SP - MARK;
2683 /* We dont worry to copy from @_. */
2688 PL_stack_sp = mark + 1;
2689 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2690 items = (*fp3)(CvXSUBANY(cv).any_i32,
2691 MARK - PL_stack_base + 1,
2693 PL_stack_sp = PL_stack_base + items;
2696 #endif /* PERL_XSUB_OLDSTYLE */
2698 I32 markix = TOPMARK;
2703 /* Need to copy @_ to stack. Alternative may be to
2704 * switch stack to @_, and copy return values
2705 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2708 #ifdef USE_5005THREADS
2709 av = (AV*)PL_curpad[0];
2711 av = GvAV(PL_defgv);
2712 #endif /* USE_5005THREADS */
2713 items = AvFILLp(av) + 1; /* @_ is not tieable */
2716 /* Mark is at the end of the stack. */
2718 Copy(AvARRAY(av), SP + 1, items, SV*);
2723 /* We assume first XSUB in &DB::sub is the called one. */
2725 SAVEVPTR(PL_curcop);
2726 PL_curcop = PL_curcopdb;
2729 /* Do we need to open block here? XXXX */
2730 (void)(*CvXSUB(cv))(aTHX_ cv);
2732 /* Enforce some sanity in scalar context. */
2733 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2734 if (markix > PL_stack_sp - PL_stack_base)
2735 *(PL_stack_base + markix) = &PL_sv_undef;
2737 *(PL_stack_base + markix) = *PL_stack_sp;
2738 PL_stack_sp = PL_stack_base + markix;
2746 register I32 items = SP - MARK;
2747 AV* padlist = CvPADLIST(cv);
2748 SV** svp = AvARRAY(padlist);
2749 push_return(PL_op->op_next);
2750 PUSHBLOCK(cx, CXt_SUB, MARK);
2753 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2754 * that eval'' ops within this sub know the correct lexical space.
2755 * Owing the speed considerations, we choose to search for the cv
2756 * in doeval() instead.
2758 if (CvDEPTH(cv) < 2)
2759 (void)SvREFCNT_inc(cv);
2760 else { /* save temporaries on recursion? */
2761 PERL_STACK_OVERFLOW_CHECK();
2762 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2764 AV *newpad = newAV();
2765 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2766 I32 ix = AvFILLp((AV*)svp[1]);
2767 I32 names_fill = AvFILLp((AV*)svp[0]);
2768 svp = AvARRAY(svp[0]);
2769 for ( ;ix > 0; ix--) {
2770 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2771 char *name = SvPVX(svp[ix]);
2772 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2773 || *name == '&') /* anonymous code? */
2775 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2777 else { /* our own lexical */
2779 av_store(newpad, ix, sv = (SV*)newAV());
2780 else if (*name == '%')
2781 av_store(newpad, ix, sv = (SV*)newHV());
2783 av_store(newpad, ix, sv = NEWSV(0,0));
2787 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2788 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2791 av_store(newpad, ix, sv = NEWSV(0,0));
2795 av = newAV(); /* will be @_ */
2797 av_store(newpad, 0, (SV*)av);
2798 AvFLAGS(av) = AVf_REIFY;
2799 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2800 AvFILLp(padlist) = CvDEPTH(cv);
2801 svp = AvARRAY(padlist);
2804 #ifdef USE_5005THREADS
2806 AV* av = (AV*)PL_curpad[0];
2808 items = AvFILLp(av) + 1;
2810 /* Mark is at the end of the stack. */
2812 Copy(AvARRAY(av), SP + 1, items, SV*);
2817 #endif /* USE_5005THREADS */
2818 SAVEVPTR(PL_curpad);
2819 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2820 #ifndef USE_5005THREADS
2822 #endif /* USE_5005THREADS */
2828 DEBUG_S(PerlIO_printf(Perl_debug_log,
2829 "%p entersub preparing @_\n", thr));
2831 av = (AV*)PL_curpad[0];
2833 /* @_ is normally not REAL--this should only ever
2834 * happen when DB::sub() calls things that modify @_ */
2839 #ifndef USE_5005THREADS
2840 cx->blk_sub.savearray = GvAV(PL_defgv);
2841 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2842 #endif /* USE_5005THREADS */
2843 cx->blk_sub.oldcurpad = PL_curpad;
2844 cx->blk_sub.argarray = av;
2847 if (items > AvMAX(av) + 1) {
2849 if (AvARRAY(av) != ary) {
2850 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2851 SvPVX(av) = (char*)ary;
2853 if (items > AvMAX(av) + 1) {
2854 AvMAX(av) = items - 1;
2855 Renew(ary,items,SV*);
2857 SvPVX(av) = (char*)ary;
2860 Copy(MARK,AvARRAY(av),items,SV*);
2861 AvFILLp(av) = items - 1;
2869 /* warning must come *after* we fully set up the context
2870 * stuff so that __WARN__ handlers can safely dounwind()
2873 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2874 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2875 sub_crush_depth(cv);
2877 DEBUG_S(PerlIO_printf(Perl_debug_log,
2878 "%p entersub returning %p\n", thr, CvSTART(cv)));
2880 RETURNOP(CvSTART(cv));
2885 Perl_sub_crush_depth(pTHX_ CV *cv)
2888 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2890 SV* tmpstr = sv_newmortal();
2891 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2892 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2902 IV elem = SvIV(elemsv);
2904 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2905 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2908 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2909 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2911 elem -= PL_curcop->cop_arybase;
2912 if (SvTYPE(av) != SVt_PVAV)
2914 svp = av_fetch(av, elem, lval && !defer);
2916 if (!svp || *svp == &PL_sv_undef) {
2919 DIE(aTHX_ PL_no_aelem, elem);
2920 lv = sv_newmortal();
2921 sv_upgrade(lv, SVt_PVLV);
2923 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2924 LvTARG(lv) = SvREFCNT_inc(av);
2925 LvTARGOFF(lv) = elem;
2930 if (PL_op->op_private & OPpLVAL_INTRO)
2931 save_aelem(av, elem, svp);
2932 else if (PL_op->op_private & OPpDEREF)
2933 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2935 sv = (svp ? *svp : &PL_sv_undef);
2936 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2937 sv = sv_mortalcopy(sv);
2943 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2949 Perl_croak(aTHX_ PL_no_modify);
2950 if (SvTYPE(sv) < SVt_RV)
2951 sv_upgrade(sv, SVt_RV);
2952 else if (SvTYPE(sv) >= SVt_PV) {
2953 (void)SvOOK_off(sv);
2954 Safefree(SvPVX(sv));
2955 SvLEN(sv) = SvCUR(sv) = 0;
2959 SvRV(sv) = NEWSV(355,0);
2962 SvRV(sv) = (SV*)newAV();
2965 SvRV(sv) = (SV*)newHV();
2980 if (SvTYPE(rsv) == SVt_PVCV) {
2986 SETs(method_common(sv, Null(U32*)));
2993 SV* sv = cSVOP->op_sv;
2994 U32 hash = SvUVX(sv);
2996 XPUSHs(method_common(sv, &hash));
3001 S_method_common(pTHX_ SV* meth, U32* hashp)
3012 name = SvPV(meth, namelen);
3013 sv = *(PL_stack_base + TOPMARK + 1);
3016 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3025 /* this isn't a reference */
3028 !(packname = SvPV(sv, packlen)) ||
3029 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3030 !(ob=(SV*)GvIO(iogv)))
3032 /* this isn't the name of a filehandle either */
3034 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3035 ? !isIDFIRST_utf8((U8*)packname)
3036 : !isIDFIRST(*packname)
3039 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3040 SvOK(sv) ? "without a package or object reference"
3041 : "on an undefined value");
3043 /* assume it's a package name */
3044 stash = gv_stashpvn(packname, packlen, FALSE);
3047 /* it _is_ a filehandle name -- replace with a reference */
3048 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3051 /* if we got here, ob should be a reference or a glob */
3052 if (!ob || !(SvOBJECT(ob)
3053 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3056 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3060 stash = SvSTASH(ob);
3063 /* NOTE: stash may be null, hope hv_fetch_ent and
3064 gv_fetchmethod can cope (it seems they can) */
3066 /* shortcut for simple names */
3068 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3070 gv = (GV*)HeVAL(he);
3071 if (isGV(gv) && GvCV(gv) &&
3072 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3073 return (SV*)GvCV(gv);
3077 gv = gv_fetchmethod(stash, name);
3080 /* This code tries to figure out just what went wrong with
3081 gv_fetchmethod. It therefore needs to duplicate a lot of
3082 the internals of that function. We can't move it inside
3083 Perl_gv_fetchmethod_autoload(), however, since that would
3084 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3091 for (p = name; *p; p++) {
3093 sep = p, leaf = p + 1;
3094 else if (*p == ':' && *(p + 1) == ':')
3095 sep = p, leaf = p + 2;
3097 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3098 /* the method name is unqualified or starts with SUPER:: */
3099 packname = sep ? CopSTASHPV(PL_curcop) :
3100 stash ? HvNAME(stash) : packname;
3101 packlen = strlen(packname);
3104 /* the method name is qualified */
3106 packlen = sep - name;
3109 /* we're relying on gv_fetchmethod not autovivifying the stash */
3110 if (gv_stashpvn(packname, packlen, FALSE)) {
3112 "Can't locate object method \"%s\" via package \"%.*s\"",
3113 leaf, (int)packlen, packname);
3117 "Can't locate object method \"%s\" via package \"%.*s\""
3118 " (perhaps you forgot to load \"%.*s\"?)",
3119 leaf, (int)packlen, packname, (int)packlen, packname);
3122 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3125 #ifdef USE_5005THREADS
3127 unset_cvowner(pTHX_ void *cvarg)
3129 register CV* cv = (CV *) cvarg;
3131 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3132 thr, cv, SvPEEK((SV*)cv))));
3133 MUTEX_LOCK(CvMUTEXP(cv));
3134 DEBUG_S(if (CvDEPTH(cv) != 0)
3135 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3137 assert(thr == CvOWNER(cv));
3139 MUTEX_UNLOCK(CvMUTEXP(cv));
3142 #endif /* USE_5005THREADS */