3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
14 * Awake! Awake! Fear, Fire, Foes! Awake!
19 #define PERL_IN_PP_HOT_C
25 static void unset_cvowner(pTHXo_ void *cvarg);
26 #endif /* USE_THREADS */
37 PL_curcop = (COP*)PL_op;
38 TAINT_NOT; /* Each statement is presumed innocent */
39 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
48 if (PL_op->op_private & OPpLVAL_INTRO)
49 PUSHs(save_scalar(cGVOP_gv));
51 PUSHs(GvSV(cGVOP_gv));
62 PL_curcop = (COP*)PL_op;
68 PUSHMARK(PL_stack_sp);
78 sv_setpvn(TARG,s,len);
90 XPUSHs((SV*)cGVOP_gv);
101 RETURNOP(cLOGOP->op_other);
109 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
111 temp = left; left = right; right = temp;
113 if (PL_tainting && PL_tainted && !SvTAINTED(left))
115 SvSetMagicSV(right, left);
124 RETURNOP(cLOGOP->op_other);
126 RETURNOP(cLOGOP->op_next);
132 TAINT_NOT; /* Each statement is presumed innocent */
133 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
135 oldsave = PL_scopestack[PL_scopestack_ix - 1];
136 LEAVE_SCOPE(oldsave);
142 djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
147 if (SvGMAGICAL(left))
149 if (TARG == right && SvGMAGICAL(right))
152 if (TARG == right && left != right)
153 /* Clone since otherwise we cannot prepend. */
154 rcopy = sv_2mortal(newSVsv(right));
157 sv_setsv(TARG, left);
161 /* $right = $right . $right; */
163 char *rpv = SvPV(right, rlen);
165 sv_catpvn(TARG, rpv, rlen);
167 else /* $right = $left . $right; */
168 sv_catsv(TARG, rcopy);
171 if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
173 /* $other = $left . $right; */
174 /* $left = $left . $right; */
175 sv_catsv(TARG, right);
178 #if defined(PERL_Y2KWARN)
179 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
181 char *s = SvPV(TARG,n);
182 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
183 && (n == 2 || !isDIGIT(s[n-3])))
185 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
186 "about to append an integer to '19'");
200 if (PL_op->op_flags & OPf_MOD) {
201 if (PL_op->op_private & OPpLVAL_INTRO)
202 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
203 else if (PL_op->op_private & OPpDEREF) {
205 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
214 tryAMAGICunTARGET(iter, 0);
215 PL_last_in_gv = (GV*)(*PL_stack_sp--);
216 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
217 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
218 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
221 XPUSHs((SV*)PL_last_in_gv);
224 PL_last_in_gv = (GV*)(*PL_stack_sp--);
227 return do_readline();
232 djSP; tryAMAGICbinSET(eq,0);
233 #ifdef PERL_PRESERVE_IVUV
236 /* Unless the left argument is integer in range we are going to have to
237 use NV maths. Hence only attempt to coerce the right argument if
238 we know the left is integer. */
241 bool auvok = SvUOK(TOPm1s);
242 bool buvok = SvUOK(TOPs);
244 if (!auvok && !buvok) { /* ## IV == IV ## */
245 IV aiv = SvIVX(TOPm1s);
246 IV biv = SvIVX(TOPs);
249 SETs(boolSV(aiv == biv));
252 if (auvok && buvok) { /* ## UV == UV ## */
253 UV auv = SvUVX(TOPm1s);
254 UV buv = SvUVX(TOPs);
257 SETs(boolSV(auv == buv));
260 { /* ## Mixed IV,UV ## */
264 /* == is commutative so swap if needed (save code) */
266 /* swap. top of stack (b) is the iv */
270 /* As (a) is a UV, it's >0, so it cannot be == */
279 /* As (b) is a UV, it's >0, so it cannot be == */
283 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
285 /* we know iv is >= 0 */
286 if (uv > (UV) IV_MAX) {
290 SETs(boolSV((UV)iv == uv));
298 SETs(boolSV(TOPn == value));
306 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
307 DIE(aTHX_ PL_no_modify);
308 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
309 SvIVX(TOPs) != IV_MAX)
312 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
314 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
327 RETURNOP(cLOGOP->op_other);
333 djSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
334 useleft = USE_LEFT(TOPm1s);
335 #ifdef PERL_PRESERVE_IVUV
336 /* We must see if we can perform the addition with integers if possible,
337 as the integer code detects overflow while the NV code doesn't.
338 If either argument hasn't had a numeric conversion yet attempt to get
339 the IV. It's important to do this now, rather than just assuming that
340 it's not IOK as a PV of "9223372036854775806" may not take well to NV
341 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
342 integer in case the second argument is IV=9223372036854775806
343 We can (now) rely on sv_2iv to do the right thing, only setting the
344 public IOK flag if the value in the NV (or PV) slot is truly integer.
346 A side effect is that this also aggressively prefers integer maths over
347 fp maths for integer values. */
350 /* Unless the left argument is integer in range we are going to have to
351 use NV maths. Hence only attempt to coerce the right argument if
352 we know the left is integer. */
354 /* left operand is undef, treat as zero. + 0 is identity. */
356 dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
365 /* Left operand is defined, so is it IV? */
368 bool auvok = SvUOK(TOPm1s);
369 bool buvok = SvUOK(TOPs);
371 if (!auvok && !buvok) { /* ## IV + IV ## */
372 IV aiv = SvIVX(TOPm1s);
373 IV biv = SvIVX(TOPs);
374 IV result = aiv + biv;
376 if (biv >= 0 ? (result >= aiv) : (result < aiv)) {
381 if (biv >=0 && aiv >= 0) {
382 UV result = (UV)aiv + (UV)biv;
383 /* UV + UV can only get bigger... */
384 if (result >= (UV) aiv) {
390 /* Overflow, drop through to NVs (beyond next if () else ) */
391 } else if (auvok && buvok) { /* ## UV + UV ## */
392 UV auv = SvUVX(TOPm1s);
393 UV buv = SvUVX(TOPs);
394 UV result = auv + buv;
400 /* Overflow, drop through to NVs (beyond next if () else ) */
401 } else { /* ## Mixed IV,UV ## */
405 /* addition is commutative so swap if needed (save code) */
415 UV result = (UV)aiv + buv;
421 } else if (buv > (UV) IV_MAX) {
422 /* assuming 2s complement means that IV_MIN == -IV_MIN,
423 and (UV)-IV_MIN *is* the value -IV_MIN (or IV_MAX + 1)
424 as buv > IV_MAX, it is >= (IV_MAX + 1), and therefore
425 as the value we can be subtracting from it only lies in
426 the range (-IV_MIN to -1) it can't overflow a UV */
428 SETu( buv - (UV)-aiv );
431 IV result = (IV) buv + aiv;
432 /* aiv < 0 so it must get smaller. */
433 if (result < (IV) buv) {
439 } /* end of IV+IV / UV+UV / mixed */
446 /* left operand is undef, treat as zero. + 0.0 is identity. */
450 SETn( value + TOPn );
458 AV *av = GvAV(cGVOP_gv);
459 U32 lval = PL_op->op_flags & OPf_MOD;
460 SV** svp = av_fetch(av, PL_op->op_private, lval);
461 SV *sv = (svp ? *svp : &PL_sv_undef);
463 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
464 sv = sv_mortalcopy(sv);
471 djSP; dMARK; dTARGET;
473 do_join(TARG, *MARK, MARK, SP);
484 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
485 * will be enough to hold an OP*.
487 SV* sv = sv_newmortal();
488 sv_upgrade(sv, SVt_PVLV);
490 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
498 /* Oversized hot code. */
502 djSP; dMARK; dORIGMARK;
509 if (PL_op->op_flags & OPf_STACKED)
513 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
515 if (MARK == ORIGMARK) {
516 /* If using default handle then we need to make space to
517 * pass object as 1st arg, so move other args up ...
521 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
525 *MARK = SvTIED_obj((SV*)gv, mg);
528 call_method("PRINT", G_SCALAR);
536 if (!(io = GvIO(gv))) {
537 if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
539 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
540 report_evil_fh(gv, io, PL_op->op_type);
541 SETERRNO(EBADF,RMS$_IFI);
544 else if (!(fp = IoOFP(io))) {
545 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
547 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
548 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
549 report_evil_fh(gv, io, PL_op->op_type);
551 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
556 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
558 if (!do_print(*MARK, fp))
562 if (!do_print(PL_ofs_sv, fp)) { /* $, */
571 if (!do_print(*MARK, fp))
579 if (PL_ors_sv && SvOK(PL_ors_sv))
580 if (!do_print(PL_ors_sv, fp)) /* $\ */
583 if (IoFLAGS(io) & IOf_FLUSH)
584 if (PerlIO_flush(fp) == EOF)
605 tryAMAGICunDEREF(to_av);
608 if (SvTYPE(av) != SVt_PVAV)
609 DIE(aTHX_ "Not an ARRAY reference");
610 if (PL_op->op_flags & OPf_REF) {
615 if (GIMME == G_SCALAR)
616 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
622 if (SvTYPE(sv) == SVt_PVAV) {
624 if (PL_op->op_flags & OPf_REF) {
629 if (GIMME == G_SCALAR)
630 Perl_croak(aTHX_ "Can't return array to lvalue"
639 if (SvTYPE(sv) != SVt_PVGV) {
643 if (SvGMAGICAL(sv)) {
649 if (PL_op->op_flags & OPf_REF ||
650 PL_op->op_private & HINT_STRICT_REFS)
651 DIE(aTHX_ PL_no_usym, "an ARRAY");
652 if (ckWARN(WARN_UNINITIALIZED))
654 if (GIMME == G_ARRAY) {
661 if ((PL_op->op_flags & OPf_SPECIAL) &&
662 !(PL_op->op_flags & OPf_MOD))
664 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
666 && (!is_gv_magical(sym,len,0)
667 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
673 if (PL_op->op_private & HINT_STRICT_REFS)
674 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
675 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
682 if (PL_op->op_private & OPpLVAL_INTRO)
684 if (PL_op->op_flags & OPf_REF) {
689 if (GIMME == G_SCALAR)
690 Perl_croak(aTHX_ "Can't return array to lvalue"
698 if (GIMME == G_ARRAY) {
699 I32 maxarg = AvFILL(av) + 1;
700 (void)POPs; /* XXXX May be optimized away? */
702 if (SvRMAGICAL(av)) {
704 for (i=0; i < maxarg; i++) {
705 SV **svp = av_fetch(av, i, FALSE);
706 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
710 Copy(AvARRAY(av), SP+1, maxarg, SV*);
716 I32 maxarg = AvFILL(av) + 1;
729 tryAMAGICunDEREF(to_hv);
732 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
733 DIE(aTHX_ "Not a HASH reference");
734 if (PL_op->op_flags & OPf_REF) {
739 if (GIMME == G_SCALAR)
740 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
746 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
748 if (PL_op->op_flags & OPf_REF) {
753 if (GIMME == G_SCALAR)
754 Perl_croak(aTHX_ "Can't return hash to lvalue"
763 if (SvTYPE(sv) != SVt_PVGV) {
767 if (SvGMAGICAL(sv)) {
773 if (PL_op->op_flags & OPf_REF ||
774 PL_op->op_private & HINT_STRICT_REFS)
775 DIE(aTHX_ PL_no_usym, "a HASH");
776 if (ckWARN(WARN_UNINITIALIZED))
778 if (GIMME == G_ARRAY) {
785 if ((PL_op->op_flags & OPf_SPECIAL) &&
786 !(PL_op->op_flags & OPf_MOD))
788 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
790 && (!is_gv_magical(sym,len,0)
791 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
797 if (PL_op->op_private & HINT_STRICT_REFS)
798 DIE(aTHX_ PL_no_symref, sym, "a HASH");
799 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
806 if (PL_op->op_private & OPpLVAL_INTRO)
808 if (PL_op->op_flags & OPf_REF) {
813 if (GIMME == G_SCALAR)
814 Perl_croak(aTHX_ "Can't return hash to lvalue"
822 if (GIMME == G_ARRAY) { /* array wanted */
823 *PL_stack_sp = (SV*)hv;
828 if (SvTYPE(hv) == SVt_PVAV)
829 hv = avhv_keys((AV*)hv);
831 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
832 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
842 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
848 leftop = ((BINOP*)PL_op)->op_last;
850 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
851 leftop = ((LISTOP*)leftop)->op_first;
853 /* Skip PUSHMARK and each element already assigned to. */
854 for (i = lelem - firstlelem; i > 0; i--) {
855 leftop = leftop->op_sibling;
858 if (leftop->op_type != OP_RV2HV)
863 av_fill(ary, 0); /* clear all but the fields hash */
864 if (lastrelem >= relem) {
865 while (relem < lastrelem) { /* gobble up all the rest */
869 /* Avoid a memory leak when avhv_store_ent dies. */
870 tmpstr = sv_newmortal();
871 sv_setsv(tmpstr,relem[1]); /* value */
873 if (avhv_store_ent(ary,relem[0],tmpstr,0))
874 (void)SvREFCNT_inc(tmpstr);
875 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
881 if (relem == lastrelem)
887 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
891 if (ckWARN(WARN_MISC)) {
892 if (relem == firstrelem &&
894 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
895 SvTYPE(SvRV(*relem)) == SVt_PVHV))
897 Perl_warner(aTHX_ WARN_MISC,
898 "Reference found where even-sized list expected");
901 Perl_warner(aTHX_ WARN_MISC,
902 "Odd number of elements in hash assignment");
904 if (SvTYPE(hash) == SVt_PVAV) {
906 tmpstr = sv_newmortal();
907 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
908 (void)SvREFCNT_inc(tmpstr);
909 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
914 tmpstr = NEWSV(29,0);
915 didstore = hv_store_ent(hash,*relem,tmpstr,0);
916 if (SvMAGICAL(hash)) {
917 if (SvSMAGICAL(tmpstr))
930 SV **lastlelem = PL_stack_sp;
931 SV **lastrelem = PL_stack_base + POPMARK;
932 SV **firstrelem = PL_stack_base + POPMARK + 1;
933 SV **firstlelem = lastrelem + 1;
946 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
948 /* If there's a common identifier on both sides we have to take
949 * special care that assigning the identifier on the left doesn't
950 * clobber a value on the right that's used later in the list.
952 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
953 EXTEND_MORTAL(lastrelem - firstrelem + 1);
954 for (relem = firstrelem; relem <= lastrelem; relem++) {
957 TAINT_NOT; /* Each item is independent */
958 *relem = sv_mortalcopy(sv);
968 while (lelem <= lastlelem) {
969 TAINT_NOT; /* Each item stands on its own, taintwise. */
971 switch (SvTYPE(sv)) {
974 magic = SvMAGICAL(ary) != 0;
975 if (PL_op->op_private & OPpASSIGN_HASH) {
976 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
982 do_oddball((HV*)ary, relem, firstrelem);
984 relem = lastrelem + 1;
989 av_extend(ary, lastrelem - relem);
991 while (relem <= lastrelem) { /* gobble up all the rest */
997 didstore = av_store(ary,i++,sv);
1007 case SVt_PVHV: { /* normal hash */
1011 magic = SvMAGICAL(hash) != 0;
1014 while (relem < lastrelem) { /* gobble up all the rest */
1019 sv = &PL_sv_no, relem++;
1020 tmpstr = NEWSV(29,0);
1022 sv_setsv(tmpstr,*relem); /* value */
1023 *(relem++) = tmpstr;
1024 didstore = hv_store_ent(hash,sv,tmpstr,0);
1026 if (SvSMAGICAL(tmpstr))
1033 if (relem == lastrelem) {
1034 do_oddball(hash, relem, firstrelem);
1040 if (SvIMMORTAL(sv)) {
1041 if (relem <= lastrelem)
1045 if (relem <= lastrelem) {
1046 sv_setsv(sv, *relem);
1050 sv_setsv(sv, &PL_sv_undef);
1055 if (PL_delaymagic & ~DM_DELAY) {
1056 if (PL_delaymagic & DM_UID) {
1057 #ifdef HAS_SETRESUID
1058 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1060 # ifdef HAS_SETREUID
1061 (void)setreuid(PL_uid,PL_euid);
1064 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1065 (void)setruid(PL_uid);
1066 PL_delaymagic &= ~DM_RUID;
1068 # endif /* HAS_SETRUID */
1070 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1071 (void)seteuid(PL_uid);
1072 PL_delaymagic &= ~DM_EUID;
1074 # endif /* HAS_SETEUID */
1075 if (PL_delaymagic & DM_UID) {
1076 if (PL_uid != PL_euid)
1077 DIE(aTHX_ "No setreuid available");
1078 (void)PerlProc_setuid(PL_uid);
1080 # endif /* HAS_SETREUID */
1081 #endif /* HAS_SETRESUID */
1082 PL_uid = PerlProc_getuid();
1083 PL_euid = PerlProc_geteuid();
1085 if (PL_delaymagic & DM_GID) {
1086 #ifdef HAS_SETRESGID
1087 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1089 # ifdef HAS_SETREGID
1090 (void)setregid(PL_gid,PL_egid);
1093 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1094 (void)setrgid(PL_gid);
1095 PL_delaymagic &= ~DM_RGID;
1097 # endif /* HAS_SETRGID */
1099 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1100 (void)setegid(PL_gid);
1101 PL_delaymagic &= ~DM_EGID;
1103 # endif /* HAS_SETEGID */
1104 if (PL_delaymagic & DM_GID) {
1105 if (PL_gid != PL_egid)
1106 DIE(aTHX_ "No setregid available");
1107 (void)PerlProc_setgid(PL_gid);
1109 # endif /* HAS_SETREGID */
1110 #endif /* HAS_SETRESGID */
1111 PL_gid = PerlProc_getgid();
1112 PL_egid = PerlProc_getegid();
1114 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1119 if (gimme == G_VOID)
1120 SP = firstrelem - 1;
1121 else if (gimme == G_SCALAR) {
1124 SETi(lastrelem - firstrelem + 1);
1130 SP = firstrelem + (lastlelem - firstlelem);
1131 lelem = firstlelem + (relem - firstrelem);
1133 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1141 register PMOP *pm = cPMOP;
1142 SV *rv = sv_newmortal();
1143 SV *sv = newSVrv(rv, "Regexp");
1144 sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
1151 register PMOP *pm = cPMOP;
1156 I32 r_flags = REXEC_CHECKED;
1157 char *truebase; /* Start of string */
1158 register REGEXP *rx = pm->op_pmregexp;
1163 I32 oldsave = PL_savestack_ix;
1164 I32 update_minmatch = 1;
1165 I32 had_zerolen = 0;
1167 if (PL_op->op_flags & OPf_STACKED)
1174 PUTBACK; /* EVAL blocks need stack_sp. */
1175 s = SvPV(TARG, len);
1178 DIE(aTHX_ "panic: pp_match");
1179 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1180 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1183 if (pm->op_pmdynflags & PMdf_USED) {
1185 if (gimme == G_ARRAY)
1190 if (!rx->prelen && PL_curpm) {
1192 rx = pm->op_pmregexp;
1194 if (rx->minlen > len) goto failure;
1198 /* XXXX What part of this is needed with true \G-support? */
1199 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1201 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1202 MAGIC* mg = mg_find(TARG, 'g');
1203 if (mg && mg->mg_len >= 0) {
1204 if (!(rx->reganch & ROPT_GPOS_SEEN))
1205 rx->endp[0] = rx->startp[0] = mg->mg_len;
1206 else if (rx->reganch & ROPT_ANCH_GPOS) {
1207 r_flags |= REXEC_IGNOREPOS;
1208 rx->endp[0] = rx->startp[0] = mg->mg_len;
1210 minmatch = (mg->mg_flags & MGf_MINMATCH);
1211 update_minmatch = 0;
1215 if ((gimme != G_ARRAY && !global && rx->nparens)
1216 || SvTEMP(TARG) || PL_sawampersand)
1217 r_flags |= REXEC_COPY_STR;
1219 r_flags |= REXEC_SCREAM;
1221 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1222 SAVEINT(PL_multiline);
1223 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1227 if (global && rx->startp[0] != -1) {
1228 t = s = rx->endp[0] + truebase;
1229 if ((s + rx->minlen) > strend)
1231 if (update_minmatch++)
1232 minmatch = had_zerolen;
1234 if (rx->reganch & RE_USE_INTUIT &&
1235 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1236 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1240 if ( (rx->reganch & ROPT_CHECK_ALL)
1242 && ((rx->reganch & ROPT_NOSCAN)
1243 || !((rx->reganch & RE_INTUIT_TAIL)
1244 && (r_flags & REXEC_SCREAM)))
1245 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1248 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1251 if (pm->op_pmflags & PMf_ONCE)
1252 pm->op_pmdynflags |= PMdf_USED;
1261 RX_MATCH_TAINTED_on(rx);
1262 TAINT_IF(RX_MATCH_TAINTED(rx));
1263 if (gimme == G_ARRAY) {
1264 I32 nparens, i, len;
1266 nparens = rx->nparens;
1267 if (global && !nparens)
1271 SPAGAIN; /* EVAL blocks could move the stack. */
1272 EXTEND(SP, nparens + i);
1273 EXTEND_MORTAL(nparens + i);
1274 for (i = !i; i <= nparens; i++) {
1275 PUSHs(sv_newmortal());
1277 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1278 len = rx->endp[i] - rx->startp[i];
1279 s = rx->startp[i] + truebase;
1280 sv_setpvn(*SP, s, len);
1286 had_zerolen = (rx->startp[0] != -1
1287 && rx->startp[0] == rx->endp[0]);
1288 PUTBACK; /* EVAL blocks may use stack */
1289 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1294 LEAVE_SCOPE(oldsave);
1300 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1301 mg = mg_find(TARG, 'g');
1303 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1304 mg = mg_find(TARG, 'g');
1306 if (rx->startp[0] != -1) {
1307 mg->mg_len = rx->endp[0];
1308 if (rx->startp[0] == rx->endp[0])
1309 mg->mg_flags |= MGf_MINMATCH;
1311 mg->mg_flags &= ~MGf_MINMATCH;
1314 LEAVE_SCOPE(oldsave);
1318 yup: /* Confirmed by INTUIT */
1320 RX_MATCH_TAINTED_on(rx);
1321 TAINT_IF(RX_MATCH_TAINTED(rx));
1323 if (pm->op_pmflags & PMf_ONCE)
1324 pm->op_pmdynflags |= PMdf_USED;
1325 if (RX_MATCH_COPIED(rx))
1326 Safefree(rx->subbeg);
1327 RX_MATCH_COPIED_off(rx);
1328 rx->subbeg = Nullch;
1330 rx->subbeg = truebase;
1331 rx->startp[0] = s - truebase;
1332 if (DO_UTF8(PL_reg_sv)) {
1333 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1334 rx->endp[0] = t - truebase;
1337 rx->endp[0] = s - truebase + rx->minlen;
1339 rx->sublen = strend - truebase;
1342 if (PL_sawampersand) {
1345 rx->subbeg = savepvn(t, strend - t);
1346 rx->sublen = strend - t;
1347 RX_MATCH_COPIED_on(rx);
1348 off = rx->startp[0] = s - t;
1349 rx->endp[0] = off + rx->minlen;
1351 else { /* startp/endp are used by @- @+. */
1352 rx->startp[0] = s - truebase;
1353 rx->endp[0] = s - truebase + rx->minlen;
1355 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1356 LEAVE_SCOPE(oldsave);
1361 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1362 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1363 MAGIC* mg = mg_find(TARG, 'g');
1368 LEAVE_SCOPE(oldsave);
1369 if (gimme == G_ARRAY)
1375 Perl_do_readline(pTHX)
1377 dSP; dTARGETSTACKED;
1382 register IO *io = GvIO(PL_last_in_gv);
1383 register I32 type = PL_op->op_type;
1384 I32 gimme = GIMME_V;
1387 if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
1389 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1392 call_method("READLINE", gimme);
1395 if (gimme == G_SCALAR)
1396 SvSetMagicSV_nosteal(TARG, TOPs);
1403 if (IoFLAGS(io) & IOf_ARGV) {
1404 if (IoFLAGS(io) & IOf_START) {
1406 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1407 IoFLAGS(io) &= ~IOf_START;
1408 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1409 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1410 SvSETMAGIC(GvSV(PL_last_in_gv));
1415 fp = nextargv(PL_last_in_gv);
1416 if (!fp) { /* Note: fp != IoIFP(io) */
1417 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1420 else if (type == OP_GLOB)
1421 fp = Perl_start_glob(aTHX_ POPs, io);
1423 else if (type == OP_GLOB)
1425 else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
1426 && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
1427 || fp == PerlIO_stderr()))
1428 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1431 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1432 && (!io || !(IoFLAGS(io) & IOf_START))) {
1433 if (type == OP_GLOB)
1434 Perl_warner(aTHX_ WARN_GLOB,
1435 "glob failed (can't start child: %s)",
1438 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1440 if (gimme == G_SCALAR) {
1441 (void)SvOK_off(TARG);
1447 if (gimme == G_SCALAR) {
1451 (void)SvUPGRADE(sv, SVt_PV);
1452 tmplen = SvLEN(sv); /* remember if already alloced */
1454 Sv_Grow(sv, 80); /* try short-buffering it */
1455 if (type == OP_RCATLINE)
1461 sv = sv_2mortal(NEWSV(57, 80));
1465 /* This should not be marked tainted if the fp is marked clean */
1466 #define MAYBE_TAINT_LINE(io, sv) \
1467 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1472 /* delay EOF state for a snarfed empty file */
1473 #define SNARF_EOF(gimme,rs,io,sv) \
1474 (gimme != G_SCALAR || SvCUR(sv) \
1475 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1478 if (!sv_gets(sv, fp, offset)
1479 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1481 PerlIO_clearerr(fp);
1482 if (IoFLAGS(io) & IOf_ARGV) {
1483 fp = nextargv(PL_last_in_gv);
1486 (void)do_close(PL_last_in_gv, FALSE);
1488 else if (type == OP_GLOB) {
1489 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1490 Perl_warner(aTHX_ WARN_GLOB,
1491 "glob failed (child exited with status %d%s)",
1492 (int)(STATUS_CURRENT >> 8),
1493 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1496 if (gimme == G_SCALAR) {
1497 (void)SvOK_off(TARG);
1500 MAYBE_TAINT_LINE(io, sv);
1503 MAYBE_TAINT_LINE(io, sv);
1505 IoFLAGS(io) |= IOf_NOLINE;
1508 if (type == OP_GLOB) {
1511 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1512 tmps = SvEND(sv) - 1;
1513 if (*tmps == *SvPVX(PL_rs)) {
1518 for (tmps = SvPVX(sv); *tmps; tmps++)
1519 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1520 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1522 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1523 (void)POPs; /* Unmatched wildcard? Chuck it... */
1527 if (gimme == G_ARRAY) {
1528 if (SvLEN(sv) - SvCUR(sv) > 20) {
1529 SvLEN_set(sv, SvCUR(sv)+1);
1530 Renew(SvPVX(sv), SvLEN(sv), char);
1532 sv = sv_2mortal(NEWSV(58, 80));
1535 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1536 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1540 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1541 Renew(SvPVX(sv), SvLEN(sv), char);
1550 register PERL_CONTEXT *cx;
1551 I32 gimme = OP_GIMME(PL_op, -1);
1554 if (cxstack_ix >= 0)
1555 gimme = cxstack[cxstack_ix].blk_gimme;
1563 PUSHBLOCK(cx, CXt_BLOCK, SP);
1575 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1576 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1578 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1581 if (SvTYPE(hv) == SVt_PVHV) {
1582 if (PL_op->op_private & OPpLVAL_INTRO)
1583 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1584 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1585 svp = he ? &HeVAL(he) : 0;
1587 else if (SvTYPE(hv) == SVt_PVAV) {
1588 if (PL_op->op_private & OPpLVAL_INTRO)
1589 DIE(aTHX_ "Can't localize pseudo-hash element");
1590 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1596 if (!svp || *svp == &PL_sv_undef) {
1601 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1603 lv = sv_newmortal();
1604 sv_upgrade(lv, SVt_PVLV);
1606 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1607 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1608 LvTARG(lv) = SvREFCNT_inc(hv);
1613 if (PL_op->op_private & OPpLVAL_INTRO) {
1614 if (HvNAME(hv) && isGV(*svp))
1615 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1619 char *key = SvPV(keysv, keylen);
1620 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1622 save_helem(hv, keysv, svp);
1625 else if (PL_op->op_private & OPpDEREF)
1626 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1628 sv = (svp ? *svp : &PL_sv_undef);
1629 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1630 * Pushing the magical RHS on to the stack is useless, since
1631 * that magic is soon destined to be misled by the local(),
1632 * and thus the later pp_sassign() will fail to mg_get() the
1633 * old value. This should also cure problems with delayed
1634 * mg_get()s. GSAR 98-07-03 */
1635 if (!lval && SvGMAGICAL(sv))
1636 sv = sv_mortalcopy(sv);
1644 register PERL_CONTEXT *cx;
1650 if (PL_op->op_flags & OPf_SPECIAL) {
1651 cx = &cxstack[cxstack_ix];
1652 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1657 gimme = OP_GIMME(PL_op, -1);
1659 if (cxstack_ix >= 0)
1660 gimme = cxstack[cxstack_ix].blk_gimme;
1666 if (gimme == G_VOID)
1668 else if (gimme == G_SCALAR) {
1671 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1674 *MARK = sv_mortalcopy(TOPs);
1677 *MARK = &PL_sv_undef;
1681 else if (gimme == G_ARRAY) {
1682 /* in case LEAVE wipes old return values */
1683 for (mark = newsp + 1; mark <= SP; mark++) {
1684 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1685 *mark = sv_mortalcopy(*mark);
1686 TAINT_NOT; /* Each item is independent */
1690 PL_curpm = newpm; /* Don't pop $1 et al till now */
1700 register PERL_CONTEXT *cx;
1706 cx = &cxstack[cxstack_ix];
1707 if (CxTYPE(cx) != CXt_LOOP)
1708 DIE(aTHX_ "panic: pp_iter");
1710 itersvp = CxITERVAR(cx);
1711 av = cx->blk_loop.iterary;
1712 if (SvTYPE(av) != SVt_PVAV) {
1713 /* iterate ($min .. $max) */
1714 if (cx->blk_loop.iterlval) {
1715 /* string increment */
1716 register SV* cur = cx->blk_loop.iterlval;
1718 char *max = SvPV((SV*)av, maxlen);
1719 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1720 #ifndef USE_THREADS /* don't risk potential race */
1721 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1722 /* safe to reuse old SV */
1723 sv_setsv(*itersvp, cur);
1728 /* we need a fresh SV every time so that loop body sees a
1729 * completely new SV for closures/references to work as
1731 SvREFCNT_dec(*itersvp);
1732 *itersvp = newSVsv(cur);
1734 if (strEQ(SvPVX(cur), max))
1735 sv_setiv(cur, 0); /* terminate next time */
1742 /* integer increment */
1743 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1746 #ifndef USE_THREADS /* don't risk potential race */
1747 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1748 /* safe to reuse old SV */
1749 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1754 /* we need a fresh SV every time so that loop body sees a
1755 * completely new SV for closures/references to work as they
1757 SvREFCNT_dec(*itersvp);
1758 *itersvp = newSViv(cx->blk_loop.iterix++);
1764 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1767 SvREFCNT_dec(*itersvp);
1769 if ((sv = SvMAGICAL(av)
1770 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1771 : AvARRAY(av)[++cx->blk_loop.iterix]))
1775 if (av != PL_curstack && SvIMMORTAL(sv)) {
1776 SV *lv = cx->blk_loop.iterlval;
1777 if (lv && SvREFCNT(lv) > 1) {
1782 SvREFCNT_dec(LvTARG(lv));
1784 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1785 sv_upgrade(lv, SVt_PVLV);
1787 sv_magic(lv, Nullsv, 'y', Nullch, 0);
1789 LvTARG(lv) = SvREFCNT_inc(av);
1790 LvTARGOFF(lv) = cx->blk_loop.iterix;
1791 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1795 *itersvp = SvREFCNT_inc(sv);
1802 register PMOP *pm = cPMOP;
1818 register REGEXP *rx = pm->op_pmregexp;
1820 int force_on_match = 0;
1821 I32 oldsave = PL_savestack_ix;
1825 /* known replacement string? */
1826 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1827 if (PL_op->op_flags & OPf_STACKED)
1834 do_utf8 = DO_UTF8(PL_reg_sv);
1835 if (SvFAKE(TARG) && SvREADONLY(TARG))
1836 sv_force_normal(TARG);
1837 if (SvREADONLY(TARG)
1838 || (SvTYPE(TARG) > SVt_PVLV
1839 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1840 DIE(aTHX_ PL_no_modify);
1843 s = SvPV(TARG, len);
1844 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1846 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1847 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1854 DIE(aTHX_ "panic: pp_subst");
1857 slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1858 maxiters = 2 * slen + 10; /* We can match twice at each
1859 position, once with zero-length,
1860 second time with non-zero. */
1862 if (!rx->prelen && PL_curpm) {
1864 rx = pm->op_pmregexp;
1866 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1867 ? REXEC_COPY_STR : 0;
1869 r_flags |= REXEC_SCREAM;
1870 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1871 SAVEINT(PL_multiline);
1872 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1875 if (rx->reganch & RE_USE_INTUIT) {
1876 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1880 /* How to do it in subst? */
1881 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1883 && ((rx->reganch & ROPT_NOSCAN)
1884 || !((rx->reganch & RE_INTUIT_TAIL)
1885 && (r_flags & REXEC_SCREAM))))
1890 /* only replace once? */
1891 once = !(rpm->op_pmflags & PMf_GLOBAL);
1893 /* known replacement string? */
1894 c = dstr ? SvPV(dstr, clen) : Nullch;
1896 /* can do inplace substitution? */
1897 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1898 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1899 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1900 r_flags | REXEC_CHECKED))
1904 LEAVE_SCOPE(oldsave);
1907 if (force_on_match) {
1909 s = SvPV_force(TARG, len);
1914 SvSCREAM_off(TARG); /* disable possible screamer */
1916 rxtainted |= RX_MATCH_TAINTED(rx);
1917 m = orig + rx->startp[0];
1918 d = orig + rx->endp[0];
1920 if (m - s > strend - d) { /* faster to shorten from end */
1922 Copy(c, m, clen, char);
1927 Move(d, m, i, char);
1931 SvCUR_set(TARG, m - s);
1934 else if ((i = m - s)) { /* faster from front */
1942 Copy(c, m, clen, char);
1947 Copy(c, d, clen, char);
1952 TAINT_IF(rxtainted & 1);
1958 if (iters++ > maxiters)
1959 DIE(aTHX_ "Substitution loop");
1960 rxtainted |= RX_MATCH_TAINTED(rx);
1961 m = rx->startp[0] + orig;
1965 Move(s, d, i, char);
1969 Copy(c, d, clen, char);
1972 s = rx->endp[0] + orig;
1973 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
1975 /* don't match same null twice */
1976 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
1979 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1980 Move(s, d, i+1, char); /* include the NUL */
1982 TAINT_IF(rxtainted & 1);
1984 PUSHs(sv_2mortal(newSViv((I32)iters)));
1986 (void)SvPOK_only_UTF8(TARG);
1987 TAINT_IF(rxtainted);
1988 if (SvSMAGICAL(TARG)) {
1994 LEAVE_SCOPE(oldsave);
1998 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1999 r_flags | REXEC_CHECKED))
2003 if (force_on_match) {
2005 s = SvPV_force(TARG, len);
2008 rxtainted |= RX_MATCH_TAINTED(rx);
2009 dstr = NEWSV(25, len);
2010 sv_setpvn(dstr, m, s-m);
2015 register PERL_CONTEXT *cx;
2018 RETURNOP(cPMOP->op_pmreplroot);
2020 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2022 if (iters++ > maxiters)
2023 DIE(aTHX_ "Substitution loop");
2024 rxtainted |= RX_MATCH_TAINTED(rx);
2025 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2030 strend = s + (strend - m);
2032 m = rx->startp[0] + orig;
2033 sv_catpvn(dstr, s, m-s);
2034 s = rx->endp[0] + orig;
2036 sv_catpvn(dstr, c, clen);
2039 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2040 TARG, NULL, r_flags));
2041 sv_catpvn(dstr, s, strend - s);
2043 (void)SvOOK_off(TARG);
2044 Safefree(SvPVX(TARG));
2045 SvPVX(TARG) = SvPVX(dstr);
2046 SvCUR_set(TARG, SvCUR(dstr));
2047 SvLEN_set(TARG, SvLEN(dstr));
2048 isutf8 = DO_UTF8(dstr);
2052 TAINT_IF(rxtainted & 1);
2054 PUSHs(sv_2mortal(newSViv((I32)iters)));
2056 (void)SvPOK_only(TARG);
2059 TAINT_IF(rxtainted);
2062 LEAVE_SCOPE(oldsave);
2071 LEAVE_SCOPE(oldsave);
2080 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2081 ++*PL_markstack_ptr;
2082 LEAVE; /* exit inner scope */
2085 if (PL_stack_base + *PL_markstack_ptr > SP) {
2087 I32 gimme = GIMME_V;
2089 LEAVE; /* exit outer scope */
2090 (void)POPMARK; /* pop src */
2091 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2092 (void)POPMARK; /* pop dst */
2093 SP = PL_stack_base + POPMARK; /* pop original mark */
2094 if (gimme == G_SCALAR) {
2098 else if (gimme == G_ARRAY)
2105 ENTER; /* enter inner scope */
2108 src = PL_stack_base[*PL_markstack_ptr];
2112 RETURNOP(cLOGOP->op_other);
2123 register PERL_CONTEXT *cx;
2129 if (gimme == G_SCALAR) {
2132 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2134 *MARK = SvREFCNT_inc(TOPs);
2139 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2141 *MARK = sv_mortalcopy(sv);
2146 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2150 *MARK = &PL_sv_undef;
2154 else if (gimme == G_ARRAY) {
2155 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2156 if (!SvTEMP(*MARK)) {
2157 *MARK = sv_mortalcopy(*MARK);
2158 TAINT_NOT; /* Each item is independent */
2164 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2165 PL_curpm = newpm; /* ... and pop $1 et al */
2169 return pop_return();
2172 /* This duplicates the above code because the above code must not
2173 * get any slower by more conditions */
2181 register PERL_CONTEXT *cx;
2188 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2189 /* We are an argument to a function or grep().
2190 * This kind of lvalueness was legal before lvalue
2191 * subroutines too, so be backward compatible:
2192 * cannot report errors. */
2194 /* Scalar context *is* possible, on the LHS of -> only,
2195 * as in f()->meth(). But this is not an lvalue. */
2196 if (gimme == G_SCALAR)
2198 if (gimme == G_ARRAY) {
2199 if (!CvLVALUE(cx->blk_sub.cv))
2200 goto temporise_array;
2201 EXTEND_MORTAL(SP - newsp);
2202 for (mark = newsp + 1; mark <= SP; mark++) {
2205 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2206 *mark = sv_mortalcopy(*mark);
2208 /* Can be a localized value subject to deletion. */
2209 PL_tmps_stack[++PL_tmps_ix] = *mark;
2210 (void)SvREFCNT_inc(*mark);
2215 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2216 /* Here we go for robustness, not for speed, so we change all
2217 * the refcounts so the caller gets a live guy. Cannot set
2218 * TEMP, so sv_2mortal is out of question. */
2219 if (!CvLVALUE(cx->blk_sub.cv)) {
2224 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2226 if (gimme == G_SCALAR) {
2230 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2235 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2236 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2238 else { /* Can be a localized value
2239 * subject to deletion. */
2240 PL_tmps_stack[++PL_tmps_ix] = *mark;
2241 (void)SvREFCNT_inc(*mark);
2244 else { /* Should not happen? */
2249 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2250 (MARK > SP ? "Empty array" : "Array"));
2254 else if (gimme == G_ARRAY) {
2255 EXTEND_MORTAL(SP - newsp);
2256 for (mark = newsp + 1; mark <= SP; mark++) {
2257 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2258 /* Might be flattened array after $#array = */
2264 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2265 (*mark != &PL_sv_undef)
2267 ? "a readonly value" : "a temporary")
2268 : "an uninitialized value");
2271 /* Can be a localized value subject to deletion. */
2272 PL_tmps_stack[++PL_tmps_ix] = *mark;
2273 (void)SvREFCNT_inc(*mark);
2279 if (gimme == G_SCALAR) {
2283 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2285 *MARK = SvREFCNT_inc(TOPs);
2290 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2292 *MARK = sv_mortalcopy(sv);
2297 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2301 *MARK = &PL_sv_undef;
2305 else if (gimme == G_ARRAY) {
2307 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2308 if (!SvTEMP(*MARK)) {
2309 *MARK = sv_mortalcopy(*MARK);
2310 TAINT_NOT; /* Each item is independent */
2317 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2318 PL_curpm = newpm; /* ... and pop $1 et al */
2322 return pop_return();
2327 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2329 SV *dbsv = GvSV(PL_DBsub);
2331 if (!PERLDB_SUB_NN) {
2335 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2336 || strEQ(GvNAME(gv), "END")
2337 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2338 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2339 && (gv = (GV*)*svp) ))) {
2340 /* Use GV from the stack as a fallback. */
2341 /* GV is potentially non-unique, or contain different CV. */
2342 SV *tmp = newRV((SV*)cv);
2343 sv_setsv(dbsv, tmp);
2347 gv_efullname3(dbsv, gv, Nullch);
2351 (void)SvUPGRADE(dbsv, SVt_PVIV);
2352 (void)SvIOK_on(dbsv);
2353 SAVEIV(SvIVX(dbsv));
2354 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2358 PL_curcopdb = PL_curcop;
2359 cv = GvCV(PL_DBsub);
2369 register PERL_CONTEXT *cx;
2371 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2374 DIE(aTHX_ "Not a CODE reference");
2375 switch (SvTYPE(sv)) {
2381 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2383 SP = PL_stack_base + POPMARK;
2386 if (SvGMAGICAL(sv)) {
2388 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2391 sym = SvPV(sv, n_a);
2393 DIE(aTHX_ PL_no_usym, "a subroutine");
2394 if (PL_op->op_private & HINT_STRICT_REFS)
2395 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2396 cv = get_cv(sym, TRUE);
2400 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2401 tryAMAGICunDEREF(to_cv);
2404 if (SvTYPE(cv) == SVt_PVCV)
2409 DIE(aTHX_ "Not a CODE reference");
2414 if (!(cv = GvCVu((GV*)sv)))
2415 cv = sv_2cv(sv, &stash, &gv, FALSE);
2428 if (!CvROOT(cv) && !CvXSUB(cv)) {
2432 /* anonymous or undef'd function leaves us no recourse */
2433 if (CvANON(cv) || !(gv = CvGV(cv)))
2434 DIE(aTHX_ "Undefined subroutine called");
2436 /* autoloaded stub? */
2437 if (cv != GvCV(gv)) {
2440 /* should call AUTOLOAD now? */
2443 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2450 sub_name = sv_newmortal();
2451 gv_efullname3(sub_name, gv, Nullch);
2452 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2456 DIE(aTHX_ "Not a CODE reference");
2461 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2462 cv = get_db_sub(&sv, cv);
2464 DIE(aTHX_ "No DBsub routine");
2469 * First we need to check if the sub or method requires locking.
2470 * If so, we gain a lock on the CV, the first argument or the
2471 * stash (for static methods), as appropriate. This has to be
2472 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2473 * reschedule by returning a new op.
2475 MUTEX_LOCK(CvMUTEXP(cv));
2476 if (CvFLAGS(cv) & CVf_LOCKED) {
2478 if (CvFLAGS(cv) & CVf_METHOD) {
2479 if (SP > PL_stack_base + TOPMARK)
2480 sv = *(PL_stack_base + TOPMARK + 1);
2482 AV *av = (AV*)PL_curpad[0];
2483 if (hasargs || !av || AvFILLp(av) < 0
2484 || !(sv = AvARRAY(av)[0]))
2486 MUTEX_UNLOCK(CvMUTEXP(cv));
2487 DIE(aTHX_ "no argument for locked method call");
2494 char *stashname = SvPV(sv, len);
2495 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2501 MUTEX_UNLOCK(CvMUTEXP(cv));
2502 mg = condpair_magic(sv);
2503 MUTEX_LOCK(MgMUTEXP(mg));
2504 if (MgOWNER(mg) == thr)
2505 MUTEX_UNLOCK(MgMUTEXP(mg));
2508 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2510 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2512 MUTEX_UNLOCK(MgMUTEXP(mg));
2513 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2515 MUTEX_LOCK(CvMUTEXP(cv));
2518 * Now we have permission to enter the sub, we must distinguish
2519 * four cases. (0) It's an XSUB (in which case we don't care
2520 * about ownership); (1) it's ours already (and we're recursing);
2521 * (2) it's free (but we may already be using a cached clone);
2522 * (3) another thread owns it. Case (1) is easy: we just use it.
2523 * Case (2) means we look for a clone--if we have one, use it
2524 * otherwise grab ownership of cv. Case (3) means we look for a
2525 * clone (for non-XSUBs) and have to create one if we don't
2527 * Why look for a clone in case (2) when we could just grab
2528 * ownership of cv straight away? Well, we could be recursing,
2529 * i.e. we originally tried to enter cv while another thread
2530 * owned it (hence we used a clone) but it has been freed up
2531 * and we're now recursing into it. It may or may not be "better"
2532 * to use the clone but at least CvDEPTH can be trusted.
2534 if (CvOWNER(cv) == thr || CvXSUB(cv))
2535 MUTEX_UNLOCK(CvMUTEXP(cv));
2537 /* Case (2) or (3) */
2541 * XXX Might it be better to release CvMUTEXP(cv) while we
2542 * do the hv_fetch? We might find someone has pinched it
2543 * when we look again, in which case we would be in case
2544 * (3) instead of (2) so we'd have to clone. Would the fact
2545 * that we released the mutex more quickly make up for this?
2547 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2549 /* We already have a clone to use */
2550 MUTEX_UNLOCK(CvMUTEXP(cv));
2552 DEBUG_S(PerlIO_printf(Perl_debug_log,
2553 "entersub: %p already has clone %p:%s\n",
2554 thr, cv, SvPEEK((SV*)cv)));
2557 if (CvDEPTH(cv) == 0)
2558 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2561 /* (2) => grab ownership of cv. (3) => make clone */
2565 MUTEX_UNLOCK(CvMUTEXP(cv));
2566 DEBUG_S(PerlIO_printf(Perl_debug_log,
2567 "entersub: %p grabbing %p:%s in stash %s\n",
2568 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2569 HvNAME(CvSTASH(cv)) : "(none)"));
2572 /* Make a new clone. */
2574 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2575 MUTEX_UNLOCK(CvMUTEXP(cv));
2576 DEBUG_S((PerlIO_printf(Perl_debug_log,
2577 "entersub: %p cloning %p:%s\n",
2578 thr, cv, SvPEEK((SV*)cv))));
2580 * We're creating a new clone so there's no race
2581 * between the original MUTEX_UNLOCK and the
2582 * SvREFCNT_inc since no one will be trying to undef
2583 * it out from underneath us. At least, I don't think
2586 clonecv = cv_clone(cv);
2587 SvREFCNT_dec(cv); /* finished with this */
2588 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2589 CvOWNER(clonecv) = thr;
2593 DEBUG_S(if (CvDEPTH(cv) != 0)
2594 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2596 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2599 #endif /* USE_THREADS */
2602 #ifdef PERL_XSUB_OLDSTYLE
2603 if (CvOLDSTYLE(cv)) {
2604 I32 (*fp3)(int,int,int);
2606 register I32 items = SP - MARK;
2607 /* We dont worry to copy from @_. */
2612 PL_stack_sp = mark + 1;
2613 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2614 items = (*fp3)(CvXSUBANY(cv).any_i32,
2615 MARK - PL_stack_base + 1,
2617 PL_stack_sp = PL_stack_base + items;
2620 #endif /* PERL_XSUB_OLDSTYLE */
2622 I32 markix = TOPMARK;
2627 /* Need to copy @_ to stack. Alternative may be to
2628 * switch stack to @_, and copy return values
2629 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2633 av = (AV*)PL_curpad[0];
2635 av = GvAV(PL_defgv);
2636 #endif /* USE_THREADS */
2637 items = AvFILLp(av) + 1; /* @_ is not tieable */
2640 /* Mark is at the end of the stack. */
2642 Copy(AvARRAY(av), SP + 1, items, SV*);
2647 /* We assume first XSUB in &DB::sub is the called one. */
2649 SAVEVPTR(PL_curcop);
2650 PL_curcop = PL_curcopdb;
2653 /* Do we need to open block here? XXXX */
2654 (void)(*CvXSUB(cv))(aTHXo_ cv);
2656 /* Enforce some sanity in scalar context. */
2657 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2658 if (markix > PL_stack_sp - PL_stack_base)
2659 *(PL_stack_base + markix) = &PL_sv_undef;
2661 *(PL_stack_base + markix) = *PL_stack_sp;
2662 PL_stack_sp = PL_stack_base + markix;
2670 register I32 items = SP - MARK;
2671 AV* padlist = CvPADLIST(cv);
2672 SV** svp = AvARRAY(padlist);
2673 push_return(PL_op->op_next);
2674 PUSHBLOCK(cx, CXt_SUB, MARK);
2677 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2678 * that eval'' ops within this sub know the correct lexical space.
2679 * Owing the speed considerations, we choose to search for the cv
2680 * in doeval() instead.
2682 if (CvDEPTH(cv) < 2)
2683 (void)SvREFCNT_inc(cv);
2684 else { /* save temporaries on recursion? */
2685 PERL_STACK_OVERFLOW_CHECK();
2686 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2688 AV *newpad = newAV();
2689 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2690 I32 ix = AvFILLp((AV*)svp[1]);
2691 I32 names_fill = AvFILLp((AV*)svp[0]);
2692 svp = AvARRAY(svp[0]);
2693 for ( ;ix > 0; ix--) {
2694 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2695 char *name = SvPVX(svp[ix]);
2696 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2697 || *name == '&') /* anonymous code? */
2699 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2701 else { /* our own lexical */
2703 av_store(newpad, ix, sv = (SV*)newAV());
2704 else if (*name == '%')
2705 av_store(newpad, ix, sv = (SV*)newHV());
2707 av_store(newpad, ix, sv = NEWSV(0,0));
2711 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2712 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2715 av_store(newpad, ix, sv = NEWSV(0,0));
2719 av = newAV(); /* will be @_ */
2721 av_store(newpad, 0, (SV*)av);
2722 AvFLAGS(av) = AVf_REIFY;
2723 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2724 AvFILLp(padlist) = CvDEPTH(cv);
2725 svp = AvARRAY(padlist);
2730 AV* av = (AV*)PL_curpad[0];
2732 items = AvFILLp(av) + 1;
2734 /* Mark is at the end of the stack. */
2736 Copy(AvARRAY(av), SP + 1, items, SV*);
2741 #endif /* USE_THREADS */
2742 SAVEVPTR(PL_curpad);
2743 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2746 #endif /* USE_THREADS */
2752 DEBUG_S(PerlIO_printf(Perl_debug_log,
2753 "%p entersub preparing @_\n", thr));
2755 av = (AV*)PL_curpad[0];
2757 /* @_ is normally not REAL--this should only ever
2758 * happen when DB::sub() calls things that modify @_ */
2764 cx->blk_sub.savearray = GvAV(PL_defgv);
2765 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2766 #endif /* USE_THREADS */
2767 cx->blk_sub.oldcurpad = PL_curpad;
2768 cx->blk_sub.argarray = av;
2771 if (items > AvMAX(av) + 1) {
2773 if (AvARRAY(av) != ary) {
2774 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2775 SvPVX(av) = (char*)ary;
2777 if (items > AvMAX(av) + 1) {
2778 AvMAX(av) = items - 1;
2779 Renew(ary,items,SV*);
2781 SvPVX(av) = (char*)ary;
2784 Copy(MARK,AvARRAY(av),items,SV*);
2785 AvFILLp(av) = items - 1;
2793 /* warning must come *after* we fully set up the context
2794 * stuff so that __WARN__ handlers can safely dounwind()
2797 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2798 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2799 sub_crush_depth(cv);
2801 DEBUG_S(PerlIO_printf(Perl_debug_log,
2802 "%p entersub returning %p\n", thr, CvSTART(cv)));
2804 RETURNOP(CvSTART(cv));
2809 Perl_sub_crush_depth(pTHX_ CV *cv)
2812 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2814 SV* tmpstr = sv_newmortal();
2815 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2816 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2826 IV elem = SvIV(elemsv);
2828 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2829 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2832 if (SvROK(elemsv) && ckWARN(WARN_MISC))
2833 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2835 elem -= PL_curcop->cop_arybase;
2836 if (SvTYPE(av) != SVt_PVAV)
2838 svp = av_fetch(av, elem, lval && !defer);
2840 if (!svp || *svp == &PL_sv_undef) {
2843 DIE(aTHX_ PL_no_aelem, elem);
2844 lv = sv_newmortal();
2845 sv_upgrade(lv, SVt_PVLV);
2847 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2848 LvTARG(lv) = SvREFCNT_inc(av);
2849 LvTARGOFF(lv) = elem;
2854 if (PL_op->op_private & OPpLVAL_INTRO)
2855 save_aelem(av, elem, svp);
2856 else if (PL_op->op_private & OPpDEREF)
2857 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2859 sv = (svp ? *svp : &PL_sv_undef);
2860 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2861 sv = sv_mortalcopy(sv);
2867 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2873 Perl_croak(aTHX_ PL_no_modify);
2874 if (SvTYPE(sv) < SVt_RV)
2875 sv_upgrade(sv, SVt_RV);
2876 else if (SvTYPE(sv) >= SVt_PV) {
2877 (void)SvOOK_off(sv);
2878 Safefree(SvPVX(sv));
2879 SvLEN(sv) = SvCUR(sv) = 0;
2883 SvRV(sv) = NEWSV(355,0);
2886 SvRV(sv) = (SV*)newAV();
2889 SvRV(sv) = (SV*)newHV();
2904 if (SvTYPE(rsv) == SVt_PVCV) {
2910 SETs(method_common(sv, Null(U32*)));
2917 SV* sv = cSVOP->op_sv;
2918 U32 hash = SvUVX(sv);
2920 XPUSHs(method_common(sv, &hash));
2925 S_method_common(pTHX_ SV* meth, U32* hashp)
2936 name = SvPV(meth, namelen);
2937 sv = *(PL_stack_base + TOPMARK + 1);
2940 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2951 !(packname = SvPV(sv, packlen)) ||
2952 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2953 !(ob=(SV*)GvIO(iogv)))
2956 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2957 ? !isIDFIRST_utf8((U8*)packname)
2958 : !isIDFIRST(*packname)
2961 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2962 SvOK(sv) ? "without a package or object reference"
2963 : "on an undefined value");
2965 stash = gv_stashpvn(packname, packlen, TRUE);
2968 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2971 if (!ob || !(SvOBJECT(ob)
2972 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2975 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2979 stash = SvSTASH(ob);
2982 /* shortcut for simple names */
2984 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2986 gv = (GV*)HeVAL(he);
2987 if (isGV(gv) && GvCV(gv) &&
2988 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2989 return (SV*)GvCV(gv);
2993 gv = gv_fetchmethod(stash, name);
3000 for (p = name; *p; p++) {
3002 sep = p, leaf = p + 1;
3003 else if (*p == ':' && *(p + 1) == ':')
3004 sep = p, leaf = p + 2;
3006 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3007 packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
3008 packlen = strlen(packname);
3012 packlen = sep - name;
3014 gv = gv_fetchpv(packname, 0, SVt_PVHV);
3015 if (gv && isGV(gv)) {
3017 "Can't locate object method \"%s\" via package \"%s\"",
3022 "Can't locate object method \"%s\" via package \"%s\""
3023 " (perhaps you forgot to load \"%s\"?)",
3024 leaf, packname, packname);
3027 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3032 unset_cvowner(pTHXo_ void *cvarg)
3034 register CV* cv = (CV *) cvarg;
3036 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3037 thr, cv, SvPEEK((SV*)cv))));
3038 MUTEX_LOCK(CvMUTEXP(cv));
3039 DEBUG_S(if (CvDEPTH(cv) != 0)
3040 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3042 assert(thr == CvOWNER(cv));
3044 MUTEX_UNLOCK(CvMUTEXP(cv));
3047 #endif /* USE_THREADS */