3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
14 * Awake! Awake! Fear, Fire, Foes! Awake!
19 #define PERL_IN_PP_HOT_C
24 #ifdef USE_5005THREADS
25 static void unset_cvowner(pTHX_ void *cvarg);
26 #endif /* USE_5005THREADS */
37 PL_curcop = (COP*)PL_op;
38 TAINT_NOT; /* Each statement is presumed innocent */
39 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
48 if (PL_op->op_private & OPpLVAL_INTRO)
49 PUSHs(save_scalar(cGVOP_gv));
51 PUSHs(GvSV(cGVOP_gv));
62 PL_curcop = (COP*)PL_op;
68 PUSHMARK(PL_stack_sp);
78 sv_setpvn(TARG,s,len);
90 XPUSHs((SV*)cGVOP_gv);
101 RETURNOP(cLOGOP->op_other);
109 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
111 temp = left; left = right; right = temp;
113 if (PL_tainting && PL_tainted && !SvTAINTED(left))
115 SvSetMagicSV(right, left);
124 RETURNOP(cLOGOP->op_other);
126 RETURNOP(cLOGOP->op_next);
132 TAINT_NOT; /* Each statement is presumed innocent */
133 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
135 oldsave = PL_scopestack[PL_scopestack_ix - 1];
136 LEAVE_SCOPE(oldsave);
142 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
149 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
150 bool rbyte = !SvUTF8(right);
152 if (TARG == right && right != left) {
153 right = sv_2mortal(newSVpvn(rpv, rlen));
154 rpv = SvPV(right, rlen); /* no point setting UTF8 here */
158 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
159 lbyte = !SvUTF8(left);
160 sv_setpvn(TARG, lpv, llen);
166 else { /* TARG == left */
167 if (SvGMAGICAL(left))
168 mg_get(left); /* or mg_get(left) may happen here */
171 lpv = SvPV_nomg(left, llen);
172 lbyte = !SvUTF8(left);
175 #if defined(PERL_Y2KWARN)
176 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
177 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
178 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
180 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
181 "about to append an integer to '19'");
186 if (lbyte != rbyte) {
188 sv_utf8_upgrade_nomg(TARG);
190 sv_utf8_upgrade_nomg(right);
191 rpv = SvPV(right, rlen);
194 sv_catpvn_nomg(TARG, rpv, rlen);
205 if (PL_op->op_flags & OPf_MOD) {
206 if (PL_op->op_private & OPpLVAL_INTRO)
207 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
208 else if (PL_op->op_private & OPpDEREF) {
210 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
219 tryAMAGICunTARGET(iter, 0);
220 PL_last_in_gv = (GV*)(*PL_stack_sp--);
221 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
222 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
223 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
226 XPUSHs((SV*)PL_last_in_gv);
229 PL_last_in_gv = (GV*)(*PL_stack_sp--);
232 return do_readline();
237 dSP; tryAMAGICbinSET(eq,0);
238 #ifndef NV_PRESERVES_UV
239 if (SvROK(TOPs) && SvROK(TOPm1s)) {
241 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
245 #ifdef PERL_PRESERVE_IVUV
248 /* Unless the left argument is integer in range we are going
249 to have to use NV maths. Hence only attempt to coerce the
250 right argument if we know the left is integer. */
253 bool auvok = SvUOK(TOPm1s);
254 bool buvok = SvUOK(TOPs);
256 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
257 /* Casting IV to UV before comparison isn't going to matter
258 on 2s complement. On 1s complement or sign&magnitude
259 (if we have any of them) it could to make negative zero
260 differ from normal zero. As I understand it. (Need to
261 check - is negative zero implementation defined behaviour
263 UV buv = SvUVX(POPs);
264 UV auv = SvUVX(TOPs);
266 SETs(boolSV(auv == buv));
269 { /* ## Mixed IV,UV ## */
273 /* == is commutative so doesn't matter which is left or right */
275 /* top of stack (b) is the iv */
284 /* As uv is a UV, it's >0, so it cannot be == */
288 /* we know iv is >= 0 */
289 SETs(boolSV((UV)iv == SvUVX(uvp)));
297 SETs(boolSV(TOPn == value));
305 if (SvTYPE(TOPs) > SVt_PVLV)
306 DIE(aTHX_ PL_no_modify);
307 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
308 && SvIVX(TOPs) != IV_MAX)
311 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
313 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
326 RETURNOP(cLOGOP->op_other);
332 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
333 useleft = USE_LEFT(TOPm1s);
334 #ifdef PERL_PRESERVE_IVUV
335 /* We must see if we can perform the addition with integers if possible,
336 as the integer code detects overflow while the NV code doesn't.
337 If either argument hasn't had a numeric conversion yet attempt to get
338 the IV. It's important to do this now, rather than just assuming that
339 it's not IOK as a PV of "9223372036854775806" may not take well to NV
340 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
341 integer in case the second argument is IV=9223372036854775806
342 We can (now) rely on sv_2iv to do the right thing, only setting the
343 public IOK flag if the value in the NV (or PV) slot is truly integer.
345 A side effect is that this also aggressively prefers integer maths over
346 fp maths for integer values.
348 How to detect overflow?
350 C 99 section 6.2.6.1 says
352 The range of nonnegative values of a signed integer type is a subrange
353 of the corresponding unsigned integer type, and the representation of
354 the same value in each type is the same. A computation involving
355 unsigned operands can never overflow, because a result that cannot be
356 represented by the resulting unsigned integer type is reduced modulo
357 the number that is one greater than the largest value that can be
358 represented by the resulting type.
362 which I read as "unsigned ints wrap."
364 signed integer overflow seems to be classed as "exception condition"
366 If an exceptional condition occurs during the evaluation of an
367 expression (that is, if the result is not mathematically defined or not
368 in the range of representable values for its type), the behavior is
371 (6.5, the 5th paragraph)
373 I had assumed that on 2s complement machines signed arithmetic would
374 wrap, hence coded pp_add and pp_subtract on the assumption that
375 everything perl builds on would be happy. After much wailing and
376 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
377 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
378 unsigned code below is actually shorter than the old code. :-)
383 /* Unless the left argument is integer in range we are going to have to
384 use NV maths. Hence only attempt to coerce the right argument if
385 we know the left is integer. */
393 /* left operand is undef, treat as zero. + 0 is identity,
394 Could SETi or SETu right now, but space optimise by not adding
395 lots of code to speed up what is probably a rarish case. */
397 /* Left operand is defined, so is it IV? */
400 if ((auvok = SvUOK(TOPm1s)))
403 register IV aiv = SvIVX(TOPm1s);
406 auvok = 1; /* Now acting as a sign flag. */
407 } else { /* 2s complement assumption for IV_MIN */
415 bool result_good = 0;
418 bool buvok = SvUOK(TOPs);
423 register IV biv = SvIVX(TOPs);
430 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
431 else "IV" now, independant of how it came in.
432 if a, b represents positive, A, B negative, a maps to -A etc
437 all UV maths. negate result if A negative.
438 add if signs same, subtract if signs differ. */
444 /* Must get smaller */
450 /* result really should be -(auv-buv). as its negation
451 of true value, need to swap our result flag */
468 if (result <= (UV)IV_MIN)
471 /* result valid, but out of range for IV. */
476 } /* Overflow, drop through to NVs. */
483 /* left operand is undef, treat as zero. + 0.0 is identity. */
487 SETn( value + TOPn );
495 AV *av = GvAV(cGVOP_gv);
496 U32 lval = PL_op->op_flags & OPf_MOD;
497 SV** svp = av_fetch(av, PL_op->op_private, lval);
498 SV *sv = (svp ? *svp : &PL_sv_undef);
500 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
501 sv = sv_mortalcopy(sv);
510 do_join(TARG, *MARK, MARK, SP);
521 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
522 * will be enough to hold an OP*.
524 SV* sv = sv_newmortal();
525 sv_upgrade(sv, SVt_PVLV);
527 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
535 /* Oversized hot code. */
539 dSP; dMARK; dORIGMARK;
545 if (PL_op->op_flags & OPf_STACKED)
550 if (gv && (io = GvIO(gv))
551 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
554 if (MARK == ORIGMARK) {
555 /* If using default handle then we need to make space to
556 * pass object as 1st arg, so move other args up ...
560 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
564 *MARK = SvTIED_obj((SV*)io, mg);
567 call_method("PRINT", G_SCALAR);
575 if (!(io = GvIO(gv))) {
576 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
577 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
579 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
580 report_evil_fh(gv, io, PL_op->op_type);
581 SETERRNO(EBADF,RMS$_IFI);
584 else if (!(fp = IoOFP(io))) {
585 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
587 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
588 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
589 report_evil_fh(gv, io, PL_op->op_type);
591 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
596 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
598 if (!do_print(*MARK, fp))
602 if (!do_print(PL_ofs_sv, fp)) { /* $, */
611 if (!do_print(*MARK, fp))
619 if (PL_ors_sv && SvOK(PL_ors_sv))
620 if (!do_print(PL_ors_sv, fp)) /* $\ */
623 if (IoFLAGS(io) & IOf_FLUSH)
624 if (PerlIO_flush(fp) == EOF)
645 tryAMAGICunDEREF(to_av);
648 if (SvTYPE(av) != SVt_PVAV)
649 DIE(aTHX_ "Not an ARRAY reference");
650 if (PL_op->op_flags & OPf_REF) {
655 if (GIMME == G_SCALAR)
656 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
662 if (SvTYPE(sv) == SVt_PVAV) {
664 if (PL_op->op_flags & OPf_REF) {
669 if (GIMME == G_SCALAR)
670 Perl_croak(aTHX_ "Can't return array to lvalue"
679 if (SvTYPE(sv) != SVt_PVGV) {
683 if (SvGMAGICAL(sv)) {
689 if (PL_op->op_flags & OPf_REF ||
690 PL_op->op_private & HINT_STRICT_REFS)
691 DIE(aTHX_ PL_no_usym, "an ARRAY");
692 if (ckWARN(WARN_UNINITIALIZED))
694 if (GIMME == G_ARRAY) {
701 if ((PL_op->op_flags & OPf_SPECIAL) &&
702 !(PL_op->op_flags & OPf_MOD))
704 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
706 && (!is_gv_magical(sym,len,0)
707 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
713 if (PL_op->op_private & HINT_STRICT_REFS)
714 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
715 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
722 if (PL_op->op_private & OPpLVAL_INTRO)
724 if (PL_op->op_flags & OPf_REF) {
729 if (GIMME == G_SCALAR)
730 Perl_croak(aTHX_ "Can't return array to lvalue"
738 if (GIMME == G_ARRAY) {
739 I32 maxarg = AvFILL(av) + 1;
740 (void)POPs; /* XXXX May be optimized away? */
742 if (SvRMAGICAL(av)) {
744 for (i=0; i < maxarg; i++) {
745 SV **svp = av_fetch(av, i, FALSE);
746 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
750 Copy(AvARRAY(av), SP+1, maxarg, SV*);
756 I32 maxarg = AvFILL(av) + 1;
769 tryAMAGICunDEREF(to_hv);
772 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
773 DIE(aTHX_ "Not a HASH reference");
774 if (PL_op->op_flags & OPf_REF) {
779 if (GIMME == G_SCALAR)
780 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
786 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
788 if (PL_op->op_flags & OPf_REF) {
793 if (GIMME == G_SCALAR)
794 Perl_croak(aTHX_ "Can't return hash to lvalue"
803 if (SvTYPE(sv) != SVt_PVGV) {
807 if (SvGMAGICAL(sv)) {
813 if (PL_op->op_flags & OPf_REF ||
814 PL_op->op_private & HINT_STRICT_REFS)
815 DIE(aTHX_ PL_no_usym, "a HASH");
816 if (ckWARN(WARN_UNINITIALIZED))
818 if (GIMME == G_ARRAY) {
825 if ((PL_op->op_flags & OPf_SPECIAL) &&
826 !(PL_op->op_flags & OPf_MOD))
828 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
830 && (!is_gv_magical(sym,len,0)
831 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
837 if (PL_op->op_private & HINT_STRICT_REFS)
838 DIE(aTHX_ PL_no_symref, sym, "a HASH");
839 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
846 if (PL_op->op_private & OPpLVAL_INTRO)
848 if (PL_op->op_flags & OPf_REF) {
853 if (GIMME == G_SCALAR)
854 Perl_croak(aTHX_ "Can't return hash to lvalue"
862 if (GIMME == G_ARRAY) { /* array wanted */
863 *PL_stack_sp = (SV*)hv;
868 if (SvTYPE(hv) == SVt_PVAV)
869 hv = avhv_keys((AV*)hv);
871 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
872 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
882 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
888 leftop = ((BINOP*)PL_op)->op_last;
890 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
891 leftop = ((LISTOP*)leftop)->op_first;
893 /* Skip PUSHMARK and each element already assigned to. */
894 for (i = lelem - firstlelem; i > 0; i--) {
895 leftop = leftop->op_sibling;
898 if (leftop->op_type != OP_RV2HV)
903 av_fill(ary, 0); /* clear all but the fields hash */
904 if (lastrelem >= relem) {
905 while (relem < lastrelem) { /* gobble up all the rest */
909 /* Avoid a memory leak when avhv_store_ent dies. */
910 tmpstr = sv_newmortal();
911 sv_setsv(tmpstr,relem[1]); /* value */
913 if (avhv_store_ent(ary,relem[0],tmpstr,0))
914 (void)SvREFCNT_inc(tmpstr);
915 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
921 if (relem == lastrelem)
927 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
931 if (ckWARN(WARN_MISC)) {
932 if (relem == firstrelem &&
934 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
935 SvTYPE(SvRV(*relem)) == SVt_PVHV))
937 Perl_warner(aTHX_ WARN_MISC,
938 "Reference found where even-sized list expected");
941 Perl_warner(aTHX_ WARN_MISC,
942 "Odd number of elements in hash assignment");
944 if (SvTYPE(hash) == SVt_PVAV) {
946 tmpstr = sv_newmortal();
947 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
948 (void)SvREFCNT_inc(tmpstr);
949 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
954 tmpstr = NEWSV(29,0);
955 didstore = hv_store_ent(hash,*relem,tmpstr,0);
956 if (SvMAGICAL(hash)) {
957 if (SvSMAGICAL(tmpstr))
970 SV **lastlelem = PL_stack_sp;
971 SV **lastrelem = PL_stack_base + POPMARK;
972 SV **firstrelem = PL_stack_base + POPMARK + 1;
973 SV **firstlelem = lastrelem + 1;
986 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
988 /* If there's a common identifier on both sides we have to take
989 * special care that assigning the identifier on the left doesn't
990 * clobber a value on the right that's used later in the list.
992 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
993 EXTEND_MORTAL(lastrelem - firstrelem + 1);
994 for (relem = firstrelem; relem <= lastrelem; relem++) {
997 TAINT_NOT; /* Each item is independent */
998 *relem = sv_mortalcopy(sv);
1008 while (lelem <= lastlelem) {
1009 TAINT_NOT; /* Each item stands on its own, taintwise. */
1011 switch (SvTYPE(sv)) {
1014 magic = SvMAGICAL(ary) != 0;
1015 if (PL_op->op_private & OPpASSIGN_HASH) {
1016 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1022 do_oddball((HV*)ary, relem, firstrelem);
1024 relem = lastrelem + 1;
1029 av_extend(ary, lastrelem - relem);
1031 while (relem <= lastrelem) { /* gobble up all the rest */
1035 sv_setsv(sv,*relem);
1037 didstore = av_store(ary,i++,sv);
1047 case SVt_PVHV: { /* normal hash */
1051 magic = SvMAGICAL(hash) != 0;
1054 while (relem < lastrelem) { /* gobble up all the rest */
1059 sv = &PL_sv_no, relem++;
1060 tmpstr = NEWSV(29,0);
1062 sv_setsv(tmpstr,*relem); /* value */
1063 *(relem++) = tmpstr;
1064 didstore = hv_store_ent(hash,sv,tmpstr,0);
1066 if (SvSMAGICAL(tmpstr))
1073 if (relem == lastrelem) {
1074 do_oddball(hash, relem, firstrelem);
1080 if (SvIMMORTAL(sv)) {
1081 if (relem <= lastrelem)
1085 if (relem <= lastrelem) {
1086 sv_setsv(sv, *relem);
1090 sv_setsv(sv, &PL_sv_undef);
1095 if (PL_delaymagic & ~DM_DELAY) {
1096 if (PL_delaymagic & DM_UID) {
1097 #ifdef HAS_SETRESUID
1098 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1100 # ifdef HAS_SETREUID
1101 (void)setreuid(PL_uid,PL_euid);
1104 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1105 (void)setruid(PL_uid);
1106 PL_delaymagic &= ~DM_RUID;
1108 # endif /* HAS_SETRUID */
1110 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1111 (void)seteuid(PL_uid);
1112 PL_delaymagic &= ~DM_EUID;
1114 # endif /* HAS_SETEUID */
1115 if (PL_delaymagic & DM_UID) {
1116 if (PL_uid != PL_euid)
1117 DIE(aTHX_ "No setreuid available");
1118 (void)PerlProc_setuid(PL_uid);
1120 # endif /* HAS_SETREUID */
1121 #endif /* HAS_SETRESUID */
1122 PL_uid = PerlProc_getuid();
1123 PL_euid = PerlProc_geteuid();
1125 if (PL_delaymagic & DM_GID) {
1126 #ifdef HAS_SETRESGID
1127 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1129 # ifdef HAS_SETREGID
1130 (void)setregid(PL_gid,PL_egid);
1133 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1134 (void)setrgid(PL_gid);
1135 PL_delaymagic &= ~DM_RGID;
1137 # endif /* HAS_SETRGID */
1139 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1140 (void)setegid(PL_gid);
1141 PL_delaymagic &= ~DM_EGID;
1143 # endif /* HAS_SETEGID */
1144 if (PL_delaymagic & DM_GID) {
1145 if (PL_gid != PL_egid)
1146 DIE(aTHX_ "No setregid available");
1147 (void)PerlProc_setgid(PL_gid);
1149 # endif /* HAS_SETREGID */
1150 #endif /* HAS_SETRESGID */
1151 PL_gid = PerlProc_getgid();
1152 PL_egid = PerlProc_getegid();
1154 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1159 if (gimme == G_VOID)
1160 SP = firstrelem - 1;
1161 else if (gimme == G_SCALAR) {
1164 SETi(lastrelem - firstrelem + 1);
1170 SP = firstrelem + (lastlelem - firstlelem);
1171 lelem = firstlelem + (relem - firstrelem);
1173 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1181 register PMOP *pm = cPMOP;
1182 SV *rv = sv_newmortal();
1183 SV *sv = newSVrv(rv, "Regexp");
1184 if (pm->op_pmdynflags & PMdf_TAINTED)
1186 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1193 register PMOP *pm = cPMOP;
1198 I32 r_flags = REXEC_CHECKED;
1199 char *truebase; /* Start of string */
1200 register REGEXP *rx = PM_GETRE(pm);
1205 I32 oldsave = PL_savestack_ix;
1206 I32 update_minmatch = 1;
1207 I32 had_zerolen = 0;
1209 if (PL_op->op_flags & OPf_STACKED)
1216 PUTBACK; /* EVAL blocks need stack_sp. */
1217 s = SvPV(TARG, len);
1220 DIE(aTHX_ "panic: pp_match");
1221 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1222 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1225 PL_reg_match_utf8 = DO_UTF8(TARG);
1227 if (pm->op_pmdynflags & PMdf_USED) {
1229 if (gimme == G_ARRAY)
1234 if (!rx->prelen && PL_curpm) {
1238 if (rx->minlen > len)
1243 /* XXXX What part of this is needed with true \G-support? */
1244 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1246 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1247 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1248 if (mg && mg->mg_len >= 0) {
1249 if (!(rx->reganch & ROPT_GPOS_SEEN))
1250 rx->endp[0] = rx->startp[0] = mg->mg_len;
1251 else if (rx->reganch & ROPT_ANCH_GPOS) {
1252 r_flags |= REXEC_IGNOREPOS;
1253 rx->endp[0] = rx->startp[0] = mg->mg_len;
1255 minmatch = (mg->mg_flags & MGf_MINMATCH);
1256 update_minmatch = 0;
1260 if ((!global && rx->nparens)
1261 || SvTEMP(TARG) || PL_sawampersand)
1262 r_flags |= REXEC_COPY_STR;
1264 r_flags |= REXEC_SCREAM;
1266 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1267 SAVEINT(PL_multiline);
1268 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1272 if (global && rx->startp[0] != -1) {
1273 t = s = rx->endp[0] + truebase;
1274 if ((s + rx->minlen) > strend)
1276 if (update_minmatch++)
1277 minmatch = had_zerolen;
1279 if (rx->reganch & RE_USE_INTUIT &&
1280 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1281 PL_bostr = truebase;
1282 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1286 if ( (rx->reganch & ROPT_CHECK_ALL)
1288 && ((rx->reganch & ROPT_NOSCAN)
1289 || !((rx->reganch & RE_INTUIT_TAIL)
1290 && (r_flags & REXEC_SCREAM)))
1291 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1294 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1297 if (pm->op_pmflags & PMf_ONCE)
1298 pm->op_pmdynflags |= PMdf_USED;
1307 RX_MATCH_TAINTED_on(rx);
1308 TAINT_IF(RX_MATCH_TAINTED(rx));
1309 if (gimme == G_ARRAY) {
1310 I32 nparens, i, len;
1312 nparens = rx->nparens;
1313 if (global && !nparens)
1317 SPAGAIN; /* EVAL blocks could move the stack. */
1318 EXTEND(SP, nparens + i);
1319 EXTEND_MORTAL(nparens + i);
1320 for (i = !i; i <= nparens; i++) {
1321 PUSHs(sv_newmortal());
1323 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1324 len = rx->endp[i] - rx->startp[i];
1325 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1326 len < 0 || len > strend - s)
1327 DIE(aTHX_ "panic: pp_match start/end pointers");
1328 s = rx->startp[i] + truebase;
1329 sv_setpvn(*SP, s, len);
1330 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1335 if (pm->op_pmflags & PMf_CONTINUE) {
1337 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1338 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1340 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1341 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1343 if (rx->startp[0] != -1) {
1344 mg->mg_len = rx->endp[0];
1345 if (rx->startp[0] == rx->endp[0])
1346 mg->mg_flags |= MGf_MINMATCH;
1348 mg->mg_flags &= ~MGf_MINMATCH;
1351 had_zerolen = (rx->startp[0] != -1
1352 && rx->startp[0] == rx->endp[0]);
1353 PUTBACK; /* EVAL blocks may use stack */
1354 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1359 LEAVE_SCOPE(oldsave);
1365 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1366 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1368 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1369 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1371 if (rx->startp[0] != -1) {
1372 mg->mg_len = rx->endp[0];
1373 if (rx->startp[0] == rx->endp[0])
1374 mg->mg_flags |= MGf_MINMATCH;
1376 mg->mg_flags &= ~MGf_MINMATCH;
1379 LEAVE_SCOPE(oldsave);
1383 yup: /* Confirmed by INTUIT */
1385 RX_MATCH_TAINTED_on(rx);
1386 TAINT_IF(RX_MATCH_TAINTED(rx));
1388 if (pm->op_pmflags & PMf_ONCE)
1389 pm->op_pmdynflags |= PMdf_USED;
1390 if (RX_MATCH_COPIED(rx))
1391 Safefree(rx->subbeg);
1392 RX_MATCH_COPIED_off(rx);
1393 rx->subbeg = Nullch;
1395 rx->subbeg = truebase;
1396 rx->startp[0] = s - truebase;
1397 if (PL_reg_match_utf8) {
1398 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1399 rx->endp[0] = t - truebase;
1402 rx->endp[0] = s - truebase + rx->minlen;
1404 rx->sublen = strend - truebase;
1407 if (PL_sawampersand) {
1410 rx->subbeg = savepvn(t, strend - t);
1411 rx->sublen = strend - t;
1412 RX_MATCH_COPIED_on(rx);
1413 off = rx->startp[0] = s - t;
1414 rx->endp[0] = off + rx->minlen;
1416 else { /* startp/endp are used by @- @+. */
1417 rx->startp[0] = s - truebase;
1418 rx->endp[0] = s - truebase + rx->minlen;
1420 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1421 LEAVE_SCOPE(oldsave);
1426 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1427 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1428 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1433 LEAVE_SCOPE(oldsave);
1434 if (gimme == G_ARRAY)
1440 Perl_do_readline(pTHX)
1442 dSP; dTARGETSTACKED;
1447 register IO *io = GvIO(PL_last_in_gv);
1448 register I32 type = PL_op->op_type;
1449 I32 gimme = GIMME_V;
1452 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1454 XPUSHs(SvTIED_obj((SV*)io, mg));
1457 call_method("READLINE", gimme);
1460 if (gimme == G_SCALAR)
1461 SvSetMagicSV_nosteal(TARG, TOPs);
1468 if (IoFLAGS(io) & IOf_ARGV) {
1469 if (IoFLAGS(io) & IOf_START) {
1471 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1472 IoFLAGS(io) &= ~IOf_START;
1473 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1474 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1475 SvSETMAGIC(GvSV(PL_last_in_gv));
1480 fp = nextargv(PL_last_in_gv);
1481 if (!fp) { /* Note: fp != IoIFP(io) */
1482 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1485 else if (type == OP_GLOB)
1486 fp = Perl_start_glob(aTHX_ POPs, io);
1488 else if (type == OP_GLOB)
1490 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1491 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1495 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1496 && (!io || !(IoFLAGS(io) & IOf_START))) {
1497 if (type == OP_GLOB)
1498 Perl_warner(aTHX_ WARN_GLOB,
1499 "glob failed (can't start child: %s)",
1502 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1504 if (gimme == G_SCALAR) {
1505 (void)SvOK_off(TARG);
1511 if (gimme == G_SCALAR) {
1515 (void)SvUPGRADE(sv, SVt_PV);
1516 tmplen = SvLEN(sv); /* remember if already alloced */
1518 Sv_Grow(sv, 80); /* try short-buffering it */
1519 if (type == OP_RCATLINE)
1525 sv = sv_2mortal(NEWSV(57, 80));
1529 /* This should not be marked tainted if the fp is marked clean */
1530 #define MAYBE_TAINT_LINE(io, sv) \
1531 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1536 /* delay EOF state for a snarfed empty file */
1537 #define SNARF_EOF(gimme,rs,io,sv) \
1538 (gimme != G_SCALAR || SvCUR(sv) \
1539 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1543 if (!sv_gets(sv, fp, offset)
1544 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1546 PerlIO_clearerr(fp);
1547 if (IoFLAGS(io) & IOf_ARGV) {
1548 fp = nextargv(PL_last_in_gv);
1551 (void)do_close(PL_last_in_gv, FALSE);
1553 else if (type == OP_GLOB) {
1554 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1555 Perl_warner(aTHX_ WARN_GLOB,
1556 "glob failed (child exited with status %d%s)",
1557 (int)(STATUS_CURRENT >> 8),
1558 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1561 if (gimme == G_SCALAR) {
1562 (void)SvOK_off(TARG);
1566 MAYBE_TAINT_LINE(io, sv);
1569 MAYBE_TAINT_LINE(io, sv);
1571 IoFLAGS(io) |= IOf_NOLINE;
1575 if (type == OP_GLOB) {
1578 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1579 tmps = SvEND(sv) - 1;
1580 if (*tmps == *SvPVX(PL_rs)) {
1585 for (tmps = SvPVX(sv); *tmps; tmps++)
1586 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1587 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1589 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1590 (void)POPs; /* Unmatched wildcard? Chuck it... */
1594 if (gimme == G_ARRAY) {
1595 if (SvLEN(sv) - SvCUR(sv) > 20) {
1596 SvLEN_set(sv, SvCUR(sv)+1);
1597 Renew(SvPVX(sv), SvLEN(sv), char);
1599 sv = sv_2mortal(NEWSV(58, 80));
1602 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1603 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1607 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1608 Renew(SvPVX(sv), SvLEN(sv), char);
1617 register PERL_CONTEXT *cx;
1618 I32 gimme = OP_GIMME(PL_op, -1);
1621 if (cxstack_ix >= 0)
1622 gimme = cxstack[cxstack_ix].blk_gimme;
1630 PUSHBLOCK(cx, CXt_BLOCK, SP);
1642 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1643 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1645 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1648 if (SvTYPE(hv) == SVt_PVHV) {
1649 if (PL_op->op_private & OPpLVAL_INTRO)
1650 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1651 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1652 svp = he ? &HeVAL(he) : 0;
1654 else if (SvTYPE(hv) == SVt_PVAV) {
1655 if (PL_op->op_private & OPpLVAL_INTRO)
1656 DIE(aTHX_ "Can't localize pseudo-hash element");
1657 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1663 if (!svp || *svp == &PL_sv_undef) {
1668 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1670 lv = sv_newmortal();
1671 sv_upgrade(lv, SVt_PVLV);
1673 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1674 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1675 LvTARG(lv) = SvREFCNT_inc(hv);
1680 if (PL_op->op_private & OPpLVAL_INTRO) {
1681 if (HvNAME(hv) && isGV(*svp))
1682 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1686 char *key = SvPV(keysv, keylen);
1687 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1689 save_helem(hv, keysv, svp);
1692 else if (PL_op->op_private & OPpDEREF)
1693 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1695 sv = (svp ? *svp : &PL_sv_undef);
1696 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1697 * Pushing the magical RHS on to the stack is useless, since
1698 * that magic is soon destined to be misled by the local(),
1699 * and thus the later pp_sassign() will fail to mg_get() the
1700 * old value. This should also cure problems with delayed
1701 * mg_get()s. GSAR 98-07-03 */
1702 if (!lval && SvGMAGICAL(sv))
1703 sv = sv_mortalcopy(sv);
1711 register PERL_CONTEXT *cx;
1717 if (PL_op->op_flags & OPf_SPECIAL) {
1718 cx = &cxstack[cxstack_ix];
1719 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1724 gimme = OP_GIMME(PL_op, -1);
1726 if (cxstack_ix >= 0)
1727 gimme = cxstack[cxstack_ix].blk_gimme;
1733 if (gimme == G_VOID)
1735 else if (gimme == G_SCALAR) {
1738 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1741 *MARK = sv_mortalcopy(TOPs);
1744 *MARK = &PL_sv_undef;
1748 else if (gimme == G_ARRAY) {
1749 /* in case LEAVE wipes old return values */
1750 for (mark = newsp + 1; mark <= SP; mark++) {
1751 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1752 *mark = sv_mortalcopy(*mark);
1753 TAINT_NOT; /* Each item is independent */
1757 PL_curpm = newpm; /* Don't pop $1 et al till now */
1767 register PERL_CONTEXT *cx;
1773 cx = &cxstack[cxstack_ix];
1774 if (CxTYPE(cx) != CXt_LOOP)
1775 DIE(aTHX_ "panic: pp_iter");
1777 itersvp = CxITERVAR(cx);
1778 av = cx->blk_loop.iterary;
1779 if (SvTYPE(av) != SVt_PVAV) {
1780 /* iterate ($min .. $max) */
1781 if (cx->blk_loop.iterlval) {
1782 /* string increment */
1783 register SV* cur = cx->blk_loop.iterlval;
1785 char *max = SvPV((SV*)av, maxlen);
1786 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1787 #ifndef USE_5005THREADS /* don't risk potential race */
1788 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1789 /* safe to reuse old SV */
1790 sv_setsv(*itersvp, cur);
1795 /* we need a fresh SV every time so that loop body sees a
1796 * completely new SV for closures/references to work as
1798 SvREFCNT_dec(*itersvp);
1799 *itersvp = newSVsv(cur);
1801 if (strEQ(SvPVX(cur), max))
1802 sv_setiv(cur, 0); /* terminate next time */
1809 /* integer increment */
1810 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1813 #ifndef USE_5005THREADS /* don't risk potential race */
1814 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1815 /* safe to reuse old SV */
1816 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1821 /* we need a fresh SV every time so that loop body sees a
1822 * completely new SV for closures/references to work as they
1824 SvREFCNT_dec(*itersvp);
1825 *itersvp = newSViv(cx->blk_loop.iterix++);
1831 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1834 SvREFCNT_dec(*itersvp);
1836 if (SvMAGICAL(av) || AvREIFY(av)) {
1837 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1844 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1850 if (av != PL_curstack && sv == &PL_sv_undef) {
1851 SV *lv = cx->blk_loop.iterlval;
1852 if (lv && SvREFCNT(lv) > 1) {
1857 SvREFCNT_dec(LvTARG(lv));
1859 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1860 sv_upgrade(lv, SVt_PVLV);
1862 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1864 LvTARG(lv) = SvREFCNT_inc(av);
1865 LvTARGOFF(lv) = cx->blk_loop.iterix;
1866 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1870 *itersvp = SvREFCNT_inc(sv);
1877 register PMOP *pm = cPMOP;
1893 register REGEXP *rx = PM_GETRE(pm);
1895 int force_on_match = 0;
1896 I32 oldsave = PL_savestack_ix;
1899 /* known replacement string? */
1900 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1901 if (PL_op->op_flags & OPf_STACKED)
1908 if (SvFAKE(TARG) && SvREADONLY(TARG))
1909 sv_force_normal(TARG);
1910 if (SvREADONLY(TARG)
1911 || (SvTYPE(TARG) > SVt_PVLV
1912 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1913 DIE(aTHX_ PL_no_modify);
1916 s = SvPV(TARG, len);
1917 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1919 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1920 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1925 PL_reg_match_utf8 = DO_UTF8(TARG);
1929 DIE(aTHX_ "panic: pp_subst");
1932 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1933 maxiters = 2 * slen + 10; /* We can match twice at each
1934 position, once with zero-length,
1935 second time with non-zero. */
1937 if (!rx->prelen && PL_curpm) {
1941 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1942 ? REXEC_COPY_STR : 0;
1944 r_flags |= REXEC_SCREAM;
1945 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1946 SAVEINT(PL_multiline);
1947 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1950 if (rx->reganch & RE_USE_INTUIT) {
1952 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1956 /* How to do it in subst? */
1957 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1959 && ((rx->reganch & ROPT_NOSCAN)
1960 || !((rx->reganch & RE_INTUIT_TAIL)
1961 && (r_flags & REXEC_SCREAM))))
1966 /* only replace once? */
1967 once = !(rpm->op_pmflags & PMf_GLOBAL);
1969 /* known replacement string? */
1970 c = dstr ? SvPV(dstr, clen) : Nullch;
1972 /* can do inplace substitution? */
1973 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1974 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1975 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1976 r_flags | REXEC_CHECKED))
1980 LEAVE_SCOPE(oldsave);
1983 if (force_on_match) {
1985 s = SvPV_force(TARG, len);
1990 SvSCREAM_off(TARG); /* disable possible screamer */
1992 rxtainted |= RX_MATCH_TAINTED(rx);
1993 m = orig + rx->startp[0];
1994 d = orig + rx->endp[0];
1996 if (m - s > strend - d) { /* faster to shorten from end */
1998 Copy(c, m, clen, char);
2003 Move(d, m, i, char);
2007 SvCUR_set(TARG, m - s);
2010 else if ((i = m - s)) { /* faster from front */
2018 Copy(c, m, clen, char);
2023 Copy(c, d, clen, char);
2028 TAINT_IF(rxtainted & 1);
2034 if (iters++ > maxiters)
2035 DIE(aTHX_ "Substitution loop");
2036 rxtainted |= RX_MATCH_TAINTED(rx);
2037 m = rx->startp[0] + orig;
2041 Move(s, d, i, char);
2045 Copy(c, d, clen, char);
2048 s = rx->endp[0] + orig;
2049 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2051 /* don't match same null twice */
2052 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2055 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2056 Move(s, d, i+1, char); /* include the NUL */
2058 TAINT_IF(rxtainted & 1);
2060 PUSHs(sv_2mortal(newSViv((I32)iters)));
2062 (void)SvPOK_only_UTF8(TARG);
2063 TAINT_IF(rxtainted);
2064 if (SvSMAGICAL(TARG)) {
2070 LEAVE_SCOPE(oldsave);
2074 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2075 r_flags | REXEC_CHECKED))
2079 if (force_on_match) {
2081 s = SvPV_force(TARG, len);
2084 rxtainted |= RX_MATCH_TAINTED(rx);
2085 dstr = NEWSV(25, len);
2086 sv_setpvn(dstr, m, s-m);
2091 register PERL_CONTEXT *cx;
2094 RETURNOP(cPMOP->op_pmreplroot);
2096 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2098 if (iters++ > maxiters)
2099 DIE(aTHX_ "Substitution loop");
2100 rxtainted |= RX_MATCH_TAINTED(rx);
2101 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2106 strend = s + (strend - m);
2108 m = rx->startp[0] + orig;
2109 sv_catpvn(dstr, s, m-s);
2110 s = rx->endp[0] + orig;
2112 sv_catpvn(dstr, c, clen);
2115 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2116 TARG, NULL, r_flags));
2117 sv_catpvn(dstr, s, strend - s);
2119 (void)SvOOK_off(TARG);
2120 Safefree(SvPVX(TARG));
2121 SvPVX(TARG) = SvPVX(dstr);
2122 SvCUR_set(TARG, SvCUR(dstr));
2123 SvLEN_set(TARG, SvLEN(dstr));
2124 isutf8 = DO_UTF8(dstr);
2128 TAINT_IF(rxtainted & 1);
2130 PUSHs(sv_2mortal(newSViv((I32)iters)));
2132 (void)SvPOK_only(TARG);
2135 TAINT_IF(rxtainted);
2138 LEAVE_SCOPE(oldsave);
2147 LEAVE_SCOPE(oldsave);
2156 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2157 ++*PL_markstack_ptr;
2158 LEAVE; /* exit inner scope */
2161 if (PL_stack_base + *PL_markstack_ptr > SP) {
2163 I32 gimme = GIMME_V;
2165 LEAVE; /* exit outer scope */
2166 (void)POPMARK; /* pop src */
2167 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2168 (void)POPMARK; /* pop dst */
2169 SP = PL_stack_base + POPMARK; /* pop original mark */
2170 if (gimme == G_SCALAR) {
2174 else if (gimme == G_ARRAY)
2181 ENTER; /* enter inner scope */
2184 src = PL_stack_base[*PL_markstack_ptr];
2188 RETURNOP(cLOGOP->op_other);
2199 register PERL_CONTEXT *cx;
2205 if (gimme == G_SCALAR) {
2208 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2210 *MARK = SvREFCNT_inc(TOPs);
2215 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2217 *MARK = sv_mortalcopy(sv);
2222 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2226 *MARK = &PL_sv_undef;
2230 else if (gimme == G_ARRAY) {
2231 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2232 if (!SvTEMP(*MARK)) {
2233 *MARK = sv_mortalcopy(*MARK);
2234 TAINT_NOT; /* Each item is independent */
2240 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2241 PL_curpm = newpm; /* ... and pop $1 et al */
2245 return pop_return();
2248 /* This duplicates the above code because the above code must not
2249 * get any slower by more conditions */
2257 register PERL_CONTEXT *cx;
2264 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2265 /* We are an argument to a function or grep().
2266 * This kind of lvalueness was legal before lvalue
2267 * subroutines too, so be backward compatible:
2268 * cannot report errors. */
2270 /* Scalar context *is* possible, on the LHS of -> only,
2271 * as in f()->meth(). But this is not an lvalue. */
2272 if (gimme == G_SCALAR)
2274 if (gimme == G_ARRAY) {
2275 if (!CvLVALUE(cx->blk_sub.cv))
2276 goto temporise_array;
2277 EXTEND_MORTAL(SP - newsp);
2278 for (mark = newsp + 1; mark <= SP; mark++) {
2281 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2282 *mark = sv_mortalcopy(*mark);
2284 /* Can be a localized value subject to deletion. */
2285 PL_tmps_stack[++PL_tmps_ix] = *mark;
2286 (void)SvREFCNT_inc(*mark);
2291 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2292 /* Here we go for robustness, not for speed, so we change all
2293 * the refcounts so the caller gets a live guy. Cannot set
2294 * TEMP, so sv_2mortal is out of question. */
2295 if (!CvLVALUE(cx->blk_sub.cv)) {
2300 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2302 if (gimme == G_SCALAR) {
2306 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2311 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2312 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2314 else { /* Can be a localized value
2315 * subject to deletion. */
2316 PL_tmps_stack[++PL_tmps_ix] = *mark;
2317 (void)SvREFCNT_inc(*mark);
2320 else { /* Should not happen? */
2325 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2326 (MARK > SP ? "Empty array" : "Array"));
2330 else if (gimme == G_ARRAY) {
2331 EXTEND_MORTAL(SP - newsp);
2332 for (mark = newsp + 1; mark <= SP; mark++) {
2333 if (*mark != &PL_sv_undef
2334 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2335 /* Might be flattened array after $#array = */
2341 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2342 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2345 /* Can be a localized value subject to deletion. */
2346 PL_tmps_stack[++PL_tmps_ix] = *mark;
2347 (void)SvREFCNT_inc(*mark);
2353 if (gimme == G_SCALAR) {
2357 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2359 *MARK = SvREFCNT_inc(TOPs);
2364 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2366 *MARK = sv_mortalcopy(sv);
2371 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2375 *MARK = &PL_sv_undef;
2379 else if (gimme == G_ARRAY) {
2381 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2382 if (!SvTEMP(*MARK)) {
2383 *MARK = sv_mortalcopy(*MARK);
2384 TAINT_NOT; /* Each item is independent */
2391 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2392 PL_curpm = newpm; /* ... and pop $1 et al */
2396 return pop_return();
2401 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2403 SV *dbsv = GvSV(PL_DBsub);
2405 if (!PERLDB_SUB_NN) {
2409 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2410 || strEQ(GvNAME(gv), "END")
2411 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2412 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2413 && (gv = (GV*)*svp) ))) {
2414 /* Use GV from the stack as a fallback. */
2415 /* GV is potentially non-unique, or contain different CV. */
2416 SV *tmp = newRV((SV*)cv);
2417 sv_setsv(dbsv, tmp);
2421 gv_efullname3(dbsv, gv, Nullch);
2425 (void)SvUPGRADE(dbsv, SVt_PVIV);
2426 (void)SvIOK_on(dbsv);
2427 SAVEIV(SvIVX(dbsv));
2428 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2432 PL_curcopdb = PL_curcop;
2433 cv = GvCV(PL_DBsub);
2443 register PERL_CONTEXT *cx;
2445 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2448 DIE(aTHX_ "Not a CODE reference");
2449 switch (SvTYPE(sv)) {
2455 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2457 SP = PL_stack_base + POPMARK;
2460 if (SvGMAGICAL(sv)) {
2464 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2467 sym = SvPV(sv, n_a);
2469 DIE(aTHX_ PL_no_usym, "a subroutine");
2470 if (PL_op->op_private & HINT_STRICT_REFS)
2471 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2472 cv = get_cv(sym, TRUE);
2477 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2478 tryAMAGICunDEREF(to_cv);
2481 if (SvTYPE(cv) == SVt_PVCV)
2486 DIE(aTHX_ "Not a CODE reference");
2491 if (!(cv = GvCVu((GV*)sv)))
2492 cv = sv_2cv(sv, &stash, &gv, FALSE);
2505 if (!CvROOT(cv) && !CvXSUB(cv)) {
2509 /* anonymous or undef'd function leaves us no recourse */
2510 if (CvANON(cv) || !(gv = CvGV(cv)))
2511 DIE(aTHX_ "Undefined subroutine called");
2513 /* autoloaded stub? */
2514 if (cv != GvCV(gv)) {
2517 /* should call AUTOLOAD now? */
2520 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2527 sub_name = sv_newmortal();
2528 gv_efullname3(sub_name, gv, Nullch);
2529 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2533 DIE(aTHX_ "Not a CODE reference");
2538 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2539 cv = get_db_sub(&sv, cv);
2541 DIE(aTHX_ "No DBsub routine");
2544 #ifdef USE_5005THREADS
2546 * First we need to check if the sub or method requires locking.
2547 * If so, we gain a lock on the CV, the first argument or the
2548 * stash (for static methods), as appropriate. This has to be
2549 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2550 * reschedule by returning a new op.
2552 MUTEX_LOCK(CvMUTEXP(cv));
2553 if (CvFLAGS(cv) & CVf_LOCKED) {
2555 if (CvFLAGS(cv) & CVf_METHOD) {
2556 if (SP > PL_stack_base + TOPMARK)
2557 sv = *(PL_stack_base + TOPMARK + 1);
2559 AV *av = (AV*)PL_curpad[0];
2560 if (hasargs || !av || AvFILLp(av) < 0
2561 || !(sv = AvARRAY(av)[0]))
2563 MUTEX_UNLOCK(CvMUTEXP(cv));
2564 DIE(aTHX_ "no argument for locked method call");
2571 char *stashname = SvPV(sv, len);
2572 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2578 MUTEX_UNLOCK(CvMUTEXP(cv));
2579 mg = condpair_magic(sv);
2580 MUTEX_LOCK(MgMUTEXP(mg));
2581 if (MgOWNER(mg) == thr)
2582 MUTEX_UNLOCK(MgMUTEXP(mg));
2585 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2587 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2589 MUTEX_UNLOCK(MgMUTEXP(mg));
2590 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2592 MUTEX_LOCK(CvMUTEXP(cv));
2595 * Now we have permission to enter the sub, we must distinguish
2596 * four cases. (0) It's an XSUB (in which case we don't care
2597 * about ownership); (1) it's ours already (and we're recursing);
2598 * (2) it's free (but we may already be using a cached clone);
2599 * (3) another thread owns it. Case (1) is easy: we just use it.
2600 * Case (2) means we look for a clone--if we have one, use it
2601 * otherwise grab ownership of cv. Case (3) means we look for a
2602 * clone (for non-XSUBs) and have to create one if we don't
2604 * Why look for a clone in case (2) when we could just grab
2605 * ownership of cv straight away? Well, we could be recursing,
2606 * i.e. we originally tried to enter cv while another thread
2607 * owned it (hence we used a clone) but it has been freed up
2608 * and we're now recursing into it. It may or may not be "better"
2609 * to use the clone but at least CvDEPTH can be trusted.
2611 if (CvOWNER(cv) == thr || CvXSUB(cv))
2612 MUTEX_UNLOCK(CvMUTEXP(cv));
2614 /* Case (2) or (3) */
2618 * XXX Might it be better to release CvMUTEXP(cv) while we
2619 * do the hv_fetch? We might find someone has pinched it
2620 * when we look again, in which case we would be in case
2621 * (3) instead of (2) so we'd have to clone. Would the fact
2622 * that we released the mutex more quickly make up for this?
2624 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2626 /* We already have a clone to use */
2627 MUTEX_UNLOCK(CvMUTEXP(cv));
2629 DEBUG_S(PerlIO_printf(Perl_debug_log,
2630 "entersub: %p already has clone %p:%s\n",
2631 thr, cv, SvPEEK((SV*)cv)));
2634 if (CvDEPTH(cv) == 0)
2635 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2638 /* (2) => grab ownership of cv. (3) => make clone */
2642 MUTEX_UNLOCK(CvMUTEXP(cv));
2643 DEBUG_S(PerlIO_printf(Perl_debug_log,
2644 "entersub: %p grabbing %p:%s in stash %s\n",
2645 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2646 HvNAME(CvSTASH(cv)) : "(none)"));
2649 /* Make a new clone. */
2651 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2652 MUTEX_UNLOCK(CvMUTEXP(cv));
2653 DEBUG_S((PerlIO_printf(Perl_debug_log,
2654 "entersub: %p cloning %p:%s\n",
2655 thr, cv, SvPEEK((SV*)cv))));
2657 * We're creating a new clone so there's no race
2658 * between the original MUTEX_UNLOCK and the
2659 * SvREFCNT_inc since no one will be trying to undef
2660 * it out from underneath us. At least, I don't think
2663 clonecv = cv_clone(cv);
2664 SvREFCNT_dec(cv); /* finished with this */
2665 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2666 CvOWNER(clonecv) = thr;
2670 DEBUG_S(if (CvDEPTH(cv) != 0)
2671 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2673 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2676 #endif /* USE_5005THREADS */
2679 #ifdef PERL_XSUB_OLDSTYLE
2680 if (CvOLDSTYLE(cv)) {
2681 I32 (*fp3)(int,int,int);
2683 register I32 items = SP - MARK;
2684 /* We dont worry to copy from @_. */
2689 PL_stack_sp = mark + 1;
2690 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2691 items = (*fp3)(CvXSUBANY(cv).any_i32,
2692 MARK - PL_stack_base + 1,
2694 PL_stack_sp = PL_stack_base + items;
2697 #endif /* PERL_XSUB_OLDSTYLE */
2699 I32 markix = TOPMARK;
2704 /* Need to copy @_ to stack. Alternative may be to
2705 * switch stack to @_, and copy return values
2706 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2709 #ifdef USE_5005THREADS
2710 av = (AV*)PL_curpad[0];
2712 av = GvAV(PL_defgv);
2713 #endif /* USE_5005THREADS */
2714 items = AvFILLp(av) + 1; /* @_ is not tieable */
2717 /* Mark is at the end of the stack. */
2719 Copy(AvARRAY(av), SP + 1, items, SV*);
2724 /* We assume first XSUB in &DB::sub is the called one. */
2726 SAVEVPTR(PL_curcop);
2727 PL_curcop = PL_curcopdb;
2730 /* Do we need to open block here? XXXX */
2731 (void)(*CvXSUB(cv))(aTHX_ cv);
2733 /* Enforce some sanity in scalar context. */
2734 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2735 if (markix > PL_stack_sp - PL_stack_base)
2736 *(PL_stack_base + markix) = &PL_sv_undef;
2738 *(PL_stack_base + markix) = *PL_stack_sp;
2739 PL_stack_sp = PL_stack_base + markix;
2747 register I32 items = SP - MARK;
2748 AV* padlist = CvPADLIST(cv);
2749 SV** svp = AvARRAY(padlist);
2750 push_return(PL_op->op_next);
2751 PUSHBLOCK(cx, CXt_SUB, MARK);
2754 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2755 * that eval'' ops within this sub know the correct lexical space.
2756 * Owing the speed considerations, we choose to search for the cv
2757 * in doeval() instead.
2759 if (CvDEPTH(cv) < 2)
2760 (void)SvREFCNT_inc(cv);
2761 else { /* save temporaries on recursion? */
2762 PERL_STACK_OVERFLOW_CHECK();
2763 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2765 AV *newpad = newAV();
2766 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2767 I32 ix = AvFILLp((AV*)svp[1]);
2768 I32 names_fill = AvFILLp((AV*)svp[0]);
2769 svp = AvARRAY(svp[0]);
2770 for ( ;ix > 0; ix--) {
2771 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2772 char *name = SvPVX(svp[ix]);
2773 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2774 || *name == '&') /* anonymous code? */
2776 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2778 else { /* our own lexical */
2780 av_store(newpad, ix, sv = (SV*)newAV());
2781 else if (*name == '%')
2782 av_store(newpad, ix, sv = (SV*)newHV());
2784 av_store(newpad, ix, sv = NEWSV(0,0));
2788 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2789 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2792 av_store(newpad, ix, sv = NEWSV(0,0));
2796 av = newAV(); /* will be @_ */
2798 av_store(newpad, 0, (SV*)av);
2799 AvFLAGS(av) = AVf_REIFY;
2800 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2801 AvFILLp(padlist) = CvDEPTH(cv);
2802 svp = AvARRAY(padlist);
2805 #ifdef USE_5005THREADS
2807 AV* av = (AV*)PL_curpad[0];
2809 items = AvFILLp(av) + 1;
2811 /* Mark is at the end of the stack. */
2813 Copy(AvARRAY(av), SP + 1, items, SV*);
2818 #endif /* USE_5005THREADS */
2819 SAVEVPTR(PL_curpad);
2820 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2821 #ifndef USE_5005THREADS
2823 #endif /* USE_5005THREADS */
2829 DEBUG_S(PerlIO_printf(Perl_debug_log,
2830 "%p entersub preparing @_\n", thr));
2832 av = (AV*)PL_curpad[0];
2834 /* @_ is normally not REAL--this should only ever
2835 * happen when DB::sub() calls things that modify @_ */
2840 #ifndef USE_5005THREADS
2841 cx->blk_sub.savearray = GvAV(PL_defgv);
2842 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2843 #endif /* USE_5005THREADS */
2844 cx->blk_sub.oldcurpad = PL_curpad;
2845 cx->blk_sub.argarray = av;
2848 if (items > AvMAX(av) + 1) {
2850 if (AvARRAY(av) != ary) {
2851 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2852 SvPVX(av) = (char*)ary;
2854 if (items > AvMAX(av) + 1) {
2855 AvMAX(av) = items - 1;
2856 Renew(ary,items,SV*);
2858 SvPVX(av) = (char*)ary;
2861 Copy(MARK,AvARRAY(av),items,SV*);
2862 AvFILLp(av) = items - 1;
2870 /* warning must come *after* we fully set up the context
2871 * stuff so that __WARN__ handlers can safely dounwind()
2874 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2875 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2876 sub_crush_depth(cv);
2878 DEBUG_S(PerlIO_printf(Perl_debug_log,
2879 "%p entersub returning %p\n", thr, CvSTART(cv)));
2881 RETURNOP(CvSTART(cv));
2886 Perl_sub_crush_depth(pTHX_ CV *cv)
2889 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2891 SV* tmpstr = sv_newmortal();
2892 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2893 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2903 IV elem = SvIV(elemsv);
2905 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2906 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2909 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2910 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2912 elem -= PL_curcop->cop_arybase;
2913 if (SvTYPE(av) != SVt_PVAV)
2915 svp = av_fetch(av, elem, lval && !defer);
2917 if (!svp || *svp == &PL_sv_undef) {
2920 DIE(aTHX_ PL_no_aelem, elem);
2921 lv = sv_newmortal();
2922 sv_upgrade(lv, SVt_PVLV);
2924 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2925 LvTARG(lv) = SvREFCNT_inc(av);
2926 LvTARGOFF(lv) = elem;
2931 if (PL_op->op_private & OPpLVAL_INTRO)
2932 save_aelem(av, elem, svp);
2933 else if (PL_op->op_private & OPpDEREF)
2934 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2936 sv = (svp ? *svp : &PL_sv_undef);
2937 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2938 sv = sv_mortalcopy(sv);
2944 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2950 Perl_croak(aTHX_ PL_no_modify);
2951 if (SvTYPE(sv) < SVt_RV)
2952 sv_upgrade(sv, SVt_RV);
2953 else if (SvTYPE(sv) >= SVt_PV) {
2954 (void)SvOOK_off(sv);
2955 Safefree(SvPVX(sv));
2956 SvLEN(sv) = SvCUR(sv) = 0;
2960 SvRV(sv) = NEWSV(355,0);
2963 SvRV(sv) = (SV*)newAV();
2966 SvRV(sv) = (SV*)newHV();
2981 if (SvTYPE(rsv) == SVt_PVCV) {
2987 SETs(method_common(sv, Null(U32*)));
2994 SV* sv = cSVOP->op_sv;
2995 U32 hash = SvUVX(sv);
2997 XPUSHs(method_common(sv, &hash));
3002 S_method_common(pTHX_ SV* meth, U32* hashp)
3013 name = SvPV(meth, namelen);
3014 sv = *(PL_stack_base + TOPMARK + 1);
3017 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3026 /* this isn't a reference */
3029 !(packname = SvPV(sv, packlen)) ||
3030 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3031 !(ob=(SV*)GvIO(iogv)))
3033 /* this isn't the name of a filehandle either */
3035 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3036 ? !isIDFIRST_utf8((U8*)packname)
3037 : !isIDFIRST(*packname)
3040 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3041 SvOK(sv) ? "without a package or object reference"
3042 : "on an undefined value");
3044 /* assume it's a package name */
3045 stash = gv_stashpvn(packname, packlen, FALSE);
3048 /* it _is_ a filehandle name -- replace with a reference */
3049 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3052 /* if we got here, ob should be a reference or a glob */
3053 if (!ob || !(SvOBJECT(ob)
3054 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3057 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3061 stash = SvSTASH(ob);
3064 /* NOTE: stash may be null, hope hv_fetch_ent and
3065 gv_fetchmethod can cope (it seems they can) */
3067 /* shortcut for simple names */
3069 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3071 gv = (GV*)HeVAL(he);
3072 if (isGV(gv) && GvCV(gv) &&
3073 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3074 return (SV*)GvCV(gv);
3078 gv = gv_fetchmethod(stash, name);
3081 /* This code tries to figure out just what went wrong with
3082 gv_fetchmethod. It therefore needs to duplicate a lot of
3083 the internals of that function. We can't move it inside
3084 Perl_gv_fetchmethod_autoload(), however, since that would
3085 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3092 for (p = name; *p; p++) {
3094 sep = p, leaf = p + 1;
3095 else if (*p == ':' && *(p + 1) == ':')
3096 sep = p, leaf = p + 2;
3098 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3099 /* the method name is unqualified or starts with SUPER:: */
3100 packname = sep ? CopSTASHPV(PL_curcop) :
3101 stash ? HvNAME(stash) : packname;
3102 packlen = strlen(packname);
3105 /* the method name is qualified */
3107 packlen = sep - name;
3110 /* we're relying on gv_fetchmethod not autovivifying the stash */
3111 if (gv_stashpvn(packname, packlen, FALSE)) {
3113 "Can't locate object method \"%s\" via package \"%.*s\"",
3114 leaf, (int)packlen, packname);
3118 "Can't locate object method \"%s\" via package \"%.*s\""
3119 " (perhaps you forgot to load \"%.*s\"?)",
3120 leaf, (int)packlen, packname, (int)packlen, packname);
3123 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3126 #ifdef USE_5005THREADS
3128 unset_cvowner(pTHX_ void *cvarg)
3130 register CV* cv = (CV *) cvarg;
3132 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3133 thr, cv, SvPEEK((SV*)cv))));
3134 MUTEX_LOCK(CvMUTEXP(cv));
3135 DEBUG_S(if (CvDEPTH(cv) != 0)
3136 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3138 assert(thr == CvOWNER(cv));
3140 MUTEX_UNLOCK(CvMUTEXP(cv));
3143 #endif /* USE_5005THREADS */