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 dSP; 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 dSP; 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 dSP; 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);
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 dSP; dMARK; dORIGMARK;
546 if (PL_op->op_flags & OPf_STACKED)
550 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
552 if (MARK == ORIGMARK) {
553 /* If using default handle then we need to make space to
554 * pass object as 1st arg, so move other args up ...
558 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
562 *MARK = SvTIED_obj((SV*)gv, mg);
565 call_method("PRINT", G_SCALAR);
573 if (!(io = GvIO(gv))) {
574 if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
576 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
577 report_evil_fh(gv, io, PL_op->op_type);
578 SETERRNO(EBADF,RMS$_IFI);
581 else if (!(fp = IoOFP(io))) {
582 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
584 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
585 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
586 report_evil_fh(gv, io, PL_op->op_type);
588 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
593 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
595 if (!do_print(*MARK, fp))
599 if (!do_print(PL_ofs_sv, fp)) { /* $, */
608 if (!do_print(*MARK, fp))
616 if (PL_ors_sv && SvOK(PL_ors_sv))
617 if (!do_print(PL_ors_sv, fp)) /* $\ */
620 if (IoFLAGS(io) & IOf_FLUSH)
621 if (PerlIO_flush(fp) == EOF)
642 tryAMAGICunDEREF(to_av);
645 if (SvTYPE(av) != SVt_PVAV)
646 DIE(aTHX_ "Not an ARRAY reference");
647 if (PL_op->op_flags & OPf_REF) {
652 if (GIMME == G_SCALAR)
653 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
659 if (SvTYPE(sv) == SVt_PVAV) {
661 if (PL_op->op_flags & OPf_REF) {
666 if (GIMME == G_SCALAR)
667 Perl_croak(aTHX_ "Can't return array to lvalue"
676 if (SvTYPE(sv) != SVt_PVGV) {
680 if (SvGMAGICAL(sv)) {
686 if (PL_op->op_flags & OPf_REF ||
687 PL_op->op_private & HINT_STRICT_REFS)
688 DIE(aTHX_ PL_no_usym, "an ARRAY");
689 if (ckWARN(WARN_UNINITIALIZED))
691 if (GIMME == G_ARRAY) {
698 if ((PL_op->op_flags & OPf_SPECIAL) &&
699 !(PL_op->op_flags & OPf_MOD))
701 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
703 && (!is_gv_magical(sym,len,0)
704 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
710 if (PL_op->op_private & HINT_STRICT_REFS)
711 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
712 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
719 if (PL_op->op_private & OPpLVAL_INTRO)
721 if (PL_op->op_flags & OPf_REF) {
726 if (GIMME == G_SCALAR)
727 Perl_croak(aTHX_ "Can't return array to lvalue"
735 if (GIMME == G_ARRAY) {
736 I32 maxarg = AvFILL(av) + 1;
737 (void)POPs; /* XXXX May be optimized away? */
739 if (SvRMAGICAL(av)) {
741 for (i=0; i < maxarg; i++) {
742 SV **svp = av_fetch(av, i, FALSE);
743 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
747 Copy(AvARRAY(av), SP+1, maxarg, SV*);
753 I32 maxarg = AvFILL(av) + 1;
766 tryAMAGICunDEREF(to_hv);
769 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
770 DIE(aTHX_ "Not a HASH reference");
771 if (PL_op->op_flags & OPf_REF) {
776 if (GIMME == G_SCALAR)
777 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
783 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
785 if (PL_op->op_flags & OPf_REF) {
790 if (GIMME == G_SCALAR)
791 Perl_croak(aTHX_ "Can't return hash to lvalue"
800 if (SvTYPE(sv) != SVt_PVGV) {
804 if (SvGMAGICAL(sv)) {
810 if (PL_op->op_flags & OPf_REF ||
811 PL_op->op_private & HINT_STRICT_REFS)
812 DIE(aTHX_ PL_no_usym, "a HASH");
813 if (ckWARN(WARN_UNINITIALIZED))
815 if (GIMME == G_ARRAY) {
822 if ((PL_op->op_flags & OPf_SPECIAL) &&
823 !(PL_op->op_flags & OPf_MOD))
825 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
827 && (!is_gv_magical(sym,len,0)
828 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
834 if (PL_op->op_private & HINT_STRICT_REFS)
835 DIE(aTHX_ PL_no_symref, sym, "a HASH");
836 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
843 if (PL_op->op_private & OPpLVAL_INTRO)
845 if (PL_op->op_flags & OPf_REF) {
850 if (GIMME == G_SCALAR)
851 Perl_croak(aTHX_ "Can't return hash to lvalue"
859 if (GIMME == G_ARRAY) { /* array wanted */
860 *PL_stack_sp = (SV*)hv;
865 if (SvTYPE(hv) == SVt_PVAV)
866 hv = avhv_keys((AV*)hv);
868 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
869 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
879 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
885 leftop = ((BINOP*)PL_op)->op_last;
887 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
888 leftop = ((LISTOP*)leftop)->op_first;
890 /* Skip PUSHMARK and each element already assigned to. */
891 for (i = lelem - firstlelem; i > 0; i--) {
892 leftop = leftop->op_sibling;
895 if (leftop->op_type != OP_RV2HV)
900 av_fill(ary, 0); /* clear all but the fields hash */
901 if (lastrelem >= relem) {
902 while (relem < lastrelem) { /* gobble up all the rest */
906 /* Avoid a memory leak when avhv_store_ent dies. */
907 tmpstr = sv_newmortal();
908 sv_setsv(tmpstr,relem[1]); /* value */
910 if (avhv_store_ent(ary,relem[0],tmpstr,0))
911 (void)SvREFCNT_inc(tmpstr);
912 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
918 if (relem == lastrelem)
924 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
928 if (ckWARN(WARN_MISC)) {
929 if (relem == firstrelem &&
931 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
932 SvTYPE(SvRV(*relem)) == SVt_PVHV))
934 Perl_warner(aTHX_ WARN_MISC,
935 "Reference found where even-sized list expected");
938 Perl_warner(aTHX_ WARN_MISC,
939 "Odd number of elements in hash assignment");
941 if (SvTYPE(hash) == SVt_PVAV) {
943 tmpstr = sv_newmortal();
944 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
945 (void)SvREFCNT_inc(tmpstr);
946 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
951 tmpstr = NEWSV(29,0);
952 didstore = hv_store_ent(hash,*relem,tmpstr,0);
953 if (SvMAGICAL(hash)) {
954 if (SvSMAGICAL(tmpstr))
967 SV **lastlelem = PL_stack_sp;
968 SV **lastrelem = PL_stack_base + POPMARK;
969 SV **firstrelem = PL_stack_base + POPMARK + 1;
970 SV **firstlelem = lastrelem + 1;
983 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
985 /* If there's a common identifier on both sides we have to take
986 * special care that assigning the identifier on the left doesn't
987 * clobber a value on the right that's used later in the list.
989 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
990 EXTEND_MORTAL(lastrelem - firstrelem + 1);
991 for (relem = firstrelem; relem <= lastrelem; relem++) {
994 TAINT_NOT; /* Each item is independent */
995 *relem = sv_mortalcopy(sv);
1005 while (lelem <= lastlelem) {
1006 TAINT_NOT; /* Each item stands on its own, taintwise. */
1008 switch (SvTYPE(sv)) {
1011 magic = SvMAGICAL(ary) != 0;
1012 if (PL_op->op_private & OPpASSIGN_HASH) {
1013 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1019 do_oddball((HV*)ary, relem, firstrelem);
1021 relem = lastrelem + 1;
1026 av_extend(ary, lastrelem - relem);
1028 while (relem <= lastrelem) { /* gobble up all the rest */
1032 sv_setsv(sv,*relem);
1034 didstore = av_store(ary,i++,sv);
1044 case SVt_PVHV: { /* normal hash */
1048 magic = SvMAGICAL(hash) != 0;
1051 while (relem < lastrelem) { /* gobble up all the rest */
1056 sv = &PL_sv_no, relem++;
1057 tmpstr = NEWSV(29,0);
1059 sv_setsv(tmpstr,*relem); /* value */
1060 *(relem++) = tmpstr;
1061 didstore = hv_store_ent(hash,sv,tmpstr,0);
1063 if (SvSMAGICAL(tmpstr))
1070 if (relem == lastrelem) {
1071 do_oddball(hash, relem, firstrelem);
1077 if (SvIMMORTAL(sv)) {
1078 if (relem <= lastrelem)
1082 if (relem <= lastrelem) {
1083 sv_setsv(sv, *relem);
1087 sv_setsv(sv, &PL_sv_undef);
1092 if (PL_delaymagic & ~DM_DELAY) {
1093 if (PL_delaymagic & DM_UID) {
1094 #ifdef HAS_SETRESUID
1095 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1097 # ifdef HAS_SETREUID
1098 (void)setreuid(PL_uid,PL_euid);
1101 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1102 (void)setruid(PL_uid);
1103 PL_delaymagic &= ~DM_RUID;
1105 # endif /* HAS_SETRUID */
1107 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1108 (void)seteuid(PL_uid);
1109 PL_delaymagic &= ~DM_EUID;
1111 # endif /* HAS_SETEUID */
1112 if (PL_delaymagic & DM_UID) {
1113 if (PL_uid != PL_euid)
1114 DIE(aTHX_ "No setreuid available");
1115 (void)PerlProc_setuid(PL_uid);
1117 # endif /* HAS_SETREUID */
1118 #endif /* HAS_SETRESUID */
1119 PL_uid = PerlProc_getuid();
1120 PL_euid = PerlProc_geteuid();
1122 if (PL_delaymagic & DM_GID) {
1123 #ifdef HAS_SETRESGID
1124 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1126 # ifdef HAS_SETREGID
1127 (void)setregid(PL_gid,PL_egid);
1130 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1131 (void)setrgid(PL_gid);
1132 PL_delaymagic &= ~DM_RGID;
1134 # endif /* HAS_SETRGID */
1136 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1137 (void)setegid(PL_gid);
1138 PL_delaymagic &= ~DM_EGID;
1140 # endif /* HAS_SETEGID */
1141 if (PL_delaymagic & DM_GID) {
1142 if (PL_gid != PL_egid)
1143 DIE(aTHX_ "No setregid available");
1144 (void)PerlProc_setgid(PL_gid);
1146 # endif /* HAS_SETREGID */
1147 #endif /* HAS_SETRESGID */
1148 PL_gid = PerlProc_getgid();
1149 PL_egid = PerlProc_getegid();
1151 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1156 if (gimme == G_VOID)
1157 SP = firstrelem - 1;
1158 else if (gimme == G_SCALAR) {
1161 SETi(lastrelem - firstrelem + 1);
1167 SP = firstrelem + (lastlelem - firstlelem);
1168 lelem = firstlelem + (relem - firstrelem);
1170 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1178 register PMOP *pm = cPMOP;
1179 SV *rv = sv_newmortal();
1180 SV *sv = newSVrv(rv, "Regexp");
1181 sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
1188 register PMOP *pm = cPMOP;
1193 I32 r_flags = REXEC_CHECKED;
1194 char *truebase; /* Start of string */
1195 register REGEXP *rx = pm->op_pmregexp;
1200 I32 oldsave = PL_savestack_ix;
1201 I32 update_minmatch = 1;
1202 I32 had_zerolen = 0;
1204 if (PL_op->op_flags & OPf_STACKED)
1211 PUTBACK; /* EVAL blocks need stack_sp. */
1212 s = SvPV(TARG, len);
1215 DIE(aTHX_ "panic: pp_match");
1216 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1217 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1220 if (pm->op_pmdynflags & PMdf_USED) {
1222 if (gimme == G_ARRAY)
1227 if (!rx->prelen && PL_curpm) {
1229 rx = pm->op_pmregexp;
1231 if (rx->minlen > len) goto failure;
1235 /* XXXX What part of this is needed with true \G-support? */
1236 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1238 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1239 MAGIC* mg = mg_find(TARG, 'g');
1240 if (mg && mg->mg_len >= 0) {
1241 if (!(rx->reganch & ROPT_GPOS_SEEN))
1242 rx->endp[0] = rx->startp[0] = mg->mg_len;
1243 else if (rx->reganch & ROPT_ANCH_GPOS) {
1244 r_flags |= REXEC_IGNOREPOS;
1245 rx->endp[0] = rx->startp[0] = mg->mg_len;
1247 minmatch = (mg->mg_flags & MGf_MINMATCH);
1248 update_minmatch = 0;
1252 if ((!global && rx->nparens)
1253 || SvTEMP(TARG) || PL_sawampersand)
1254 r_flags |= REXEC_COPY_STR;
1256 r_flags |= REXEC_SCREAM;
1258 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1259 SAVEINT(PL_multiline);
1260 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1264 if (global && rx->startp[0] != -1) {
1265 t = s = rx->endp[0] + truebase;
1266 if ((s + rx->minlen) > strend)
1268 if (update_minmatch++)
1269 minmatch = had_zerolen;
1271 if (rx->reganch & RE_USE_INTUIT &&
1272 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1273 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1277 if ( (rx->reganch & ROPT_CHECK_ALL)
1279 && ((rx->reganch & ROPT_NOSCAN)
1280 || !((rx->reganch & RE_INTUIT_TAIL)
1281 && (r_flags & REXEC_SCREAM)))
1282 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1285 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1288 if (pm->op_pmflags & PMf_ONCE)
1289 pm->op_pmdynflags |= PMdf_USED;
1298 RX_MATCH_TAINTED_on(rx);
1299 TAINT_IF(RX_MATCH_TAINTED(rx));
1300 if (gimme == G_ARRAY) {
1301 I32 nparens, i, len;
1303 nparens = rx->nparens;
1304 if (global && !nparens)
1308 SPAGAIN; /* EVAL blocks could move the stack. */
1309 EXTEND(SP, nparens + i);
1310 EXTEND_MORTAL(nparens + i);
1311 for (i = !i; i <= nparens; i++) {
1312 PUSHs(sv_newmortal());
1314 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1315 len = rx->endp[i] - rx->startp[i];
1316 s = rx->startp[i] + truebase;
1317 sv_setpvn(*SP, s, len);
1323 had_zerolen = (rx->startp[0] != -1
1324 && rx->startp[0] == rx->endp[0]);
1325 PUTBACK; /* EVAL blocks may use stack */
1326 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1331 LEAVE_SCOPE(oldsave);
1337 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1338 mg = mg_find(TARG, 'g');
1340 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1341 mg = mg_find(TARG, 'g');
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 LEAVE_SCOPE(oldsave);
1355 yup: /* Confirmed by INTUIT */
1357 RX_MATCH_TAINTED_on(rx);
1358 TAINT_IF(RX_MATCH_TAINTED(rx));
1360 if (pm->op_pmflags & PMf_ONCE)
1361 pm->op_pmdynflags |= PMdf_USED;
1362 if (RX_MATCH_COPIED(rx))
1363 Safefree(rx->subbeg);
1364 RX_MATCH_COPIED_off(rx);
1365 rx->subbeg = Nullch;
1367 rx->subbeg = truebase;
1368 rx->startp[0] = s - truebase;
1369 if (DO_UTF8(PL_reg_sv)) {
1370 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1371 rx->endp[0] = t - truebase;
1374 rx->endp[0] = s - truebase + rx->minlen;
1376 rx->sublen = strend - truebase;
1379 if (PL_sawampersand) {
1382 rx->subbeg = savepvn(t, strend - t);
1383 rx->sublen = strend - t;
1384 RX_MATCH_COPIED_on(rx);
1385 off = rx->startp[0] = s - t;
1386 rx->endp[0] = off + rx->minlen;
1388 else { /* startp/endp are used by @- @+. */
1389 rx->startp[0] = s - truebase;
1390 rx->endp[0] = s - truebase + rx->minlen;
1392 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1393 LEAVE_SCOPE(oldsave);
1398 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1399 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1400 MAGIC* mg = mg_find(TARG, 'g');
1405 LEAVE_SCOPE(oldsave);
1406 if (gimme == G_ARRAY)
1412 Perl_do_readline(pTHX)
1414 dSP; dTARGETSTACKED;
1419 register IO *io = GvIO(PL_last_in_gv);
1420 register I32 type = PL_op->op_type;
1421 I32 gimme = GIMME_V;
1424 if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
1426 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1429 call_method("READLINE", gimme);
1432 if (gimme == G_SCALAR)
1433 SvSetMagicSV_nosteal(TARG, TOPs);
1440 if (IoFLAGS(io) & IOf_ARGV) {
1441 if (IoFLAGS(io) & IOf_START) {
1443 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1444 IoFLAGS(io) &= ~IOf_START;
1445 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1446 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1447 SvSETMAGIC(GvSV(PL_last_in_gv));
1452 fp = nextargv(PL_last_in_gv);
1453 if (!fp) { /* Note: fp != IoIFP(io) */
1454 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1457 else if (type == OP_GLOB)
1458 fp = Perl_start_glob(aTHX_ POPs, io);
1460 else if (type == OP_GLOB)
1462 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1463 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1467 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1468 && (!io || !(IoFLAGS(io) & IOf_START))) {
1469 if (type == OP_GLOB)
1470 Perl_warner(aTHX_ WARN_GLOB,
1471 "glob failed (can't start child: %s)",
1474 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1476 if (gimme == G_SCALAR) {
1477 (void)SvOK_off(TARG);
1483 if (gimme == G_SCALAR) {
1487 (void)SvUPGRADE(sv, SVt_PV);
1488 tmplen = SvLEN(sv); /* remember if already alloced */
1490 Sv_Grow(sv, 80); /* try short-buffering it */
1491 if (type == OP_RCATLINE)
1497 sv = sv_2mortal(NEWSV(57, 80));
1501 /* This should not be marked tainted if the fp is marked clean */
1502 #define MAYBE_TAINT_LINE(io, sv) \
1503 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1508 /* delay EOF state for a snarfed empty file */
1509 #define SNARF_EOF(gimme,rs,io,sv) \
1510 (gimme != G_SCALAR || SvCUR(sv) \
1511 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1514 if (!sv_gets(sv, fp, offset)
1515 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1517 PerlIO_clearerr(fp);
1518 if (IoFLAGS(io) & IOf_ARGV) {
1519 fp = nextargv(PL_last_in_gv);
1522 (void)do_close(PL_last_in_gv, FALSE);
1524 else if (type == OP_GLOB) {
1525 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1526 Perl_warner(aTHX_ WARN_GLOB,
1527 "glob failed (child exited with status %d%s)",
1528 (int)(STATUS_CURRENT >> 8),
1529 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1532 if (gimme == G_SCALAR) {
1533 (void)SvOK_off(TARG);
1536 MAYBE_TAINT_LINE(io, sv);
1539 MAYBE_TAINT_LINE(io, sv);
1541 IoFLAGS(io) |= IOf_NOLINE;
1544 if (type == OP_GLOB) {
1547 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1548 tmps = SvEND(sv) - 1;
1549 if (*tmps == *SvPVX(PL_rs)) {
1554 for (tmps = SvPVX(sv); *tmps; tmps++)
1555 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1556 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1558 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1559 (void)POPs; /* Unmatched wildcard? Chuck it... */
1563 if (gimme == G_ARRAY) {
1564 if (SvLEN(sv) - SvCUR(sv) > 20) {
1565 SvLEN_set(sv, SvCUR(sv)+1);
1566 Renew(SvPVX(sv), SvLEN(sv), char);
1568 sv = sv_2mortal(NEWSV(58, 80));
1571 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1572 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1576 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1577 Renew(SvPVX(sv), SvLEN(sv), char);
1586 register PERL_CONTEXT *cx;
1587 I32 gimme = OP_GIMME(PL_op, -1);
1590 if (cxstack_ix >= 0)
1591 gimme = cxstack[cxstack_ix].blk_gimme;
1599 PUSHBLOCK(cx, CXt_BLOCK, SP);
1611 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1612 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1614 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1617 if (SvTYPE(hv) == SVt_PVHV) {
1618 if (PL_op->op_private & OPpLVAL_INTRO)
1619 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1620 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1621 svp = he ? &HeVAL(he) : 0;
1623 else if (SvTYPE(hv) == SVt_PVAV) {
1624 if (PL_op->op_private & OPpLVAL_INTRO)
1625 DIE(aTHX_ "Can't localize pseudo-hash element");
1626 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1632 if (!svp || *svp == &PL_sv_undef) {
1637 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1639 lv = sv_newmortal();
1640 sv_upgrade(lv, SVt_PVLV);
1642 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1643 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1644 LvTARG(lv) = SvREFCNT_inc(hv);
1649 if (PL_op->op_private & OPpLVAL_INTRO) {
1650 if (HvNAME(hv) && isGV(*svp))
1651 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1655 char *key = SvPV(keysv, keylen);
1656 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1658 save_helem(hv, keysv, svp);
1661 else if (PL_op->op_private & OPpDEREF)
1662 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1664 sv = (svp ? *svp : &PL_sv_undef);
1665 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1666 * Pushing the magical RHS on to the stack is useless, since
1667 * that magic is soon destined to be misled by the local(),
1668 * and thus the later pp_sassign() will fail to mg_get() the
1669 * old value. This should also cure problems with delayed
1670 * mg_get()s. GSAR 98-07-03 */
1671 if (!lval && SvGMAGICAL(sv))
1672 sv = sv_mortalcopy(sv);
1680 register PERL_CONTEXT *cx;
1686 if (PL_op->op_flags & OPf_SPECIAL) {
1687 cx = &cxstack[cxstack_ix];
1688 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1693 gimme = OP_GIMME(PL_op, -1);
1695 if (cxstack_ix >= 0)
1696 gimme = cxstack[cxstack_ix].blk_gimme;
1702 if (gimme == G_VOID)
1704 else if (gimme == G_SCALAR) {
1707 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1710 *MARK = sv_mortalcopy(TOPs);
1713 *MARK = &PL_sv_undef;
1717 else if (gimme == G_ARRAY) {
1718 /* in case LEAVE wipes old return values */
1719 for (mark = newsp + 1; mark <= SP; mark++) {
1720 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1721 *mark = sv_mortalcopy(*mark);
1722 TAINT_NOT; /* Each item is independent */
1726 PL_curpm = newpm; /* Don't pop $1 et al till now */
1736 register PERL_CONTEXT *cx;
1742 cx = &cxstack[cxstack_ix];
1743 if (CxTYPE(cx) != CXt_LOOP)
1744 DIE(aTHX_ "panic: pp_iter");
1746 itersvp = CxITERVAR(cx);
1747 av = cx->blk_loop.iterary;
1748 if (SvTYPE(av) != SVt_PVAV) {
1749 /* iterate ($min .. $max) */
1750 if (cx->blk_loop.iterlval) {
1751 /* string increment */
1752 register SV* cur = cx->blk_loop.iterlval;
1754 char *max = SvPV((SV*)av, maxlen);
1755 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1756 #ifndef USE_THREADS /* don't risk potential race */
1757 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1758 /* safe to reuse old SV */
1759 sv_setsv(*itersvp, cur);
1764 /* we need a fresh SV every time so that loop body sees a
1765 * completely new SV for closures/references to work as
1767 SvREFCNT_dec(*itersvp);
1768 *itersvp = newSVsv(cur);
1770 if (strEQ(SvPVX(cur), max))
1771 sv_setiv(cur, 0); /* terminate next time */
1778 /* integer increment */
1779 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1782 #ifndef USE_THREADS /* don't risk potential race */
1783 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1784 /* safe to reuse old SV */
1785 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1790 /* we need a fresh SV every time so that loop body sees a
1791 * completely new SV for closures/references to work as they
1793 SvREFCNT_dec(*itersvp);
1794 *itersvp = newSViv(cx->blk_loop.iterix++);
1800 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1803 SvREFCNT_dec(*itersvp);
1805 if ((sv = SvMAGICAL(av)
1806 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1807 : AvARRAY(av)[++cx->blk_loop.iterix]))
1811 if (av != PL_curstack && SvIMMORTAL(sv)) {
1812 SV *lv = cx->blk_loop.iterlval;
1813 if (lv && SvREFCNT(lv) > 1) {
1818 SvREFCNT_dec(LvTARG(lv));
1820 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1821 sv_upgrade(lv, SVt_PVLV);
1823 sv_magic(lv, Nullsv, 'y', Nullch, 0);
1825 LvTARG(lv) = SvREFCNT_inc(av);
1826 LvTARGOFF(lv) = cx->blk_loop.iterix;
1827 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1831 *itersvp = SvREFCNT_inc(sv);
1838 register PMOP *pm = cPMOP;
1854 register REGEXP *rx = pm->op_pmregexp;
1856 int force_on_match = 0;
1857 I32 oldsave = PL_savestack_ix;
1861 /* known replacement string? */
1862 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1863 if (PL_op->op_flags & OPf_STACKED)
1870 do_utf8 = DO_UTF8(PL_reg_sv);
1871 if (SvFAKE(TARG) && SvREADONLY(TARG))
1872 sv_force_normal(TARG);
1873 if (SvREADONLY(TARG)
1874 || (SvTYPE(TARG) > SVt_PVLV
1875 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1876 DIE(aTHX_ PL_no_modify);
1879 s = SvPV(TARG, len);
1880 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1882 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1883 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1890 DIE(aTHX_ "panic: pp_subst");
1893 slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1894 maxiters = 2 * slen + 10; /* We can match twice at each
1895 position, once with zero-length,
1896 second time with non-zero. */
1898 if (!rx->prelen && PL_curpm) {
1900 rx = pm->op_pmregexp;
1902 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1903 ? REXEC_COPY_STR : 0;
1905 r_flags |= REXEC_SCREAM;
1906 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1907 SAVEINT(PL_multiline);
1908 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1911 if (rx->reganch & RE_USE_INTUIT) {
1912 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1916 /* How to do it in subst? */
1917 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1919 && ((rx->reganch & ROPT_NOSCAN)
1920 || !((rx->reganch & RE_INTUIT_TAIL)
1921 && (r_flags & REXEC_SCREAM))))
1926 /* only replace once? */
1927 once = !(rpm->op_pmflags & PMf_GLOBAL);
1929 /* known replacement string? */
1930 c = dstr ? SvPV(dstr, clen) : Nullch;
1932 /* can do inplace substitution? */
1933 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1934 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1935 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1936 r_flags | REXEC_CHECKED))
1940 LEAVE_SCOPE(oldsave);
1943 if (force_on_match) {
1945 s = SvPV_force(TARG, len);
1950 SvSCREAM_off(TARG); /* disable possible screamer */
1952 rxtainted |= RX_MATCH_TAINTED(rx);
1953 m = orig + rx->startp[0];
1954 d = orig + rx->endp[0];
1956 if (m - s > strend - d) { /* faster to shorten from end */
1958 Copy(c, m, clen, char);
1963 Move(d, m, i, char);
1967 SvCUR_set(TARG, m - s);
1970 else if ((i = m - s)) { /* faster from front */
1978 Copy(c, m, clen, char);
1983 Copy(c, d, clen, char);
1988 TAINT_IF(rxtainted & 1);
1994 if (iters++ > maxiters)
1995 DIE(aTHX_ "Substitution loop");
1996 rxtainted |= RX_MATCH_TAINTED(rx);
1997 m = rx->startp[0] + orig;
2001 Move(s, d, i, char);
2005 Copy(c, d, clen, char);
2008 s = rx->endp[0] + orig;
2009 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2011 /* don't match same null twice */
2012 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2015 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2016 Move(s, d, i+1, char); /* include the NUL */
2018 TAINT_IF(rxtainted & 1);
2020 PUSHs(sv_2mortal(newSViv((I32)iters)));
2022 (void)SvPOK_only_UTF8(TARG);
2023 TAINT_IF(rxtainted);
2024 if (SvSMAGICAL(TARG)) {
2030 LEAVE_SCOPE(oldsave);
2034 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2035 r_flags | REXEC_CHECKED))
2039 if (force_on_match) {
2041 s = SvPV_force(TARG, len);
2044 rxtainted |= RX_MATCH_TAINTED(rx);
2045 dstr = NEWSV(25, len);
2046 sv_setpvn(dstr, m, s-m);
2051 register PERL_CONTEXT *cx;
2054 RETURNOP(cPMOP->op_pmreplroot);
2056 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2058 if (iters++ > maxiters)
2059 DIE(aTHX_ "Substitution loop");
2060 rxtainted |= RX_MATCH_TAINTED(rx);
2061 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2066 strend = s + (strend - m);
2068 m = rx->startp[0] + orig;
2069 sv_catpvn(dstr, s, m-s);
2070 s = rx->endp[0] + orig;
2072 sv_catpvn(dstr, c, clen);
2075 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2076 TARG, NULL, r_flags));
2077 sv_catpvn(dstr, s, strend - s);
2079 (void)SvOOK_off(TARG);
2080 Safefree(SvPVX(TARG));
2081 SvPVX(TARG) = SvPVX(dstr);
2082 SvCUR_set(TARG, SvCUR(dstr));
2083 SvLEN_set(TARG, SvLEN(dstr));
2084 isutf8 = DO_UTF8(dstr);
2088 TAINT_IF(rxtainted & 1);
2090 PUSHs(sv_2mortal(newSViv((I32)iters)));
2092 (void)SvPOK_only(TARG);
2095 TAINT_IF(rxtainted);
2098 LEAVE_SCOPE(oldsave);
2107 LEAVE_SCOPE(oldsave);
2116 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2117 ++*PL_markstack_ptr;
2118 LEAVE; /* exit inner scope */
2121 if (PL_stack_base + *PL_markstack_ptr > SP) {
2123 I32 gimme = GIMME_V;
2125 LEAVE; /* exit outer scope */
2126 (void)POPMARK; /* pop src */
2127 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2128 (void)POPMARK; /* pop dst */
2129 SP = PL_stack_base + POPMARK; /* pop original mark */
2130 if (gimme == G_SCALAR) {
2134 else if (gimme == G_ARRAY)
2141 ENTER; /* enter inner scope */
2144 src = PL_stack_base[*PL_markstack_ptr];
2148 RETURNOP(cLOGOP->op_other);
2159 register PERL_CONTEXT *cx;
2165 if (gimme == G_SCALAR) {
2168 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2170 *MARK = SvREFCNT_inc(TOPs);
2175 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2177 *MARK = sv_mortalcopy(sv);
2182 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2186 *MARK = &PL_sv_undef;
2190 else if (gimme == G_ARRAY) {
2191 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2192 if (!SvTEMP(*MARK)) {
2193 *MARK = sv_mortalcopy(*MARK);
2194 TAINT_NOT; /* Each item is independent */
2200 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2201 PL_curpm = newpm; /* ... and pop $1 et al */
2205 return pop_return();
2208 /* This duplicates the above code because the above code must not
2209 * get any slower by more conditions */
2217 register PERL_CONTEXT *cx;
2224 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2225 /* We are an argument to a function or grep().
2226 * This kind of lvalueness was legal before lvalue
2227 * subroutines too, so be backward compatible:
2228 * cannot report errors. */
2230 /* Scalar context *is* possible, on the LHS of -> only,
2231 * as in f()->meth(). But this is not an lvalue. */
2232 if (gimme == G_SCALAR)
2234 if (gimme == G_ARRAY) {
2235 if (!CvLVALUE(cx->blk_sub.cv))
2236 goto temporise_array;
2237 EXTEND_MORTAL(SP - newsp);
2238 for (mark = newsp + 1; mark <= SP; mark++) {
2241 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2242 *mark = sv_mortalcopy(*mark);
2244 /* Can be a localized value subject to deletion. */
2245 PL_tmps_stack[++PL_tmps_ix] = *mark;
2246 (void)SvREFCNT_inc(*mark);
2251 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2252 /* Here we go for robustness, not for speed, so we change all
2253 * the refcounts so the caller gets a live guy. Cannot set
2254 * TEMP, so sv_2mortal is out of question. */
2255 if (!CvLVALUE(cx->blk_sub.cv)) {
2260 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2262 if (gimme == G_SCALAR) {
2266 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2271 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2272 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2274 else { /* Can be a localized value
2275 * subject to deletion. */
2276 PL_tmps_stack[++PL_tmps_ix] = *mark;
2277 (void)SvREFCNT_inc(*mark);
2280 else { /* Should not happen? */
2285 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2286 (MARK > SP ? "Empty array" : "Array"));
2290 else if (gimme == G_ARRAY) {
2291 EXTEND_MORTAL(SP - newsp);
2292 for (mark = newsp + 1; mark <= SP; mark++) {
2293 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2294 /* Might be flattened array after $#array = */
2300 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2301 (*mark != &PL_sv_undef)
2303 ? "a readonly value" : "a temporary")
2304 : "an uninitialized value");
2307 /* Can be a localized value subject to deletion. */
2308 PL_tmps_stack[++PL_tmps_ix] = *mark;
2309 (void)SvREFCNT_inc(*mark);
2315 if (gimme == G_SCALAR) {
2319 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2321 *MARK = SvREFCNT_inc(TOPs);
2326 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2328 *MARK = sv_mortalcopy(sv);
2333 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2337 *MARK = &PL_sv_undef;
2341 else if (gimme == G_ARRAY) {
2343 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2344 if (!SvTEMP(*MARK)) {
2345 *MARK = sv_mortalcopy(*MARK);
2346 TAINT_NOT; /* Each item is independent */
2353 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2354 PL_curpm = newpm; /* ... and pop $1 et al */
2358 return pop_return();
2363 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2365 SV *dbsv = GvSV(PL_DBsub);
2367 if (!PERLDB_SUB_NN) {
2371 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2372 || strEQ(GvNAME(gv), "END")
2373 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2374 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2375 && (gv = (GV*)*svp) ))) {
2376 /* Use GV from the stack as a fallback. */
2377 /* GV is potentially non-unique, or contain different CV. */
2378 SV *tmp = newRV((SV*)cv);
2379 sv_setsv(dbsv, tmp);
2383 gv_efullname3(dbsv, gv, Nullch);
2387 (void)SvUPGRADE(dbsv, SVt_PVIV);
2388 (void)SvIOK_on(dbsv);
2389 SAVEIV(SvIVX(dbsv));
2390 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2394 PL_curcopdb = PL_curcop;
2395 cv = GvCV(PL_DBsub);
2405 register PERL_CONTEXT *cx;
2407 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2410 DIE(aTHX_ "Not a CODE reference");
2411 switch (SvTYPE(sv)) {
2417 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2419 SP = PL_stack_base + POPMARK;
2422 if (SvGMAGICAL(sv)) {
2424 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2427 sym = SvPV(sv, n_a);
2429 DIE(aTHX_ PL_no_usym, "a subroutine");
2430 if (PL_op->op_private & HINT_STRICT_REFS)
2431 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2432 cv = get_cv(sym, TRUE);
2436 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2437 tryAMAGICunDEREF(to_cv);
2440 if (SvTYPE(cv) == SVt_PVCV)
2445 DIE(aTHX_ "Not a CODE reference");
2450 if (!(cv = GvCVu((GV*)sv)))
2451 cv = sv_2cv(sv, &stash, &gv, FALSE);
2464 if (!CvROOT(cv) && !CvXSUB(cv)) {
2468 /* anonymous or undef'd function leaves us no recourse */
2469 if (CvANON(cv) || !(gv = CvGV(cv)))
2470 DIE(aTHX_ "Undefined subroutine called");
2472 /* autoloaded stub? */
2473 if (cv != GvCV(gv)) {
2476 /* should call AUTOLOAD now? */
2479 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2486 sub_name = sv_newmortal();
2487 gv_efullname3(sub_name, gv, Nullch);
2488 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2492 DIE(aTHX_ "Not a CODE reference");
2497 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2498 cv = get_db_sub(&sv, cv);
2500 DIE(aTHX_ "No DBsub routine");
2505 * First we need to check if the sub or method requires locking.
2506 * If so, we gain a lock on the CV, the first argument or the
2507 * stash (for static methods), as appropriate. This has to be
2508 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2509 * reschedule by returning a new op.
2511 MUTEX_LOCK(CvMUTEXP(cv));
2512 if (CvFLAGS(cv) & CVf_LOCKED) {
2514 if (CvFLAGS(cv) & CVf_METHOD) {
2515 if (SP > PL_stack_base + TOPMARK)
2516 sv = *(PL_stack_base + TOPMARK + 1);
2518 AV *av = (AV*)PL_curpad[0];
2519 if (hasargs || !av || AvFILLp(av) < 0
2520 || !(sv = AvARRAY(av)[0]))
2522 MUTEX_UNLOCK(CvMUTEXP(cv));
2523 DIE(aTHX_ "no argument for locked method call");
2530 char *stashname = SvPV(sv, len);
2531 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2537 MUTEX_UNLOCK(CvMUTEXP(cv));
2538 mg = condpair_magic(sv);
2539 MUTEX_LOCK(MgMUTEXP(mg));
2540 if (MgOWNER(mg) == thr)
2541 MUTEX_UNLOCK(MgMUTEXP(mg));
2544 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2546 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2548 MUTEX_UNLOCK(MgMUTEXP(mg));
2549 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2551 MUTEX_LOCK(CvMUTEXP(cv));
2554 * Now we have permission to enter the sub, we must distinguish
2555 * four cases. (0) It's an XSUB (in which case we don't care
2556 * about ownership); (1) it's ours already (and we're recursing);
2557 * (2) it's free (but we may already be using a cached clone);
2558 * (3) another thread owns it. Case (1) is easy: we just use it.
2559 * Case (2) means we look for a clone--if we have one, use it
2560 * otherwise grab ownership of cv. Case (3) means we look for a
2561 * clone (for non-XSUBs) and have to create one if we don't
2563 * Why look for a clone in case (2) when we could just grab
2564 * ownership of cv straight away? Well, we could be recursing,
2565 * i.e. we originally tried to enter cv while another thread
2566 * owned it (hence we used a clone) but it has been freed up
2567 * and we're now recursing into it. It may or may not be "better"
2568 * to use the clone but at least CvDEPTH can be trusted.
2570 if (CvOWNER(cv) == thr || CvXSUB(cv))
2571 MUTEX_UNLOCK(CvMUTEXP(cv));
2573 /* Case (2) or (3) */
2577 * XXX Might it be better to release CvMUTEXP(cv) while we
2578 * do the hv_fetch? We might find someone has pinched it
2579 * when we look again, in which case we would be in case
2580 * (3) instead of (2) so we'd have to clone. Would the fact
2581 * that we released the mutex more quickly make up for this?
2583 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2585 /* We already have a clone to use */
2586 MUTEX_UNLOCK(CvMUTEXP(cv));
2588 DEBUG_S(PerlIO_printf(Perl_debug_log,
2589 "entersub: %p already has clone %p:%s\n",
2590 thr, cv, SvPEEK((SV*)cv)));
2593 if (CvDEPTH(cv) == 0)
2594 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2597 /* (2) => grab ownership of cv. (3) => make clone */
2601 MUTEX_UNLOCK(CvMUTEXP(cv));
2602 DEBUG_S(PerlIO_printf(Perl_debug_log,
2603 "entersub: %p grabbing %p:%s in stash %s\n",
2604 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2605 HvNAME(CvSTASH(cv)) : "(none)"));
2608 /* Make a new clone. */
2610 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2611 MUTEX_UNLOCK(CvMUTEXP(cv));
2612 DEBUG_S((PerlIO_printf(Perl_debug_log,
2613 "entersub: %p cloning %p:%s\n",
2614 thr, cv, SvPEEK((SV*)cv))));
2616 * We're creating a new clone so there's no race
2617 * between the original MUTEX_UNLOCK and the
2618 * SvREFCNT_inc since no one will be trying to undef
2619 * it out from underneath us. At least, I don't think
2622 clonecv = cv_clone(cv);
2623 SvREFCNT_dec(cv); /* finished with this */
2624 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2625 CvOWNER(clonecv) = thr;
2629 DEBUG_S(if (CvDEPTH(cv) != 0)
2630 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2632 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2635 #endif /* USE_THREADS */
2638 #ifdef PERL_XSUB_OLDSTYLE
2639 if (CvOLDSTYLE(cv)) {
2640 I32 (*fp3)(int,int,int);
2642 register I32 items = SP - MARK;
2643 /* We dont worry to copy from @_. */
2648 PL_stack_sp = mark + 1;
2649 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2650 items = (*fp3)(CvXSUBANY(cv).any_i32,
2651 MARK - PL_stack_base + 1,
2653 PL_stack_sp = PL_stack_base + items;
2656 #endif /* PERL_XSUB_OLDSTYLE */
2658 I32 markix = TOPMARK;
2663 /* Need to copy @_ to stack. Alternative may be to
2664 * switch stack to @_, and copy return values
2665 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2669 av = (AV*)PL_curpad[0];
2671 av = GvAV(PL_defgv);
2672 #endif /* USE_THREADS */
2673 items = AvFILLp(av) + 1; /* @_ is not tieable */
2676 /* Mark is at the end of the stack. */
2678 Copy(AvARRAY(av), SP + 1, items, SV*);
2683 /* We assume first XSUB in &DB::sub is the called one. */
2685 SAVEVPTR(PL_curcop);
2686 PL_curcop = PL_curcopdb;
2689 /* Do we need to open block here? XXXX */
2690 (void)(*CvXSUB(cv))(aTHXo_ cv);
2692 /* Enforce some sanity in scalar context. */
2693 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2694 if (markix > PL_stack_sp - PL_stack_base)
2695 *(PL_stack_base + markix) = &PL_sv_undef;
2697 *(PL_stack_base + markix) = *PL_stack_sp;
2698 PL_stack_sp = PL_stack_base + markix;
2706 register I32 items = SP - MARK;
2707 AV* padlist = CvPADLIST(cv);
2708 SV** svp = AvARRAY(padlist);
2709 push_return(PL_op->op_next);
2710 PUSHBLOCK(cx, CXt_SUB, MARK);
2713 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2714 * that eval'' ops within this sub know the correct lexical space.
2715 * Owing the speed considerations, we choose to search for the cv
2716 * in doeval() instead.
2718 if (CvDEPTH(cv) < 2)
2719 (void)SvREFCNT_inc(cv);
2720 else { /* save temporaries on recursion? */
2721 PERL_STACK_OVERFLOW_CHECK();
2722 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2724 AV *newpad = newAV();
2725 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2726 I32 ix = AvFILLp((AV*)svp[1]);
2727 I32 names_fill = AvFILLp((AV*)svp[0]);
2728 svp = AvARRAY(svp[0]);
2729 for ( ;ix > 0; ix--) {
2730 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2731 char *name = SvPVX(svp[ix]);
2732 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2733 || *name == '&') /* anonymous code? */
2735 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2737 else { /* our own lexical */
2739 av_store(newpad, ix, sv = (SV*)newAV());
2740 else if (*name == '%')
2741 av_store(newpad, ix, sv = (SV*)newHV());
2743 av_store(newpad, ix, sv = NEWSV(0,0));
2747 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2748 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2751 av_store(newpad, ix, sv = NEWSV(0,0));
2755 av = newAV(); /* will be @_ */
2757 av_store(newpad, 0, (SV*)av);
2758 AvFLAGS(av) = AVf_REIFY;
2759 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2760 AvFILLp(padlist) = CvDEPTH(cv);
2761 svp = AvARRAY(padlist);
2766 AV* av = (AV*)PL_curpad[0];
2768 items = AvFILLp(av) + 1;
2770 /* Mark is at the end of the stack. */
2772 Copy(AvARRAY(av), SP + 1, items, SV*);
2777 #endif /* USE_THREADS */
2778 SAVEVPTR(PL_curpad);
2779 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2782 #endif /* USE_THREADS */
2788 DEBUG_S(PerlIO_printf(Perl_debug_log,
2789 "%p entersub preparing @_\n", thr));
2791 av = (AV*)PL_curpad[0];
2793 /* @_ is normally not REAL--this should only ever
2794 * happen when DB::sub() calls things that modify @_ */
2800 cx->blk_sub.savearray = GvAV(PL_defgv);
2801 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2802 #endif /* USE_THREADS */
2803 cx->blk_sub.oldcurpad = PL_curpad;
2804 cx->blk_sub.argarray = av;
2807 if (items > AvMAX(av) + 1) {
2809 if (AvARRAY(av) != ary) {
2810 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2811 SvPVX(av) = (char*)ary;
2813 if (items > AvMAX(av) + 1) {
2814 AvMAX(av) = items - 1;
2815 Renew(ary,items,SV*);
2817 SvPVX(av) = (char*)ary;
2820 Copy(MARK,AvARRAY(av),items,SV*);
2821 AvFILLp(av) = items - 1;
2829 /* warning must come *after* we fully set up the context
2830 * stuff so that __WARN__ handlers can safely dounwind()
2833 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2834 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2835 sub_crush_depth(cv);
2837 DEBUG_S(PerlIO_printf(Perl_debug_log,
2838 "%p entersub returning %p\n", thr, CvSTART(cv)));
2840 RETURNOP(CvSTART(cv));
2845 Perl_sub_crush_depth(pTHX_ CV *cv)
2848 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2850 SV* tmpstr = sv_newmortal();
2851 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2852 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2862 IV elem = SvIV(elemsv);
2864 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2865 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2868 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2869 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2871 elem -= PL_curcop->cop_arybase;
2872 if (SvTYPE(av) != SVt_PVAV)
2874 svp = av_fetch(av, elem, lval && !defer);
2876 if (!svp || *svp == &PL_sv_undef) {
2879 DIE(aTHX_ PL_no_aelem, elem);
2880 lv = sv_newmortal();
2881 sv_upgrade(lv, SVt_PVLV);
2883 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2884 LvTARG(lv) = SvREFCNT_inc(av);
2885 LvTARGOFF(lv) = elem;
2890 if (PL_op->op_private & OPpLVAL_INTRO)
2891 save_aelem(av, elem, svp);
2892 else if (PL_op->op_private & OPpDEREF)
2893 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2895 sv = (svp ? *svp : &PL_sv_undef);
2896 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2897 sv = sv_mortalcopy(sv);
2903 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2909 Perl_croak(aTHX_ PL_no_modify);
2910 if (SvTYPE(sv) < SVt_RV)
2911 sv_upgrade(sv, SVt_RV);
2912 else if (SvTYPE(sv) >= SVt_PV) {
2913 (void)SvOOK_off(sv);
2914 Safefree(SvPVX(sv));
2915 SvLEN(sv) = SvCUR(sv) = 0;
2919 SvRV(sv) = NEWSV(355,0);
2922 SvRV(sv) = (SV*)newAV();
2925 SvRV(sv) = (SV*)newHV();
2940 if (SvTYPE(rsv) == SVt_PVCV) {
2946 SETs(method_common(sv, Null(U32*)));
2953 SV* sv = cSVOP->op_sv;
2954 U32 hash = SvUVX(sv);
2956 XPUSHs(method_common(sv, &hash));
2961 S_method_common(pTHX_ SV* meth, U32* hashp)
2972 name = SvPV(meth, namelen);
2973 sv = *(PL_stack_base + TOPMARK + 1);
2976 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2987 !(packname = SvPV(sv, packlen)) ||
2988 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2989 !(ob=(SV*)GvIO(iogv)))
2992 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2993 ? !isIDFIRST_utf8((U8*)packname)
2994 : !isIDFIRST(*packname)
2997 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2998 SvOK(sv) ? "without a package or object reference"
2999 : "on an undefined value");
3001 stash = gv_stashpvn(packname, packlen, TRUE);
3004 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3007 if (!ob || !(SvOBJECT(ob)
3008 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3011 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3015 stash = SvSTASH(ob);
3018 /* shortcut for simple names */
3020 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3022 gv = (GV*)HeVAL(he);
3023 if (isGV(gv) && GvCV(gv) &&
3024 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3025 return (SV*)GvCV(gv);
3029 gv = gv_fetchmethod(stash, name);
3036 for (p = name; *p; p++) {
3038 sep = p, leaf = p + 1;
3039 else if (*p == ':' && *(p + 1) == ':')
3040 sep = p, leaf = p + 2;
3042 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3043 packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
3044 packlen = strlen(packname);
3048 packlen = sep - name;
3050 gv = gv_fetchpv(packname, 0, SVt_PVHV);
3051 if (gv && isGV(gv)) {
3053 "Can't locate object method \"%s\" via package \"%s\"",
3058 "Can't locate object method \"%s\" via package \"%s\""
3059 " (perhaps you forgot to load \"%s\"?)",
3060 leaf, packname, packname);
3063 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3068 unset_cvowner(pTHXo_ void *cvarg)
3070 register CV* cv = (CV *) cvarg;
3072 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3073 thr, cv, SvPEEK((SV*)cv))));
3074 MUTEX_LOCK(CvMUTEXP(cv));
3075 DEBUG_S(if (CvDEPTH(cv) != 0)
3076 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3078 assert(thr == CvOWNER(cv));
3080 MUTEX_UNLOCK(CvMUTEXP(cv));
3083 #endif /* USE_THREADS */