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
25 static void unset_cvowner(pTHXo_ void *cvarg);
26 #endif /* USE_THREADS */
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 djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
147 if (SvGMAGICAL(left))
149 if (TARG == right && SvGMAGICAL(right))
152 if (TARG == right && left != right)
153 /* Clone since otherwise we cannot prepend. */
154 rcopy = sv_2mortal(newSVsv(right));
157 sv_setsv(TARG, left);
161 /* $right = $right . $right; */
163 char *rpv = SvPV(right, rlen);
165 sv_catpvn(TARG, rpv, rlen);
167 else /* $right = $left . $right; */
168 sv_catsv(TARG, rcopy);
171 if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
173 /* $other = $left . $right; */
174 /* $left = $left . $right; */
175 sv_catsv(TARG, right);
178 #if defined(PERL_Y2KWARN)
179 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
181 char *s = SvPV(TARG,n);
182 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
183 && (n == 2 || !isDIGIT(s[n-3])))
185 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
186 "about to append an integer to '19'");
200 if (PL_op->op_flags & OPf_MOD) {
201 if (PL_op->op_private & OPpLVAL_INTRO)
202 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
203 else if (PL_op->op_private & OPpDEREF) {
205 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
214 tryAMAGICunTARGET(iter, 0);
215 PL_last_in_gv = (GV*)(*PL_stack_sp--);
216 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
217 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
218 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
221 XPUSHs((SV*)PL_last_in_gv);
224 PL_last_in_gv = (GV*)(*PL_stack_sp--);
227 return do_readline();
232 djSP; tryAMAGICbinSET(eq,0);
233 #ifdef PERL_PRESERVE_IVUV
236 /* Unless the left argument is integer in range we are going to have to
237 use NV maths. Hence only attempt to coerce the right argument if
238 we know the left is integer. */
241 bool auvok = SvUOK(TOPm1s);
242 bool buvok = SvUOK(TOPs);
244 if (!auvok && !buvok) { /* ## IV == IV ## */
245 IV aiv = SvIVX(TOPm1s);
246 IV biv = SvIVX(TOPs);
249 SETs(boolSV(aiv == biv));
252 if (auvok && buvok) { /* ## UV == UV ## */
253 UV auv = SvUVX(TOPm1s);
254 UV buv = SvUVX(TOPs);
257 SETs(boolSV(auv == buv));
260 { /* ## Mixed IV,UV ## */
264 /* == is commutative so swap if needed (save code) */
266 /* swap. top of stack (b) is the iv */
270 /* As (a) is a UV, it's >0, so it cannot be == */
279 /* As (b) is a UV, it's >0, so it cannot be == */
283 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
285 /* we know iv is >= 0 */
286 if (uv > (UV) IV_MAX) {
290 SETs(boolSV((UV)iv == uv));
298 SETs(boolSV(TOPn == value));
306 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
307 DIE(aTHX_ PL_no_modify);
308 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
309 SvIVX(TOPs) != IV_MAX)
312 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
314 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
327 RETURNOP(cLOGOP->op_other);
333 djSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
334 useleft = USE_LEFT(TOPm1s);
335 #ifdef PERL_PRESERVE_IVUV
336 /* We must see if we can perform the addition with integers if possible,
337 as the integer code detects overflow while the NV code doesn't.
338 If either argument hasn't had a numeric conversion yet attempt to get
339 the IV. It's important to do this now, rather than just assuming that
340 it's not IOK as a PV of "9223372036854775806" may not take well to NV
341 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
342 integer in case the second argument is IV=9223372036854775806
343 We can (now) rely on sv_2iv to do the right thing, only setting the
344 public IOK flag if the value in the NV (or PV) slot is truly integer.
346 A side effect is that this also aggressively prefers integer maths over
347 fp maths for integer values.
349 How to detect overflow?
351 C 99 section 6.2.6.1 says
353 The range of nonnegative values of a signed integer type is a subrange
354 of the corresponding unsigned integer type, and the representation of
355 the same value in each type is the same. A computation involving
356 unsigned operands can never overflow, because a result that cannot be
357 represented by the resulting unsigned integer type is reduced modulo
358 the number that is one greater than the largest value that can be
359 represented by the resulting type.
363 which I read as "unsigned ints wrap."
365 signed integer overflow seems to be classed as "exception condition"
367 If an exceptional condition occurs during the evaluation of an
368 expression (that is, if the result is not mathematically defined or not
369 in the range of representable values for its type), the behavior is
372 (6.5, the 5th paragraph)
374 I had assumed that on 2s complement machines signed arithmetic would
375 wrap, hence coded pp_add and pp_subtract on the assumption that
376 everything perl builds on would be happy. After much wailing and
377 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
378 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
379 unsigned code below is actually shorter than the old code. :-)
384 /* Unless the left argument is integer in range we are going to have to
385 use NV maths. Hence only attempt to coerce the right argument if
386 we know the left is integer. */
394 /* left operand is undef, treat as zero. + 0 is identity,
395 Could SETi or SETu right now, but space optimise by not adding
396 lots of code to speed up what is probably a rarish case. */
398 /* Left operand is defined, so is it IV? */
401 if ((auvok = SvUOK(TOPm1s)))
404 register IV aiv = SvIVX(TOPm1s);
407 auvok = 1; /* Now acting as a sign flag. */
408 } else { /* 2s complement assumption for IV_MIN */
416 bool result_good = 0;
419 bool buvok = SvUOK(TOPs);
424 register IV biv = SvIVX(TOPs);
431 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
432 else "IV" now, independant of how it came in.
433 if a, b represents positive, A, B negative, a maps to -A etc
438 all UV maths. negate result if A negative.
439 add if signs same, subtract if signs differ. */
445 /* Must get smaller */
451 /* result really should be -(auv-buv). as its negation
452 of true value, need to swap our result flag */
469 if (result <= (UV)IV_MIN)
472 /* result valid, but out of range for IV. */
477 } /* Overflow, drop through to NVs. */
484 /* left operand is undef, treat as zero. + 0.0 is identity. */
488 SETn( value + TOPn );
496 AV *av = GvAV(cGVOP_gv);
497 U32 lval = PL_op->op_flags & OPf_MOD;
498 SV** svp = av_fetch(av, PL_op->op_private, lval);
499 SV *sv = (svp ? *svp : &PL_sv_undef);
501 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
502 sv = sv_mortalcopy(sv);
509 djSP; dMARK; dTARGET;
511 do_join(TARG, *MARK, MARK, SP);
522 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
523 * will be enough to hold an OP*.
525 SV* sv = sv_newmortal();
526 sv_upgrade(sv, SVt_PVLV);
528 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
536 /* Oversized hot code. */
540 djSP; dMARK; dORIGMARK;
547 if (PL_op->op_flags & OPf_STACKED)
551 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
553 if (MARK == ORIGMARK) {
554 /* If using default handle then we need to make space to
555 * pass object as 1st arg, so move other args up ...
559 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
563 *MARK = SvTIED_obj((SV*)gv, mg);
566 call_method("PRINT", G_SCALAR);
574 if (!(io = GvIO(gv))) {
575 if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
577 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
578 report_evil_fh(gv, io, PL_op->op_type);
579 SETERRNO(EBADF,RMS$_IFI);
582 else if (!(fp = IoOFP(io))) {
583 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
585 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
586 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
587 report_evil_fh(gv, io, PL_op->op_type);
589 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
594 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
596 if (!do_print(*MARK, fp))
600 if (!do_print(PL_ofs_sv, fp)) { /* $, */
609 if (!do_print(*MARK, fp))
617 if (PL_ors_sv && SvOK(PL_ors_sv))
618 if (!do_print(PL_ors_sv, fp)) /* $\ */
621 if (IoFLAGS(io) & IOf_FLUSH)
622 if (PerlIO_flush(fp) == EOF)
643 tryAMAGICunDEREF(to_av);
646 if (SvTYPE(av) != SVt_PVAV)
647 DIE(aTHX_ "Not an ARRAY reference");
648 if (PL_op->op_flags & OPf_REF) {
653 if (GIMME == G_SCALAR)
654 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
660 if (SvTYPE(sv) == SVt_PVAV) {
662 if (PL_op->op_flags & OPf_REF) {
667 if (GIMME == G_SCALAR)
668 Perl_croak(aTHX_ "Can't return array to lvalue"
677 if (SvTYPE(sv) != SVt_PVGV) {
681 if (SvGMAGICAL(sv)) {
687 if (PL_op->op_flags & OPf_REF ||
688 PL_op->op_private & HINT_STRICT_REFS)
689 DIE(aTHX_ PL_no_usym, "an ARRAY");
690 if (ckWARN(WARN_UNINITIALIZED))
692 if (GIMME == G_ARRAY) {
699 if ((PL_op->op_flags & OPf_SPECIAL) &&
700 !(PL_op->op_flags & OPf_MOD))
702 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
704 && (!is_gv_magical(sym,len,0)
705 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
711 if (PL_op->op_private & HINT_STRICT_REFS)
712 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
713 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
720 if (PL_op->op_private & OPpLVAL_INTRO)
722 if (PL_op->op_flags & OPf_REF) {
727 if (GIMME == G_SCALAR)
728 Perl_croak(aTHX_ "Can't return array to lvalue"
736 if (GIMME == G_ARRAY) {
737 I32 maxarg = AvFILL(av) + 1;
738 (void)POPs; /* XXXX May be optimized away? */
740 if (SvRMAGICAL(av)) {
742 for (i=0; i < maxarg; i++) {
743 SV **svp = av_fetch(av, i, FALSE);
744 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
748 Copy(AvARRAY(av), SP+1, maxarg, SV*);
754 I32 maxarg = AvFILL(av) + 1;
767 tryAMAGICunDEREF(to_hv);
770 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
771 DIE(aTHX_ "Not a HASH reference");
772 if (PL_op->op_flags & OPf_REF) {
777 if (GIMME == G_SCALAR)
778 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
784 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
786 if (PL_op->op_flags & OPf_REF) {
791 if (GIMME == G_SCALAR)
792 Perl_croak(aTHX_ "Can't return hash to lvalue"
801 if (SvTYPE(sv) != SVt_PVGV) {
805 if (SvGMAGICAL(sv)) {
811 if (PL_op->op_flags & OPf_REF ||
812 PL_op->op_private & HINT_STRICT_REFS)
813 DIE(aTHX_ PL_no_usym, "a HASH");
814 if (ckWARN(WARN_UNINITIALIZED))
816 if (GIMME == G_ARRAY) {
823 if ((PL_op->op_flags & OPf_SPECIAL) &&
824 !(PL_op->op_flags & OPf_MOD))
826 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
828 && (!is_gv_magical(sym,len,0)
829 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
835 if (PL_op->op_private & HINT_STRICT_REFS)
836 DIE(aTHX_ PL_no_symref, sym, "a HASH");
837 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
844 if (PL_op->op_private & OPpLVAL_INTRO)
846 if (PL_op->op_flags & OPf_REF) {
851 if (GIMME == G_SCALAR)
852 Perl_croak(aTHX_ "Can't return hash to lvalue"
860 if (GIMME == G_ARRAY) { /* array wanted */
861 *PL_stack_sp = (SV*)hv;
866 if (SvTYPE(hv) == SVt_PVAV)
867 hv = avhv_keys((AV*)hv);
869 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
870 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
880 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
886 leftop = ((BINOP*)PL_op)->op_last;
888 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
889 leftop = ((LISTOP*)leftop)->op_first;
891 /* Skip PUSHMARK and each element already assigned to. */
892 for (i = lelem - firstlelem; i > 0; i--) {
893 leftop = leftop->op_sibling;
896 if (leftop->op_type != OP_RV2HV)
901 av_fill(ary, 0); /* clear all but the fields hash */
902 if (lastrelem >= relem) {
903 while (relem < lastrelem) { /* gobble up all the rest */
907 /* Avoid a memory leak when avhv_store_ent dies. */
908 tmpstr = sv_newmortal();
909 sv_setsv(tmpstr,relem[1]); /* value */
911 if (avhv_store_ent(ary,relem[0],tmpstr,0))
912 (void)SvREFCNT_inc(tmpstr);
913 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
919 if (relem == lastrelem)
925 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
929 if (ckWARN(WARN_MISC)) {
930 if (relem == firstrelem &&
932 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
933 SvTYPE(SvRV(*relem)) == SVt_PVHV))
935 Perl_warner(aTHX_ WARN_MISC,
936 "Reference found where even-sized list expected");
939 Perl_warner(aTHX_ WARN_MISC,
940 "Odd number of elements in hash assignment");
942 if (SvTYPE(hash) == SVt_PVAV) {
944 tmpstr = sv_newmortal();
945 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
946 (void)SvREFCNT_inc(tmpstr);
947 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
952 tmpstr = NEWSV(29,0);
953 didstore = hv_store_ent(hash,*relem,tmpstr,0);
954 if (SvMAGICAL(hash)) {
955 if (SvSMAGICAL(tmpstr))
968 SV **lastlelem = PL_stack_sp;
969 SV **lastrelem = PL_stack_base + POPMARK;
970 SV **firstrelem = PL_stack_base + POPMARK + 1;
971 SV **firstlelem = lastrelem + 1;
984 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
986 /* If there's a common identifier on both sides we have to take
987 * special care that assigning the identifier on the left doesn't
988 * clobber a value on the right that's used later in the list.
990 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
991 EXTEND_MORTAL(lastrelem - firstrelem + 1);
992 for (relem = firstrelem; relem <= lastrelem; relem++) {
995 TAINT_NOT; /* Each item is independent */
996 *relem = sv_mortalcopy(sv);
1006 while (lelem <= lastlelem) {
1007 TAINT_NOT; /* Each item stands on its own, taintwise. */
1009 switch (SvTYPE(sv)) {
1012 magic = SvMAGICAL(ary) != 0;
1013 if (PL_op->op_private & OPpASSIGN_HASH) {
1014 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1020 do_oddball((HV*)ary, relem, firstrelem);
1022 relem = lastrelem + 1;
1027 av_extend(ary, lastrelem - relem);
1029 while (relem <= lastrelem) { /* gobble up all the rest */
1033 sv_setsv(sv,*relem);
1035 didstore = av_store(ary,i++,sv);
1045 case SVt_PVHV: { /* normal hash */
1049 magic = SvMAGICAL(hash) != 0;
1052 while (relem < lastrelem) { /* gobble up all the rest */
1057 sv = &PL_sv_no, relem++;
1058 tmpstr = NEWSV(29,0);
1060 sv_setsv(tmpstr,*relem); /* value */
1061 *(relem++) = tmpstr;
1062 didstore = hv_store_ent(hash,sv,tmpstr,0);
1064 if (SvSMAGICAL(tmpstr))
1071 if (relem == lastrelem) {
1072 do_oddball(hash, relem, firstrelem);
1078 if (SvIMMORTAL(sv)) {
1079 if (relem <= lastrelem)
1083 if (relem <= lastrelem) {
1084 sv_setsv(sv, *relem);
1088 sv_setsv(sv, &PL_sv_undef);
1093 if (PL_delaymagic & ~DM_DELAY) {
1094 if (PL_delaymagic & DM_UID) {
1095 #ifdef HAS_SETRESUID
1096 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1098 # ifdef HAS_SETREUID
1099 (void)setreuid(PL_uid,PL_euid);
1102 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1103 (void)setruid(PL_uid);
1104 PL_delaymagic &= ~DM_RUID;
1106 # endif /* HAS_SETRUID */
1108 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1109 (void)seteuid(PL_uid);
1110 PL_delaymagic &= ~DM_EUID;
1112 # endif /* HAS_SETEUID */
1113 if (PL_delaymagic & DM_UID) {
1114 if (PL_uid != PL_euid)
1115 DIE(aTHX_ "No setreuid available");
1116 (void)PerlProc_setuid(PL_uid);
1118 # endif /* HAS_SETREUID */
1119 #endif /* HAS_SETRESUID */
1120 PL_uid = PerlProc_getuid();
1121 PL_euid = PerlProc_geteuid();
1123 if (PL_delaymagic & DM_GID) {
1124 #ifdef HAS_SETRESGID
1125 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1127 # ifdef HAS_SETREGID
1128 (void)setregid(PL_gid,PL_egid);
1131 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1132 (void)setrgid(PL_gid);
1133 PL_delaymagic &= ~DM_RGID;
1135 # endif /* HAS_SETRGID */
1137 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1138 (void)setegid(PL_gid);
1139 PL_delaymagic &= ~DM_EGID;
1141 # endif /* HAS_SETEGID */
1142 if (PL_delaymagic & DM_GID) {
1143 if (PL_gid != PL_egid)
1144 DIE(aTHX_ "No setregid available");
1145 (void)PerlProc_setgid(PL_gid);
1147 # endif /* HAS_SETREGID */
1148 #endif /* HAS_SETRESGID */
1149 PL_gid = PerlProc_getgid();
1150 PL_egid = PerlProc_getegid();
1152 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1157 if (gimme == G_VOID)
1158 SP = firstrelem - 1;
1159 else if (gimme == G_SCALAR) {
1162 SETi(lastrelem - firstrelem + 1);
1168 SP = firstrelem + (lastlelem - firstlelem);
1169 lelem = firstlelem + (relem - firstrelem);
1171 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1179 register PMOP *pm = cPMOP;
1180 SV *rv = sv_newmortal();
1181 SV *sv = newSVrv(rv, "Regexp");
1182 sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
1189 register PMOP *pm = cPMOP;
1194 I32 r_flags = REXEC_CHECKED;
1195 char *truebase; /* Start of string */
1196 register REGEXP *rx = pm->op_pmregexp;
1201 I32 oldsave = PL_savestack_ix;
1202 I32 update_minmatch = 1;
1203 I32 had_zerolen = 0;
1205 if (PL_op->op_flags & OPf_STACKED)
1212 PUTBACK; /* EVAL blocks need stack_sp. */
1213 s = SvPV(TARG, len);
1216 DIE(aTHX_ "panic: pp_match");
1217 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1218 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1221 if (pm->op_pmdynflags & PMdf_USED) {
1223 if (gimme == G_ARRAY)
1228 if (!rx->prelen && PL_curpm) {
1230 rx = pm->op_pmregexp;
1232 if (rx->minlen > len) goto failure;
1236 /* XXXX What part of this is needed with true \G-support? */
1237 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1239 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1240 MAGIC* mg = mg_find(TARG, 'g');
1241 if (mg && mg->mg_len >= 0) {
1242 if (!(rx->reganch & ROPT_GPOS_SEEN))
1243 rx->endp[0] = rx->startp[0] = mg->mg_len;
1244 else if (rx->reganch & ROPT_ANCH_GPOS) {
1245 r_flags |= REXEC_IGNOREPOS;
1246 rx->endp[0] = rx->startp[0] = mg->mg_len;
1248 minmatch = (mg->mg_flags & MGf_MINMATCH);
1249 update_minmatch = 0;
1253 if ((gimme != G_ARRAY && !global && rx->nparens)
1254 || SvTEMP(TARG) || PL_sawampersand)
1255 r_flags |= REXEC_COPY_STR;
1257 r_flags |= REXEC_SCREAM;
1259 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1260 SAVEINT(PL_multiline);
1261 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1265 if (global && rx->startp[0] != -1) {
1266 t = s = rx->endp[0] + truebase;
1267 if ((s + rx->minlen) > strend)
1269 if (update_minmatch++)
1270 minmatch = had_zerolen;
1272 if (rx->reganch & RE_USE_INTUIT &&
1273 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1274 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1278 if ( (rx->reganch & ROPT_CHECK_ALL)
1280 && ((rx->reganch & ROPT_NOSCAN)
1281 || !((rx->reganch & RE_INTUIT_TAIL)
1282 && (r_flags & REXEC_SCREAM)))
1283 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1286 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1289 if (pm->op_pmflags & PMf_ONCE)
1290 pm->op_pmdynflags |= PMdf_USED;
1299 RX_MATCH_TAINTED_on(rx);
1300 TAINT_IF(RX_MATCH_TAINTED(rx));
1301 if (gimme == G_ARRAY) {
1302 I32 nparens, i, len;
1304 nparens = rx->nparens;
1305 if (global && !nparens)
1309 SPAGAIN; /* EVAL blocks could move the stack. */
1310 EXTEND(SP, nparens + i);
1311 EXTEND_MORTAL(nparens + i);
1312 for (i = !i; i <= nparens; i++) {
1313 PUSHs(sv_newmortal());
1315 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1316 len = rx->endp[i] - rx->startp[i];
1317 s = rx->startp[i] + truebase;
1318 sv_setpvn(*SP, s, len);
1324 had_zerolen = (rx->startp[0] != -1
1325 && rx->startp[0] == rx->endp[0]);
1326 PUTBACK; /* EVAL blocks may use stack */
1327 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1332 LEAVE_SCOPE(oldsave);
1338 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1339 mg = mg_find(TARG, 'g');
1341 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1342 mg = mg_find(TARG, 'g');
1344 if (rx->startp[0] != -1) {
1345 mg->mg_len = rx->endp[0];
1346 if (rx->startp[0] == rx->endp[0])
1347 mg->mg_flags |= MGf_MINMATCH;
1349 mg->mg_flags &= ~MGf_MINMATCH;
1352 LEAVE_SCOPE(oldsave);
1356 yup: /* Confirmed by INTUIT */
1358 RX_MATCH_TAINTED_on(rx);
1359 TAINT_IF(RX_MATCH_TAINTED(rx));
1361 if (pm->op_pmflags & PMf_ONCE)
1362 pm->op_pmdynflags |= PMdf_USED;
1363 if (RX_MATCH_COPIED(rx))
1364 Safefree(rx->subbeg);
1365 RX_MATCH_COPIED_off(rx);
1366 rx->subbeg = Nullch;
1368 rx->subbeg = truebase;
1369 rx->startp[0] = s - truebase;
1370 if (DO_UTF8(PL_reg_sv)) {
1371 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1372 rx->endp[0] = t - truebase;
1375 rx->endp[0] = s - truebase + rx->minlen;
1377 rx->sublen = strend - truebase;
1380 if (PL_sawampersand) {
1383 rx->subbeg = savepvn(t, strend - t);
1384 rx->sublen = strend - t;
1385 RX_MATCH_COPIED_on(rx);
1386 off = rx->startp[0] = s - t;
1387 rx->endp[0] = off + rx->minlen;
1389 else { /* startp/endp are used by @- @+. */
1390 rx->startp[0] = s - truebase;
1391 rx->endp[0] = s - truebase + rx->minlen;
1393 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1394 LEAVE_SCOPE(oldsave);
1399 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1400 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1401 MAGIC* mg = mg_find(TARG, 'g');
1406 LEAVE_SCOPE(oldsave);
1407 if (gimme == G_ARRAY)
1413 Perl_do_readline(pTHX)
1415 dSP; dTARGETSTACKED;
1420 register IO *io = GvIO(PL_last_in_gv);
1421 register I32 type = PL_op->op_type;
1422 I32 gimme = GIMME_V;
1425 if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
1427 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1430 call_method("READLINE", gimme);
1433 if (gimme == G_SCALAR)
1434 SvSetMagicSV_nosteal(TARG, TOPs);
1441 if (IoFLAGS(io) & IOf_ARGV) {
1442 if (IoFLAGS(io) & IOf_START) {
1444 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1445 IoFLAGS(io) &= ~IOf_START;
1446 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1447 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1448 SvSETMAGIC(GvSV(PL_last_in_gv));
1453 fp = nextargv(PL_last_in_gv);
1454 if (!fp) { /* Note: fp != IoIFP(io) */
1455 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1458 else if (type == OP_GLOB)
1459 fp = Perl_start_glob(aTHX_ POPs, io);
1461 else if (type == OP_GLOB)
1463 else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
1464 && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
1465 || fp == PerlIO_stderr()))
1466 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1469 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1470 && (!io || !(IoFLAGS(io) & IOf_START))) {
1471 if (type == OP_GLOB)
1472 Perl_warner(aTHX_ WARN_GLOB,
1473 "glob failed (can't start child: %s)",
1476 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1478 if (gimme == G_SCALAR) {
1479 (void)SvOK_off(TARG);
1485 if (gimme == G_SCALAR) {
1489 (void)SvUPGRADE(sv, SVt_PV);
1490 tmplen = SvLEN(sv); /* remember if already alloced */
1492 Sv_Grow(sv, 80); /* try short-buffering it */
1493 if (type == OP_RCATLINE)
1499 sv = sv_2mortal(NEWSV(57, 80));
1503 /* This should not be marked tainted if the fp is marked clean */
1504 #define MAYBE_TAINT_LINE(io, sv) \
1505 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1510 /* delay EOF state for a snarfed empty file */
1511 #define SNARF_EOF(gimme,rs,io,sv) \
1512 (gimme != G_SCALAR || SvCUR(sv) \
1513 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1516 if (!sv_gets(sv, fp, offset)
1517 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1519 PerlIO_clearerr(fp);
1520 if (IoFLAGS(io) & IOf_ARGV) {
1521 fp = nextargv(PL_last_in_gv);
1524 (void)do_close(PL_last_in_gv, FALSE);
1526 else if (type == OP_GLOB) {
1527 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1528 Perl_warner(aTHX_ WARN_GLOB,
1529 "glob failed (child exited with status %d%s)",
1530 (int)(STATUS_CURRENT >> 8),
1531 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1534 if (gimme == G_SCALAR) {
1535 (void)SvOK_off(TARG);
1538 MAYBE_TAINT_LINE(io, sv);
1541 MAYBE_TAINT_LINE(io, sv);
1543 IoFLAGS(io) |= IOf_NOLINE;
1546 if (type == OP_GLOB) {
1549 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1550 tmps = SvEND(sv) - 1;
1551 if (*tmps == *SvPVX(PL_rs)) {
1556 for (tmps = SvPVX(sv); *tmps; tmps++)
1557 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1558 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1560 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1561 (void)POPs; /* Unmatched wildcard? Chuck it... */
1565 if (gimme == G_ARRAY) {
1566 if (SvLEN(sv) - SvCUR(sv) > 20) {
1567 SvLEN_set(sv, SvCUR(sv)+1);
1568 Renew(SvPVX(sv), SvLEN(sv), char);
1570 sv = sv_2mortal(NEWSV(58, 80));
1573 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1574 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1578 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1579 Renew(SvPVX(sv), SvLEN(sv), char);
1588 register PERL_CONTEXT *cx;
1589 I32 gimme = OP_GIMME(PL_op, -1);
1592 if (cxstack_ix >= 0)
1593 gimme = cxstack[cxstack_ix].blk_gimme;
1601 PUSHBLOCK(cx, CXt_BLOCK, SP);
1613 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1614 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1616 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1619 if (SvTYPE(hv) == SVt_PVHV) {
1620 if (PL_op->op_private & OPpLVAL_INTRO)
1621 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1622 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1623 svp = he ? &HeVAL(he) : 0;
1625 else if (SvTYPE(hv) == SVt_PVAV) {
1626 if (PL_op->op_private & OPpLVAL_INTRO)
1627 DIE(aTHX_ "Can't localize pseudo-hash element");
1628 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1634 if (!svp || *svp == &PL_sv_undef) {
1639 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1641 lv = sv_newmortal();
1642 sv_upgrade(lv, SVt_PVLV);
1644 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1645 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1646 LvTARG(lv) = SvREFCNT_inc(hv);
1651 if (PL_op->op_private & OPpLVAL_INTRO) {
1652 if (HvNAME(hv) && isGV(*svp))
1653 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1657 char *key = SvPV(keysv, keylen);
1658 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1660 save_helem(hv, keysv, svp);
1663 else if (PL_op->op_private & OPpDEREF)
1664 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1666 sv = (svp ? *svp : &PL_sv_undef);
1667 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1668 * Pushing the magical RHS on to the stack is useless, since
1669 * that magic is soon destined to be misled by the local(),
1670 * and thus the later pp_sassign() will fail to mg_get() the
1671 * old value. This should also cure problems with delayed
1672 * mg_get()s. GSAR 98-07-03 */
1673 if (!lval && SvGMAGICAL(sv))
1674 sv = sv_mortalcopy(sv);
1682 register PERL_CONTEXT *cx;
1688 if (PL_op->op_flags & OPf_SPECIAL) {
1689 cx = &cxstack[cxstack_ix];
1690 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1695 gimme = OP_GIMME(PL_op, -1);
1697 if (cxstack_ix >= 0)
1698 gimme = cxstack[cxstack_ix].blk_gimme;
1704 if (gimme == G_VOID)
1706 else if (gimme == G_SCALAR) {
1709 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1712 *MARK = sv_mortalcopy(TOPs);
1715 *MARK = &PL_sv_undef;
1719 else if (gimme == G_ARRAY) {
1720 /* in case LEAVE wipes old return values */
1721 for (mark = newsp + 1; mark <= SP; mark++) {
1722 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1723 *mark = sv_mortalcopy(*mark);
1724 TAINT_NOT; /* Each item is independent */
1728 PL_curpm = newpm; /* Don't pop $1 et al till now */
1738 register PERL_CONTEXT *cx;
1744 cx = &cxstack[cxstack_ix];
1745 if (CxTYPE(cx) != CXt_LOOP)
1746 DIE(aTHX_ "panic: pp_iter");
1748 itersvp = CxITERVAR(cx);
1749 av = cx->blk_loop.iterary;
1750 if (SvTYPE(av) != SVt_PVAV) {
1751 /* iterate ($min .. $max) */
1752 if (cx->blk_loop.iterlval) {
1753 /* string increment */
1754 register SV* cur = cx->blk_loop.iterlval;
1756 char *max = SvPV((SV*)av, maxlen);
1757 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1758 #ifndef USE_THREADS /* don't risk potential race */
1759 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1760 /* safe to reuse old SV */
1761 sv_setsv(*itersvp, cur);
1766 /* we need a fresh SV every time so that loop body sees a
1767 * completely new SV for closures/references to work as
1769 SvREFCNT_dec(*itersvp);
1770 *itersvp = newSVsv(cur);
1772 if (strEQ(SvPVX(cur), max))
1773 sv_setiv(cur, 0); /* terminate next time */
1780 /* integer increment */
1781 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1784 #ifndef USE_THREADS /* don't risk potential race */
1785 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1786 /* safe to reuse old SV */
1787 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1792 /* we need a fresh SV every time so that loop body sees a
1793 * completely new SV for closures/references to work as they
1795 SvREFCNT_dec(*itersvp);
1796 *itersvp = newSViv(cx->blk_loop.iterix++);
1802 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1805 SvREFCNT_dec(*itersvp);
1807 if ((sv = SvMAGICAL(av)
1808 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1809 : AvARRAY(av)[++cx->blk_loop.iterix]))
1813 if (av != PL_curstack && SvIMMORTAL(sv)) {
1814 SV *lv = cx->blk_loop.iterlval;
1815 if (lv && SvREFCNT(lv) > 1) {
1820 SvREFCNT_dec(LvTARG(lv));
1822 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1823 sv_upgrade(lv, SVt_PVLV);
1825 sv_magic(lv, Nullsv, 'y', Nullch, 0);
1827 LvTARG(lv) = SvREFCNT_inc(av);
1828 LvTARGOFF(lv) = cx->blk_loop.iterix;
1829 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1833 *itersvp = SvREFCNT_inc(sv);
1840 register PMOP *pm = cPMOP;
1856 register REGEXP *rx = pm->op_pmregexp;
1858 int force_on_match = 0;
1859 I32 oldsave = PL_savestack_ix;
1863 /* known replacement string? */
1864 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1865 if (PL_op->op_flags & OPf_STACKED)
1872 do_utf8 = DO_UTF8(PL_reg_sv);
1873 if (SvFAKE(TARG) && SvREADONLY(TARG))
1874 sv_force_normal(TARG);
1875 if (SvREADONLY(TARG)
1876 || (SvTYPE(TARG) > SVt_PVLV
1877 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1878 DIE(aTHX_ PL_no_modify);
1881 s = SvPV(TARG, len);
1882 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1884 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1885 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1892 DIE(aTHX_ "panic: pp_subst");
1895 slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1896 maxiters = 2 * slen + 10; /* We can match twice at each
1897 position, once with zero-length,
1898 second time with non-zero. */
1900 if (!rx->prelen && PL_curpm) {
1902 rx = pm->op_pmregexp;
1904 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1905 ? REXEC_COPY_STR : 0;
1907 r_flags |= REXEC_SCREAM;
1908 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1909 SAVEINT(PL_multiline);
1910 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1913 if (rx->reganch & RE_USE_INTUIT) {
1914 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1918 /* How to do it in subst? */
1919 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1921 && ((rx->reganch & ROPT_NOSCAN)
1922 || !((rx->reganch & RE_INTUIT_TAIL)
1923 && (r_flags & REXEC_SCREAM))))
1928 /* only replace once? */
1929 once = !(rpm->op_pmflags & PMf_GLOBAL);
1931 /* known replacement string? */
1932 c = dstr ? SvPV(dstr, clen) : Nullch;
1934 /* can do inplace substitution? */
1935 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1936 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1937 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1938 r_flags | REXEC_CHECKED))
1942 LEAVE_SCOPE(oldsave);
1945 if (force_on_match) {
1947 s = SvPV_force(TARG, len);
1952 SvSCREAM_off(TARG); /* disable possible screamer */
1954 rxtainted |= RX_MATCH_TAINTED(rx);
1955 m = orig + rx->startp[0];
1956 d = orig + rx->endp[0];
1958 if (m - s > strend - d) { /* faster to shorten from end */
1960 Copy(c, m, clen, char);
1965 Move(d, m, i, char);
1969 SvCUR_set(TARG, m - s);
1972 else if ((i = m - s)) { /* faster from front */
1980 Copy(c, m, clen, char);
1985 Copy(c, d, clen, char);
1990 TAINT_IF(rxtainted & 1);
1996 if (iters++ > maxiters)
1997 DIE(aTHX_ "Substitution loop");
1998 rxtainted |= RX_MATCH_TAINTED(rx);
1999 m = rx->startp[0] + orig;
2003 Move(s, d, i, char);
2007 Copy(c, d, clen, char);
2010 s = rx->endp[0] + orig;
2011 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2013 /* don't match same null twice */
2014 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2017 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2018 Move(s, d, i+1, char); /* include the NUL */
2020 TAINT_IF(rxtainted & 1);
2022 PUSHs(sv_2mortal(newSViv((I32)iters)));
2024 (void)SvPOK_only_UTF8(TARG);
2025 TAINT_IF(rxtainted);
2026 if (SvSMAGICAL(TARG)) {
2032 LEAVE_SCOPE(oldsave);
2036 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2037 r_flags | REXEC_CHECKED))
2041 if (force_on_match) {
2043 s = SvPV_force(TARG, len);
2046 rxtainted |= RX_MATCH_TAINTED(rx);
2047 dstr = NEWSV(25, len);
2048 sv_setpvn(dstr, m, s-m);
2053 register PERL_CONTEXT *cx;
2056 RETURNOP(cPMOP->op_pmreplroot);
2058 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2060 if (iters++ > maxiters)
2061 DIE(aTHX_ "Substitution loop");
2062 rxtainted |= RX_MATCH_TAINTED(rx);
2063 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2068 strend = s + (strend - m);
2070 m = rx->startp[0] + orig;
2071 sv_catpvn(dstr, s, m-s);
2072 s = rx->endp[0] + orig;
2074 sv_catpvn(dstr, c, clen);
2077 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2078 TARG, NULL, r_flags));
2079 sv_catpvn(dstr, s, strend - s);
2081 (void)SvOOK_off(TARG);
2082 Safefree(SvPVX(TARG));
2083 SvPVX(TARG) = SvPVX(dstr);
2084 SvCUR_set(TARG, SvCUR(dstr));
2085 SvLEN_set(TARG, SvLEN(dstr));
2086 isutf8 = DO_UTF8(dstr);
2090 TAINT_IF(rxtainted & 1);
2092 PUSHs(sv_2mortal(newSViv((I32)iters)));
2094 (void)SvPOK_only(TARG);
2097 TAINT_IF(rxtainted);
2100 LEAVE_SCOPE(oldsave);
2109 LEAVE_SCOPE(oldsave);
2118 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2119 ++*PL_markstack_ptr;
2120 LEAVE; /* exit inner scope */
2123 if (PL_stack_base + *PL_markstack_ptr > SP) {
2125 I32 gimme = GIMME_V;
2127 LEAVE; /* exit outer scope */
2128 (void)POPMARK; /* pop src */
2129 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2130 (void)POPMARK; /* pop dst */
2131 SP = PL_stack_base + POPMARK; /* pop original mark */
2132 if (gimme == G_SCALAR) {
2136 else if (gimme == G_ARRAY)
2143 ENTER; /* enter inner scope */
2146 src = PL_stack_base[*PL_markstack_ptr];
2150 RETURNOP(cLOGOP->op_other);
2161 register PERL_CONTEXT *cx;
2167 if (gimme == G_SCALAR) {
2170 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2172 *MARK = SvREFCNT_inc(TOPs);
2177 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2179 *MARK = sv_mortalcopy(sv);
2184 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2188 *MARK = &PL_sv_undef;
2192 else if (gimme == G_ARRAY) {
2193 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2194 if (!SvTEMP(*MARK)) {
2195 *MARK = sv_mortalcopy(*MARK);
2196 TAINT_NOT; /* Each item is independent */
2202 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2203 PL_curpm = newpm; /* ... and pop $1 et al */
2207 return pop_return();
2210 /* This duplicates the above code because the above code must not
2211 * get any slower by more conditions */
2219 register PERL_CONTEXT *cx;
2226 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2227 /* We are an argument to a function or grep().
2228 * This kind of lvalueness was legal before lvalue
2229 * subroutines too, so be backward compatible:
2230 * cannot report errors. */
2232 /* Scalar context *is* possible, on the LHS of -> only,
2233 * as in f()->meth(). But this is not an lvalue. */
2234 if (gimme == G_SCALAR)
2236 if (gimme == G_ARRAY) {
2237 if (!CvLVALUE(cx->blk_sub.cv))
2238 goto temporise_array;
2239 EXTEND_MORTAL(SP - newsp);
2240 for (mark = newsp + 1; mark <= SP; mark++) {
2243 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2244 *mark = sv_mortalcopy(*mark);
2246 /* Can be a localized value subject to deletion. */
2247 PL_tmps_stack[++PL_tmps_ix] = *mark;
2248 (void)SvREFCNT_inc(*mark);
2253 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2254 /* Here we go for robustness, not for speed, so we change all
2255 * the refcounts so the caller gets a live guy. Cannot set
2256 * TEMP, so sv_2mortal is out of question. */
2257 if (!CvLVALUE(cx->blk_sub.cv)) {
2262 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2264 if (gimme == G_SCALAR) {
2268 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2273 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2274 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2276 else { /* Can be a localized value
2277 * subject to deletion. */
2278 PL_tmps_stack[++PL_tmps_ix] = *mark;
2279 (void)SvREFCNT_inc(*mark);
2282 else { /* Should not happen? */
2287 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2288 (MARK > SP ? "Empty array" : "Array"));
2292 else if (gimme == G_ARRAY) {
2293 EXTEND_MORTAL(SP - newsp);
2294 for (mark = newsp + 1; mark <= SP; mark++) {
2295 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2296 /* Might be flattened array after $#array = */
2302 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2303 (*mark != &PL_sv_undef)
2305 ? "a readonly value" : "a temporary")
2306 : "an uninitialized value");
2309 /* Can be a localized value subject to deletion. */
2310 PL_tmps_stack[++PL_tmps_ix] = *mark;
2311 (void)SvREFCNT_inc(*mark);
2317 if (gimme == G_SCALAR) {
2321 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2323 *MARK = SvREFCNT_inc(TOPs);
2328 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2330 *MARK = sv_mortalcopy(sv);
2335 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2339 *MARK = &PL_sv_undef;
2343 else if (gimme == G_ARRAY) {
2345 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2346 if (!SvTEMP(*MARK)) {
2347 *MARK = sv_mortalcopy(*MARK);
2348 TAINT_NOT; /* Each item is independent */
2355 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2356 PL_curpm = newpm; /* ... and pop $1 et al */
2360 return pop_return();
2365 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2367 SV *dbsv = GvSV(PL_DBsub);
2369 if (!PERLDB_SUB_NN) {
2373 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2374 || strEQ(GvNAME(gv), "END")
2375 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2376 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2377 && (gv = (GV*)*svp) ))) {
2378 /* Use GV from the stack as a fallback. */
2379 /* GV is potentially non-unique, or contain different CV. */
2380 SV *tmp = newRV((SV*)cv);
2381 sv_setsv(dbsv, tmp);
2385 gv_efullname3(dbsv, gv, Nullch);
2389 (void)SvUPGRADE(dbsv, SVt_PVIV);
2390 (void)SvIOK_on(dbsv);
2391 SAVEIV(SvIVX(dbsv));
2392 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2396 PL_curcopdb = PL_curcop;
2397 cv = GvCV(PL_DBsub);
2407 register PERL_CONTEXT *cx;
2409 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2412 DIE(aTHX_ "Not a CODE reference");
2413 switch (SvTYPE(sv)) {
2419 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2421 SP = PL_stack_base + POPMARK;
2424 if (SvGMAGICAL(sv)) {
2426 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2429 sym = SvPV(sv, n_a);
2431 DIE(aTHX_ PL_no_usym, "a subroutine");
2432 if (PL_op->op_private & HINT_STRICT_REFS)
2433 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2434 cv = get_cv(sym, TRUE);
2438 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2439 tryAMAGICunDEREF(to_cv);
2442 if (SvTYPE(cv) == SVt_PVCV)
2447 DIE(aTHX_ "Not a CODE reference");
2452 if (!(cv = GvCVu((GV*)sv)))
2453 cv = sv_2cv(sv, &stash, &gv, FALSE);
2466 if (!CvROOT(cv) && !CvXSUB(cv)) {
2470 /* anonymous or undef'd function leaves us no recourse */
2471 if (CvANON(cv) || !(gv = CvGV(cv)))
2472 DIE(aTHX_ "Undefined subroutine called");
2474 /* autoloaded stub? */
2475 if (cv != GvCV(gv)) {
2478 /* should call AUTOLOAD now? */
2481 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2488 sub_name = sv_newmortal();
2489 gv_efullname3(sub_name, gv, Nullch);
2490 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2494 DIE(aTHX_ "Not a CODE reference");
2499 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2500 cv = get_db_sub(&sv, cv);
2502 DIE(aTHX_ "No DBsub routine");
2507 * First we need to check if the sub or method requires locking.
2508 * If so, we gain a lock on the CV, the first argument or the
2509 * stash (for static methods), as appropriate. This has to be
2510 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2511 * reschedule by returning a new op.
2513 MUTEX_LOCK(CvMUTEXP(cv));
2514 if (CvFLAGS(cv) & CVf_LOCKED) {
2516 if (CvFLAGS(cv) & CVf_METHOD) {
2517 if (SP > PL_stack_base + TOPMARK)
2518 sv = *(PL_stack_base + TOPMARK + 1);
2520 AV *av = (AV*)PL_curpad[0];
2521 if (hasargs || !av || AvFILLp(av) < 0
2522 || !(sv = AvARRAY(av)[0]))
2524 MUTEX_UNLOCK(CvMUTEXP(cv));
2525 DIE(aTHX_ "no argument for locked method call");
2532 char *stashname = SvPV(sv, len);
2533 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2539 MUTEX_UNLOCK(CvMUTEXP(cv));
2540 mg = condpair_magic(sv);
2541 MUTEX_LOCK(MgMUTEXP(mg));
2542 if (MgOWNER(mg) == thr)
2543 MUTEX_UNLOCK(MgMUTEXP(mg));
2546 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2548 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2550 MUTEX_UNLOCK(MgMUTEXP(mg));
2551 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2553 MUTEX_LOCK(CvMUTEXP(cv));
2556 * Now we have permission to enter the sub, we must distinguish
2557 * four cases. (0) It's an XSUB (in which case we don't care
2558 * about ownership); (1) it's ours already (and we're recursing);
2559 * (2) it's free (but we may already be using a cached clone);
2560 * (3) another thread owns it. Case (1) is easy: we just use it.
2561 * Case (2) means we look for a clone--if we have one, use it
2562 * otherwise grab ownership of cv. Case (3) means we look for a
2563 * clone (for non-XSUBs) and have to create one if we don't
2565 * Why look for a clone in case (2) when we could just grab
2566 * ownership of cv straight away? Well, we could be recursing,
2567 * i.e. we originally tried to enter cv while another thread
2568 * owned it (hence we used a clone) but it has been freed up
2569 * and we're now recursing into it. It may or may not be "better"
2570 * to use the clone but at least CvDEPTH can be trusted.
2572 if (CvOWNER(cv) == thr || CvXSUB(cv))
2573 MUTEX_UNLOCK(CvMUTEXP(cv));
2575 /* Case (2) or (3) */
2579 * XXX Might it be better to release CvMUTEXP(cv) while we
2580 * do the hv_fetch? We might find someone has pinched it
2581 * when we look again, in which case we would be in case
2582 * (3) instead of (2) so we'd have to clone. Would the fact
2583 * that we released the mutex more quickly make up for this?
2585 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2587 /* We already have a clone to use */
2588 MUTEX_UNLOCK(CvMUTEXP(cv));
2590 DEBUG_S(PerlIO_printf(Perl_debug_log,
2591 "entersub: %p already has clone %p:%s\n",
2592 thr, cv, SvPEEK((SV*)cv)));
2595 if (CvDEPTH(cv) == 0)
2596 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2599 /* (2) => grab ownership of cv. (3) => make clone */
2603 MUTEX_UNLOCK(CvMUTEXP(cv));
2604 DEBUG_S(PerlIO_printf(Perl_debug_log,
2605 "entersub: %p grabbing %p:%s in stash %s\n",
2606 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2607 HvNAME(CvSTASH(cv)) : "(none)"));
2610 /* Make a new clone. */
2612 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2613 MUTEX_UNLOCK(CvMUTEXP(cv));
2614 DEBUG_S((PerlIO_printf(Perl_debug_log,
2615 "entersub: %p cloning %p:%s\n",
2616 thr, cv, SvPEEK((SV*)cv))));
2618 * We're creating a new clone so there's no race
2619 * between the original MUTEX_UNLOCK and the
2620 * SvREFCNT_inc since no one will be trying to undef
2621 * it out from underneath us. At least, I don't think
2624 clonecv = cv_clone(cv);
2625 SvREFCNT_dec(cv); /* finished with this */
2626 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2627 CvOWNER(clonecv) = thr;
2631 DEBUG_S(if (CvDEPTH(cv) != 0)
2632 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2634 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2637 #endif /* USE_THREADS */
2640 #ifdef PERL_XSUB_OLDSTYLE
2641 if (CvOLDSTYLE(cv)) {
2642 I32 (*fp3)(int,int,int);
2644 register I32 items = SP - MARK;
2645 /* We dont worry to copy from @_. */
2650 PL_stack_sp = mark + 1;
2651 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2652 items = (*fp3)(CvXSUBANY(cv).any_i32,
2653 MARK - PL_stack_base + 1,
2655 PL_stack_sp = PL_stack_base + items;
2658 #endif /* PERL_XSUB_OLDSTYLE */
2660 I32 markix = TOPMARK;
2665 /* Need to copy @_ to stack. Alternative may be to
2666 * switch stack to @_, and copy return values
2667 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2671 av = (AV*)PL_curpad[0];
2673 av = GvAV(PL_defgv);
2674 #endif /* USE_THREADS */
2675 items = AvFILLp(av) + 1; /* @_ is not tieable */
2678 /* Mark is at the end of the stack. */
2680 Copy(AvARRAY(av), SP + 1, items, SV*);
2685 /* We assume first XSUB in &DB::sub is the called one. */
2687 SAVEVPTR(PL_curcop);
2688 PL_curcop = PL_curcopdb;
2691 /* Do we need to open block here? XXXX */
2692 (void)(*CvXSUB(cv))(aTHXo_ cv);
2694 /* Enforce some sanity in scalar context. */
2695 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2696 if (markix > PL_stack_sp - PL_stack_base)
2697 *(PL_stack_base + markix) = &PL_sv_undef;
2699 *(PL_stack_base + markix) = *PL_stack_sp;
2700 PL_stack_sp = PL_stack_base + markix;
2708 register I32 items = SP - MARK;
2709 AV* padlist = CvPADLIST(cv);
2710 SV** svp = AvARRAY(padlist);
2711 push_return(PL_op->op_next);
2712 PUSHBLOCK(cx, CXt_SUB, MARK);
2715 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2716 * that eval'' ops within this sub know the correct lexical space.
2717 * Owing the speed considerations, we choose to search for the cv
2718 * in doeval() instead.
2720 if (CvDEPTH(cv) < 2)
2721 (void)SvREFCNT_inc(cv);
2722 else { /* save temporaries on recursion? */
2723 PERL_STACK_OVERFLOW_CHECK();
2724 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2726 AV *newpad = newAV();
2727 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2728 I32 ix = AvFILLp((AV*)svp[1]);
2729 I32 names_fill = AvFILLp((AV*)svp[0]);
2730 svp = AvARRAY(svp[0]);
2731 for ( ;ix > 0; ix--) {
2732 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2733 char *name = SvPVX(svp[ix]);
2734 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2735 || *name == '&') /* anonymous code? */
2737 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2739 else { /* our own lexical */
2741 av_store(newpad, ix, sv = (SV*)newAV());
2742 else if (*name == '%')
2743 av_store(newpad, ix, sv = (SV*)newHV());
2745 av_store(newpad, ix, sv = NEWSV(0,0));
2749 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2750 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2753 av_store(newpad, ix, sv = NEWSV(0,0));
2757 av = newAV(); /* will be @_ */
2759 av_store(newpad, 0, (SV*)av);
2760 AvFLAGS(av) = AVf_REIFY;
2761 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2762 AvFILLp(padlist) = CvDEPTH(cv);
2763 svp = AvARRAY(padlist);
2768 AV* av = (AV*)PL_curpad[0];
2770 items = AvFILLp(av) + 1;
2772 /* Mark is at the end of the stack. */
2774 Copy(AvARRAY(av), SP + 1, items, SV*);
2779 #endif /* USE_THREADS */
2780 SAVEVPTR(PL_curpad);
2781 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2784 #endif /* USE_THREADS */
2790 DEBUG_S(PerlIO_printf(Perl_debug_log,
2791 "%p entersub preparing @_\n", thr));
2793 av = (AV*)PL_curpad[0];
2795 /* @_ is normally not REAL--this should only ever
2796 * happen when DB::sub() calls things that modify @_ */
2802 cx->blk_sub.savearray = GvAV(PL_defgv);
2803 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2804 #endif /* USE_THREADS */
2805 cx->blk_sub.oldcurpad = PL_curpad;
2806 cx->blk_sub.argarray = av;
2809 if (items > AvMAX(av) + 1) {
2811 if (AvARRAY(av) != ary) {
2812 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2813 SvPVX(av) = (char*)ary;
2815 if (items > AvMAX(av) + 1) {
2816 AvMAX(av) = items - 1;
2817 Renew(ary,items,SV*);
2819 SvPVX(av) = (char*)ary;
2822 Copy(MARK,AvARRAY(av),items,SV*);
2823 AvFILLp(av) = items - 1;
2831 /* warning must come *after* we fully set up the context
2832 * stuff so that __WARN__ handlers can safely dounwind()
2835 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2836 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2837 sub_crush_depth(cv);
2839 DEBUG_S(PerlIO_printf(Perl_debug_log,
2840 "%p entersub returning %p\n", thr, CvSTART(cv)));
2842 RETURNOP(CvSTART(cv));
2847 Perl_sub_crush_depth(pTHX_ CV *cv)
2850 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2852 SV* tmpstr = sv_newmortal();
2853 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2854 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2864 IV elem = SvIV(elemsv);
2866 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2867 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2870 if (SvROK(elemsv) && ckWARN(WARN_MISC))
2871 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2873 elem -= PL_curcop->cop_arybase;
2874 if (SvTYPE(av) != SVt_PVAV)
2876 svp = av_fetch(av, elem, lval && !defer);
2878 if (!svp || *svp == &PL_sv_undef) {
2881 DIE(aTHX_ PL_no_aelem, elem);
2882 lv = sv_newmortal();
2883 sv_upgrade(lv, SVt_PVLV);
2885 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2886 LvTARG(lv) = SvREFCNT_inc(av);
2887 LvTARGOFF(lv) = elem;
2892 if (PL_op->op_private & OPpLVAL_INTRO)
2893 save_aelem(av, elem, svp);
2894 else if (PL_op->op_private & OPpDEREF)
2895 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2897 sv = (svp ? *svp : &PL_sv_undef);
2898 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2899 sv = sv_mortalcopy(sv);
2905 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2911 Perl_croak(aTHX_ PL_no_modify);
2912 if (SvTYPE(sv) < SVt_RV)
2913 sv_upgrade(sv, SVt_RV);
2914 else if (SvTYPE(sv) >= SVt_PV) {
2915 (void)SvOOK_off(sv);
2916 Safefree(SvPVX(sv));
2917 SvLEN(sv) = SvCUR(sv) = 0;
2921 SvRV(sv) = NEWSV(355,0);
2924 SvRV(sv) = (SV*)newAV();
2927 SvRV(sv) = (SV*)newHV();
2942 if (SvTYPE(rsv) == SVt_PVCV) {
2948 SETs(method_common(sv, Null(U32*)));
2955 SV* sv = cSVOP->op_sv;
2956 U32 hash = SvUVX(sv);
2958 XPUSHs(method_common(sv, &hash));
2963 S_method_common(pTHX_ SV* meth, U32* hashp)
2974 name = SvPV(meth, namelen);
2975 sv = *(PL_stack_base + TOPMARK + 1);
2978 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2989 !(packname = SvPV(sv, packlen)) ||
2990 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2991 !(ob=(SV*)GvIO(iogv)))
2994 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2995 ? !isIDFIRST_utf8((U8*)packname)
2996 : !isIDFIRST(*packname)
2999 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3000 SvOK(sv) ? "without a package or object reference"
3001 : "on an undefined value");
3003 stash = gv_stashpvn(packname, packlen, TRUE);
3006 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3009 if (!ob || !(SvOBJECT(ob)
3010 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3013 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3017 stash = SvSTASH(ob);
3020 /* shortcut for simple names */
3022 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3024 gv = (GV*)HeVAL(he);
3025 if (isGV(gv) && GvCV(gv) &&
3026 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3027 return (SV*)GvCV(gv);
3031 gv = gv_fetchmethod(stash, name);
3038 for (p = name; *p; p++) {
3040 sep = p, leaf = p + 1;
3041 else if (*p == ':' && *(p + 1) == ':')
3042 sep = p, leaf = p + 2;
3044 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3045 packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
3046 packlen = strlen(packname);
3050 packlen = sep - name;
3052 gv = gv_fetchpv(packname, 0, SVt_PVHV);
3053 if (gv && isGV(gv)) {
3055 "Can't locate object method \"%s\" via package \"%s\"",
3060 "Can't locate object method \"%s\" via package \"%s\""
3061 " (perhaps you forgot to load \"%s\"?)",
3062 leaf, packname, packname);
3065 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3070 unset_cvowner(pTHXo_ void *cvarg)
3072 register CV* cv = (CV *) cvarg;
3074 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3075 thr, cv, SvPEEK((SV*)cv))));
3076 MUTEX_LOCK(CvMUTEXP(cv));
3077 DEBUG_S(if (CvDEPTH(cv) != 0)
3078 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3080 assert(thr == CvOWNER(cv));
3082 MUTEX_UNLOCK(CvMUTEXP(cv));
3085 #endif /* USE_THREADS */