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) /* stdout/stderr or other write fh */
1463 && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
1464 || fp == PerlIO_stderr()))
1465 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1468 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1469 && (!io || !(IoFLAGS(io) & IOf_START))) {
1470 if (type == OP_GLOB)
1471 Perl_warner(aTHX_ WARN_GLOB,
1472 "glob failed (can't start child: %s)",
1475 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1477 if (gimme == G_SCALAR) {
1478 (void)SvOK_off(TARG);
1484 if (gimme == G_SCALAR) {
1488 (void)SvUPGRADE(sv, SVt_PV);
1489 tmplen = SvLEN(sv); /* remember if already alloced */
1491 Sv_Grow(sv, 80); /* try short-buffering it */
1492 if (type == OP_RCATLINE)
1498 sv = sv_2mortal(NEWSV(57, 80));
1502 /* This should not be marked tainted if the fp is marked clean */
1503 #define MAYBE_TAINT_LINE(io, sv) \
1504 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1509 /* delay EOF state for a snarfed empty file */
1510 #define SNARF_EOF(gimme,rs,io,sv) \
1511 (gimme != G_SCALAR || SvCUR(sv) \
1512 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1515 if (!sv_gets(sv, fp, offset)
1516 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1518 PerlIO_clearerr(fp);
1519 if (IoFLAGS(io) & IOf_ARGV) {
1520 fp = nextargv(PL_last_in_gv);
1523 (void)do_close(PL_last_in_gv, FALSE);
1525 else if (type == OP_GLOB) {
1526 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1527 Perl_warner(aTHX_ WARN_GLOB,
1528 "glob failed (child exited with status %d%s)",
1529 (int)(STATUS_CURRENT >> 8),
1530 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1533 if (gimme == G_SCALAR) {
1534 (void)SvOK_off(TARG);
1537 MAYBE_TAINT_LINE(io, sv);
1540 MAYBE_TAINT_LINE(io, sv);
1542 IoFLAGS(io) |= IOf_NOLINE;
1545 if (type == OP_GLOB) {
1548 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1549 tmps = SvEND(sv) - 1;
1550 if (*tmps == *SvPVX(PL_rs)) {
1555 for (tmps = SvPVX(sv); *tmps; tmps++)
1556 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1557 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1559 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1560 (void)POPs; /* Unmatched wildcard? Chuck it... */
1564 if (gimme == G_ARRAY) {
1565 if (SvLEN(sv) - SvCUR(sv) > 20) {
1566 SvLEN_set(sv, SvCUR(sv)+1);
1567 Renew(SvPVX(sv), SvLEN(sv), char);
1569 sv = sv_2mortal(NEWSV(58, 80));
1572 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1573 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1577 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1578 Renew(SvPVX(sv), SvLEN(sv), char);
1587 register PERL_CONTEXT *cx;
1588 I32 gimme = OP_GIMME(PL_op, -1);
1591 if (cxstack_ix >= 0)
1592 gimme = cxstack[cxstack_ix].blk_gimme;
1600 PUSHBLOCK(cx, CXt_BLOCK, SP);
1612 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1613 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1615 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1618 if (SvTYPE(hv) == SVt_PVHV) {
1619 if (PL_op->op_private & OPpLVAL_INTRO)
1620 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1621 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1622 svp = he ? &HeVAL(he) : 0;
1624 else if (SvTYPE(hv) == SVt_PVAV) {
1625 if (PL_op->op_private & OPpLVAL_INTRO)
1626 DIE(aTHX_ "Can't localize pseudo-hash element");
1627 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1633 if (!svp || *svp == &PL_sv_undef) {
1638 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1640 lv = sv_newmortal();
1641 sv_upgrade(lv, SVt_PVLV);
1643 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1644 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1645 LvTARG(lv) = SvREFCNT_inc(hv);
1650 if (PL_op->op_private & OPpLVAL_INTRO) {
1651 if (HvNAME(hv) && isGV(*svp))
1652 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1656 char *key = SvPV(keysv, keylen);
1657 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1659 save_helem(hv, keysv, svp);
1662 else if (PL_op->op_private & OPpDEREF)
1663 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1665 sv = (svp ? *svp : &PL_sv_undef);
1666 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1667 * Pushing the magical RHS on to the stack is useless, since
1668 * that magic is soon destined to be misled by the local(),
1669 * and thus the later pp_sassign() will fail to mg_get() the
1670 * old value. This should also cure problems with delayed
1671 * mg_get()s. GSAR 98-07-03 */
1672 if (!lval && SvGMAGICAL(sv))
1673 sv = sv_mortalcopy(sv);
1681 register PERL_CONTEXT *cx;
1687 if (PL_op->op_flags & OPf_SPECIAL) {
1688 cx = &cxstack[cxstack_ix];
1689 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1694 gimme = OP_GIMME(PL_op, -1);
1696 if (cxstack_ix >= 0)
1697 gimme = cxstack[cxstack_ix].blk_gimme;
1703 if (gimme == G_VOID)
1705 else if (gimme == G_SCALAR) {
1708 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1711 *MARK = sv_mortalcopy(TOPs);
1714 *MARK = &PL_sv_undef;
1718 else if (gimme == G_ARRAY) {
1719 /* in case LEAVE wipes old return values */
1720 for (mark = newsp + 1; mark <= SP; mark++) {
1721 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1722 *mark = sv_mortalcopy(*mark);
1723 TAINT_NOT; /* Each item is independent */
1727 PL_curpm = newpm; /* Don't pop $1 et al till now */
1737 register PERL_CONTEXT *cx;
1743 cx = &cxstack[cxstack_ix];
1744 if (CxTYPE(cx) != CXt_LOOP)
1745 DIE(aTHX_ "panic: pp_iter");
1747 itersvp = CxITERVAR(cx);
1748 av = cx->blk_loop.iterary;
1749 if (SvTYPE(av) != SVt_PVAV) {
1750 /* iterate ($min .. $max) */
1751 if (cx->blk_loop.iterlval) {
1752 /* string increment */
1753 register SV* cur = cx->blk_loop.iterlval;
1755 char *max = SvPV((SV*)av, maxlen);
1756 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1757 #ifndef USE_THREADS /* don't risk potential race */
1758 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1759 /* safe to reuse old SV */
1760 sv_setsv(*itersvp, cur);
1765 /* we need a fresh SV every time so that loop body sees a
1766 * completely new SV for closures/references to work as
1768 SvREFCNT_dec(*itersvp);
1769 *itersvp = newSVsv(cur);
1771 if (strEQ(SvPVX(cur), max))
1772 sv_setiv(cur, 0); /* terminate next time */
1779 /* integer increment */
1780 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1783 #ifndef USE_THREADS /* don't risk potential race */
1784 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1785 /* safe to reuse old SV */
1786 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1791 /* we need a fresh SV every time so that loop body sees a
1792 * completely new SV for closures/references to work as they
1794 SvREFCNT_dec(*itersvp);
1795 *itersvp = newSViv(cx->blk_loop.iterix++);
1801 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1804 SvREFCNT_dec(*itersvp);
1806 if ((sv = SvMAGICAL(av)
1807 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1808 : AvARRAY(av)[++cx->blk_loop.iterix]))
1812 if (av != PL_curstack && SvIMMORTAL(sv)) {
1813 SV *lv = cx->blk_loop.iterlval;
1814 if (lv && SvREFCNT(lv) > 1) {
1819 SvREFCNT_dec(LvTARG(lv));
1821 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1822 sv_upgrade(lv, SVt_PVLV);
1824 sv_magic(lv, Nullsv, 'y', Nullch, 0);
1826 LvTARG(lv) = SvREFCNT_inc(av);
1827 LvTARGOFF(lv) = cx->blk_loop.iterix;
1828 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1832 *itersvp = SvREFCNT_inc(sv);
1839 register PMOP *pm = cPMOP;
1855 register REGEXP *rx = pm->op_pmregexp;
1857 int force_on_match = 0;
1858 I32 oldsave = PL_savestack_ix;
1862 /* known replacement string? */
1863 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1864 if (PL_op->op_flags & OPf_STACKED)
1871 do_utf8 = DO_UTF8(PL_reg_sv);
1872 if (SvFAKE(TARG) && SvREADONLY(TARG))
1873 sv_force_normal(TARG);
1874 if (SvREADONLY(TARG)
1875 || (SvTYPE(TARG) > SVt_PVLV
1876 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1877 DIE(aTHX_ PL_no_modify);
1880 s = SvPV(TARG, len);
1881 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1883 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1884 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1891 DIE(aTHX_ "panic: pp_subst");
1894 slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1895 maxiters = 2 * slen + 10; /* We can match twice at each
1896 position, once with zero-length,
1897 second time with non-zero. */
1899 if (!rx->prelen && PL_curpm) {
1901 rx = pm->op_pmregexp;
1903 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1904 ? REXEC_COPY_STR : 0;
1906 r_flags |= REXEC_SCREAM;
1907 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1908 SAVEINT(PL_multiline);
1909 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1912 if (rx->reganch & RE_USE_INTUIT) {
1913 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1917 /* How to do it in subst? */
1918 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1920 && ((rx->reganch & ROPT_NOSCAN)
1921 || !((rx->reganch & RE_INTUIT_TAIL)
1922 && (r_flags & REXEC_SCREAM))))
1927 /* only replace once? */
1928 once = !(rpm->op_pmflags & PMf_GLOBAL);
1930 /* known replacement string? */
1931 c = dstr ? SvPV(dstr, clen) : Nullch;
1933 /* can do inplace substitution? */
1934 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1935 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1936 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1937 r_flags | REXEC_CHECKED))
1941 LEAVE_SCOPE(oldsave);
1944 if (force_on_match) {
1946 s = SvPV_force(TARG, len);
1951 SvSCREAM_off(TARG); /* disable possible screamer */
1953 rxtainted |= RX_MATCH_TAINTED(rx);
1954 m = orig + rx->startp[0];
1955 d = orig + rx->endp[0];
1957 if (m - s > strend - d) { /* faster to shorten from end */
1959 Copy(c, m, clen, char);
1964 Move(d, m, i, char);
1968 SvCUR_set(TARG, m - s);
1971 else if ((i = m - s)) { /* faster from front */
1979 Copy(c, m, clen, char);
1984 Copy(c, d, clen, char);
1989 TAINT_IF(rxtainted & 1);
1995 if (iters++ > maxiters)
1996 DIE(aTHX_ "Substitution loop");
1997 rxtainted |= RX_MATCH_TAINTED(rx);
1998 m = rx->startp[0] + orig;
2002 Move(s, d, i, char);
2006 Copy(c, d, clen, char);
2009 s = rx->endp[0] + orig;
2010 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2012 /* don't match same null twice */
2013 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2016 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2017 Move(s, d, i+1, char); /* include the NUL */
2019 TAINT_IF(rxtainted & 1);
2021 PUSHs(sv_2mortal(newSViv((I32)iters)));
2023 (void)SvPOK_only_UTF8(TARG);
2024 TAINT_IF(rxtainted);
2025 if (SvSMAGICAL(TARG)) {
2031 LEAVE_SCOPE(oldsave);
2035 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2036 r_flags | REXEC_CHECKED))
2040 if (force_on_match) {
2042 s = SvPV_force(TARG, len);
2045 rxtainted |= RX_MATCH_TAINTED(rx);
2046 dstr = NEWSV(25, len);
2047 sv_setpvn(dstr, m, s-m);
2052 register PERL_CONTEXT *cx;
2055 RETURNOP(cPMOP->op_pmreplroot);
2057 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2059 if (iters++ > maxiters)
2060 DIE(aTHX_ "Substitution loop");
2061 rxtainted |= RX_MATCH_TAINTED(rx);
2062 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2067 strend = s + (strend - m);
2069 m = rx->startp[0] + orig;
2070 sv_catpvn(dstr, s, m-s);
2071 s = rx->endp[0] + orig;
2073 sv_catpvn(dstr, c, clen);
2076 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2077 TARG, NULL, r_flags));
2078 sv_catpvn(dstr, s, strend - s);
2080 (void)SvOOK_off(TARG);
2081 Safefree(SvPVX(TARG));
2082 SvPVX(TARG) = SvPVX(dstr);
2083 SvCUR_set(TARG, SvCUR(dstr));
2084 SvLEN_set(TARG, SvLEN(dstr));
2085 isutf8 = DO_UTF8(dstr);
2089 TAINT_IF(rxtainted & 1);
2091 PUSHs(sv_2mortal(newSViv((I32)iters)));
2093 (void)SvPOK_only(TARG);
2096 TAINT_IF(rxtainted);
2099 LEAVE_SCOPE(oldsave);
2108 LEAVE_SCOPE(oldsave);
2117 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2118 ++*PL_markstack_ptr;
2119 LEAVE; /* exit inner scope */
2122 if (PL_stack_base + *PL_markstack_ptr > SP) {
2124 I32 gimme = GIMME_V;
2126 LEAVE; /* exit outer scope */
2127 (void)POPMARK; /* pop src */
2128 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2129 (void)POPMARK; /* pop dst */
2130 SP = PL_stack_base + POPMARK; /* pop original mark */
2131 if (gimme == G_SCALAR) {
2135 else if (gimme == G_ARRAY)
2142 ENTER; /* enter inner scope */
2145 src = PL_stack_base[*PL_markstack_ptr];
2149 RETURNOP(cLOGOP->op_other);
2160 register PERL_CONTEXT *cx;
2166 if (gimme == G_SCALAR) {
2169 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2171 *MARK = SvREFCNT_inc(TOPs);
2176 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2178 *MARK = sv_mortalcopy(sv);
2183 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2187 *MARK = &PL_sv_undef;
2191 else if (gimme == G_ARRAY) {
2192 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2193 if (!SvTEMP(*MARK)) {
2194 *MARK = sv_mortalcopy(*MARK);
2195 TAINT_NOT; /* Each item is independent */
2201 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2202 PL_curpm = newpm; /* ... and pop $1 et al */
2206 return pop_return();
2209 /* This duplicates the above code because the above code must not
2210 * get any slower by more conditions */
2218 register PERL_CONTEXT *cx;
2225 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2226 /* We are an argument to a function or grep().
2227 * This kind of lvalueness was legal before lvalue
2228 * subroutines too, so be backward compatible:
2229 * cannot report errors. */
2231 /* Scalar context *is* possible, on the LHS of -> only,
2232 * as in f()->meth(). But this is not an lvalue. */
2233 if (gimme == G_SCALAR)
2235 if (gimme == G_ARRAY) {
2236 if (!CvLVALUE(cx->blk_sub.cv))
2237 goto temporise_array;
2238 EXTEND_MORTAL(SP - newsp);
2239 for (mark = newsp + 1; mark <= SP; mark++) {
2242 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2243 *mark = sv_mortalcopy(*mark);
2245 /* Can be a localized value subject to deletion. */
2246 PL_tmps_stack[++PL_tmps_ix] = *mark;
2247 (void)SvREFCNT_inc(*mark);
2252 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2253 /* Here we go for robustness, not for speed, so we change all
2254 * the refcounts so the caller gets a live guy. Cannot set
2255 * TEMP, so sv_2mortal is out of question. */
2256 if (!CvLVALUE(cx->blk_sub.cv)) {
2261 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2263 if (gimme == G_SCALAR) {
2267 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2272 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2273 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2275 else { /* Can be a localized value
2276 * subject to deletion. */
2277 PL_tmps_stack[++PL_tmps_ix] = *mark;
2278 (void)SvREFCNT_inc(*mark);
2281 else { /* Should not happen? */
2286 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2287 (MARK > SP ? "Empty array" : "Array"));
2291 else if (gimme == G_ARRAY) {
2292 EXTEND_MORTAL(SP - newsp);
2293 for (mark = newsp + 1; mark <= SP; mark++) {
2294 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2295 /* Might be flattened array after $#array = */
2301 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2302 (*mark != &PL_sv_undef)
2304 ? "a readonly value" : "a temporary")
2305 : "an uninitialized value");
2308 /* Can be a localized value subject to deletion. */
2309 PL_tmps_stack[++PL_tmps_ix] = *mark;
2310 (void)SvREFCNT_inc(*mark);
2316 if (gimme == G_SCALAR) {
2320 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2322 *MARK = SvREFCNT_inc(TOPs);
2327 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2329 *MARK = sv_mortalcopy(sv);
2334 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2338 *MARK = &PL_sv_undef;
2342 else if (gimme == G_ARRAY) {
2344 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2345 if (!SvTEMP(*MARK)) {
2346 *MARK = sv_mortalcopy(*MARK);
2347 TAINT_NOT; /* Each item is independent */
2354 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2355 PL_curpm = newpm; /* ... and pop $1 et al */
2359 return pop_return();
2364 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2366 SV *dbsv = GvSV(PL_DBsub);
2368 if (!PERLDB_SUB_NN) {
2372 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2373 || strEQ(GvNAME(gv), "END")
2374 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2375 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2376 && (gv = (GV*)*svp) ))) {
2377 /* Use GV from the stack as a fallback. */
2378 /* GV is potentially non-unique, or contain different CV. */
2379 SV *tmp = newRV((SV*)cv);
2380 sv_setsv(dbsv, tmp);
2384 gv_efullname3(dbsv, gv, Nullch);
2388 (void)SvUPGRADE(dbsv, SVt_PVIV);
2389 (void)SvIOK_on(dbsv);
2390 SAVEIV(SvIVX(dbsv));
2391 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2395 PL_curcopdb = PL_curcop;
2396 cv = GvCV(PL_DBsub);
2406 register PERL_CONTEXT *cx;
2408 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2411 DIE(aTHX_ "Not a CODE reference");
2412 switch (SvTYPE(sv)) {
2418 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2420 SP = PL_stack_base + POPMARK;
2423 if (SvGMAGICAL(sv)) {
2425 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2428 sym = SvPV(sv, n_a);
2430 DIE(aTHX_ PL_no_usym, "a subroutine");
2431 if (PL_op->op_private & HINT_STRICT_REFS)
2432 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2433 cv = get_cv(sym, TRUE);
2437 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2438 tryAMAGICunDEREF(to_cv);
2441 if (SvTYPE(cv) == SVt_PVCV)
2446 DIE(aTHX_ "Not a CODE reference");
2451 if (!(cv = GvCVu((GV*)sv)))
2452 cv = sv_2cv(sv, &stash, &gv, FALSE);
2465 if (!CvROOT(cv) && !CvXSUB(cv)) {
2469 /* anonymous or undef'd function leaves us no recourse */
2470 if (CvANON(cv) || !(gv = CvGV(cv)))
2471 DIE(aTHX_ "Undefined subroutine called");
2473 /* autoloaded stub? */
2474 if (cv != GvCV(gv)) {
2477 /* should call AUTOLOAD now? */
2480 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2487 sub_name = sv_newmortal();
2488 gv_efullname3(sub_name, gv, Nullch);
2489 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2493 DIE(aTHX_ "Not a CODE reference");
2498 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2499 cv = get_db_sub(&sv, cv);
2501 DIE(aTHX_ "No DBsub routine");
2506 * First we need to check if the sub or method requires locking.
2507 * If so, we gain a lock on the CV, the first argument or the
2508 * stash (for static methods), as appropriate. This has to be
2509 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2510 * reschedule by returning a new op.
2512 MUTEX_LOCK(CvMUTEXP(cv));
2513 if (CvFLAGS(cv) & CVf_LOCKED) {
2515 if (CvFLAGS(cv) & CVf_METHOD) {
2516 if (SP > PL_stack_base + TOPMARK)
2517 sv = *(PL_stack_base + TOPMARK + 1);
2519 AV *av = (AV*)PL_curpad[0];
2520 if (hasargs || !av || AvFILLp(av) < 0
2521 || !(sv = AvARRAY(av)[0]))
2523 MUTEX_UNLOCK(CvMUTEXP(cv));
2524 DIE(aTHX_ "no argument for locked method call");
2531 char *stashname = SvPV(sv, len);
2532 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2538 MUTEX_UNLOCK(CvMUTEXP(cv));
2539 mg = condpair_magic(sv);
2540 MUTEX_LOCK(MgMUTEXP(mg));
2541 if (MgOWNER(mg) == thr)
2542 MUTEX_UNLOCK(MgMUTEXP(mg));
2545 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2547 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2549 MUTEX_UNLOCK(MgMUTEXP(mg));
2550 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2552 MUTEX_LOCK(CvMUTEXP(cv));
2555 * Now we have permission to enter the sub, we must distinguish
2556 * four cases. (0) It's an XSUB (in which case we don't care
2557 * about ownership); (1) it's ours already (and we're recursing);
2558 * (2) it's free (but we may already be using a cached clone);
2559 * (3) another thread owns it. Case (1) is easy: we just use it.
2560 * Case (2) means we look for a clone--if we have one, use it
2561 * otherwise grab ownership of cv. Case (3) means we look for a
2562 * clone (for non-XSUBs) and have to create one if we don't
2564 * Why look for a clone in case (2) when we could just grab
2565 * ownership of cv straight away? Well, we could be recursing,
2566 * i.e. we originally tried to enter cv while another thread
2567 * owned it (hence we used a clone) but it has been freed up
2568 * and we're now recursing into it. It may or may not be "better"
2569 * to use the clone but at least CvDEPTH can be trusted.
2571 if (CvOWNER(cv) == thr || CvXSUB(cv))
2572 MUTEX_UNLOCK(CvMUTEXP(cv));
2574 /* Case (2) or (3) */
2578 * XXX Might it be better to release CvMUTEXP(cv) while we
2579 * do the hv_fetch? We might find someone has pinched it
2580 * when we look again, in which case we would be in case
2581 * (3) instead of (2) so we'd have to clone. Would the fact
2582 * that we released the mutex more quickly make up for this?
2584 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2586 /* We already have a clone to use */
2587 MUTEX_UNLOCK(CvMUTEXP(cv));
2589 DEBUG_S(PerlIO_printf(Perl_debug_log,
2590 "entersub: %p already has clone %p:%s\n",
2591 thr, cv, SvPEEK((SV*)cv)));
2594 if (CvDEPTH(cv) == 0)
2595 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2598 /* (2) => grab ownership of cv. (3) => make clone */
2602 MUTEX_UNLOCK(CvMUTEXP(cv));
2603 DEBUG_S(PerlIO_printf(Perl_debug_log,
2604 "entersub: %p grabbing %p:%s in stash %s\n",
2605 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2606 HvNAME(CvSTASH(cv)) : "(none)"));
2609 /* Make a new clone. */
2611 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2612 MUTEX_UNLOCK(CvMUTEXP(cv));
2613 DEBUG_S((PerlIO_printf(Perl_debug_log,
2614 "entersub: %p cloning %p:%s\n",
2615 thr, cv, SvPEEK((SV*)cv))));
2617 * We're creating a new clone so there's no race
2618 * between the original MUTEX_UNLOCK and the
2619 * SvREFCNT_inc since no one will be trying to undef
2620 * it out from underneath us. At least, I don't think
2623 clonecv = cv_clone(cv);
2624 SvREFCNT_dec(cv); /* finished with this */
2625 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2626 CvOWNER(clonecv) = thr;
2630 DEBUG_S(if (CvDEPTH(cv) != 0)
2631 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2633 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2636 #endif /* USE_THREADS */
2639 #ifdef PERL_XSUB_OLDSTYLE
2640 if (CvOLDSTYLE(cv)) {
2641 I32 (*fp3)(int,int,int);
2643 register I32 items = SP - MARK;
2644 /* We dont worry to copy from @_. */
2649 PL_stack_sp = mark + 1;
2650 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2651 items = (*fp3)(CvXSUBANY(cv).any_i32,
2652 MARK - PL_stack_base + 1,
2654 PL_stack_sp = PL_stack_base + items;
2657 #endif /* PERL_XSUB_OLDSTYLE */
2659 I32 markix = TOPMARK;
2664 /* Need to copy @_ to stack. Alternative may be to
2665 * switch stack to @_, and copy return values
2666 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2670 av = (AV*)PL_curpad[0];
2672 av = GvAV(PL_defgv);
2673 #endif /* USE_THREADS */
2674 items = AvFILLp(av) + 1; /* @_ is not tieable */
2677 /* Mark is at the end of the stack. */
2679 Copy(AvARRAY(av), SP + 1, items, SV*);
2684 /* We assume first XSUB in &DB::sub is the called one. */
2686 SAVEVPTR(PL_curcop);
2687 PL_curcop = PL_curcopdb;
2690 /* Do we need to open block here? XXXX */
2691 (void)(*CvXSUB(cv))(aTHXo_ cv);
2693 /* Enforce some sanity in scalar context. */
2694 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2695 if (markix > PL_stack_sp - PL_stack_base)
2696 *(PL_stack_base + markix) = &PL_sv_undef;
2698 *(PL_stack_base + markix) = *PL_stack_sp;
2699 PL_stack_sp = PL_stack_base + markix;
2707 register I32 items = SP - MARK;
2708 AV* padlist = CvPADLIST(cv);
2709 SV** svp = AvARRAY(padlist);
2710 push_return(PL_op->op_next);
2711 PUSHBLOCK(cx, CXt_SUB, MARK);
2714 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2715 * that eval'' ops within this sub know the correct lexical space.
2716 * Owing the speed considerations, we choose to search for the cv
2717 * in doeval() instead.
2719 if (CvDEPTH(cv) < 2)
2720 (void)SvREFCNT_inc(cv);
2721 else { /* save temporaries on recursion? */
2722 PERL_STACK_OVERFLOW_CHECK();
2723 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2725 AV *newpad = newAV();
2726 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2727 I32 ix = AvFILLp((AV*)svp[1]);
2728 I32 names_fill = AvFILLp((AV*)svp[0]);
2729 svp = AvARRAY(svp[0]);
2730 for ( ;ix > 0; ix--) {
2731 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2732 char *name = SvPVX(svp[ix]);
2733 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2734 || *name == '&') /* anonymous code? */
2736 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2738 else { /* our own lexical */
2740 av_store(newpad, ix, sv = (SV*)newAV());
2741 else if (*name == '%')
2742 av_store(newpad, ix, sv = (SV*)newHV());
2744 av_store(newpad, ix, sv = NEWSV(0,0));
2748 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2749 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2752 av_store(newpad, ix, sv = NEWSV(0,0));
2756 av = newAV(); /* will be @_ */
2758 av_store(newpad, 0, (SV*)av);
2759 AvFLAGS(av) = AVf_REIFY;
2760 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2761 AvFILLp(padlist) = CvDEPTH(cv);
2762 svp = AvARRAY(padlist);
2767 AV* av = (AV*)PL_curpad[0];
2769 items = AvFILLp(av) + 1;
2771 /* Mark is at the end of the stack. */
2773 Copy(AvARRAY(av), SP + 1, items, SV*);
2778 #endif /* USE_THREADS */
2779 SAVEVPTR(PL_curpad);
2780 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2783 #endif /* USE_THREADS */
2789 DEBUG_S(PerlIO_printf(Perl_debug_log,
2790 "%p entersub preparing @_\n", thr));
2792 av = (AV*)PL_curpad[0];
2794 /* @_ is normally not REAL--this should only ever
2795 * happen when DB::sub() calls things that modify @_ */
2801 cx->blk_sub.savearray = GvAV(PL_defgv);
2802 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2803 #endif /* USE_THREADS */
2804 cx->blk_sub.oldcurpad = PL_curpad;
2805 cx->blk_sub.argarray = av;
2808 if (items > AvMAX(av) + 1) {
2810 if (AvARRAY(av) != ary) {
2811 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2812 SvPVX(av) = (char*)ary;
2814 if (items > AvMAX(av) + 1) {
2815 AvMAX(av) = items - 1;
2816 Renew(ary,items,SV*);
2818 SvPVX(av) = (char*)ary;
2821 Copy(MARK,AvARRAY(av),items,SV*);
2822 AvFILLp(av) = items - 1;
2830 /* warning must come *after* we fully set up the context
2831 * stuff so that __WARN__ handlers can safely dounwind()
2834 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2835 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2836 sub_crush_depth(cv);
2838 DEBUG_S(PerlIO_printf(Perl_debug_log,
2839 "%p entersub returning %p\n", thr, CvSTART(cv)));
2841 RETURNOP(CvSTART(cv));
2846 Perl_sub_crush_depth(pTHX_ CV *cv)
2849 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2851 SV* tmpstr = sv_newmortal();
2852 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2853 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2863 IV elem = SvIV(elemsv);
2865 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2866 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2869 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2870 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2872 elem -= PL_curcop->cop_arybase;
2873 if (SvTYPE(av) != SVt_PVAV)
2875 svp = av_fetch(av, elem, lval && !defer);
2877 if (!svp || *svp == &PL_sv_undef) {
2880 DIE(aTHX_ PL_no_aelem, elem);
2881 lv = sv_newmortal();
2882 sv_upgrade(lv, SVt_PVLV);
2884 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2885 LvTARG(lv) = SvREFCNT_inc(av);
2886 LvTARGOFF(lv) = elem;
2891 if (PL_op->op_private & OPpLVAL_INTRO)
2892 save_aelem(av, elem, svp);
2893 else if (PL_op->op_private & OPpDEREF)
2894 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2896 sv = (svp ? *svp : &PL_sv_undef);
2897 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2898 sv = sv_mortalcopy(sv);
2904 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2910 Perl_croak(aTHX_ PL_no_modify);
2911 if (SvTYPE(sv) < SVt_RV)
2912 sv_upgrade(sv, SVt_RV);
2913 else if (SvTYPE(sv) >= SVt_PV) {
2914 (void)SvOOK_off(sv);
2915 Safefree(SvPVX(sv));
2916 SvLEN(sv) = SvCUR(sv) = 0;
2920 SvRV(sv) = NEWSV(355,0);
2923 SvRV(sv) = (SV*)newAV();
2926 SvRV(sv) = (SV*)newHV();
2941 if (SvTYPE(rsv) == SVt_PVCV) {
2947 SETs(method_common(sv, Null(U32*)));
2954 SV* sv = cSVOP->op_sv;
2955 U32 hash = SvUVX(sv);
2957 XPUSHs(method_common(sv, &hash));
2962 S_method_common(pTHX_ SV* meth, U32* hashp)
2973 name = SvPV(meth, namelen);
2974 sv = *(PL_stack_base + TOPMARK + 1);
2977 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2988 !(packname = SvPV(sv, packlen)) ||
2989 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2990 !(ob=(SV*)GvIO(iogv)))
2993 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2994 ? !isIDFIRST_utf8((U8*)packname)
2995 : !isIDFIRST(*packname)
2998 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2999 SvOK(sv) ? "without a package or object reference"
3000 : "on an undefined value");
3002 stash = gv_stashpvn(packname, packlen, TRUE);
3005 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3008 if (!ob || !(SvOBJECT(ob)
3009 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3012 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3016 stash = SvSTASH(ob);
3019 /* shortcut for simple names */
3021 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3023 gv = (GV*)HeVAL(he);
3024 if (isGV(gv) && GvCV(gv) &&
3025 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3026 return (SV*)GvCV(gv);
3030 gv = gv_fetchmethod(stash, name);
3037 for (p = name; *p; p++) {
3039 sep = p, leaf = p + 1;
3040 else if (*p == ':' && *(p + 1) == ':')
3041 sep = p, leaf = p + 2;
3043 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3044 packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
3045 packlen = strlen(packname);
3049 packlen = sep - name;
3051 gv = gv_fetchpv(packname, 0, SVt_PVHV);
3052 if (gv && isGV(gv)) {
3054 "Can't locate object method \"%s\" via package \"%s\"",
3059 "Can't locate object method \"%s\" via package \"%s\""
3060 " (perhaps you forgot to load \"%s\"?)",
3061 leaf, packname, packname);
3064 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3069 unset_cvowner(pTHXo_ void *cvarg)
3071 register CV* cv = (CV *) cvarg;
3073 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3074 thr, cv, SvPEEK((SV*)cv))));
3075 MUTEX_LOCK(CvMUTEXP(cv));
3076 DEBUG_S(if (CvDEPTH(cv) != 0)
3077 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3079 assert(thr == CvOWNER(cv));
3081 MUTEX_UNLOCK(CvMUTEXP(cv));
3084 #endif /* USE_THREADS */