3 * Copyright (c) 1991-2000, 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
29 static void unset_cvowner(pTHXo_ void *cvarg);
30 #endif /* USE_THREADS */
41 PL_curcop = (COP*)PL_op;
42 TAINT_NOT; /* Each statement is presumed innocent */
43 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
52 if (PL_op->op_private & OPpLVAL_INTRO)
53 PUSHs(save_scalar(cGVOP_gv));
55 PUSHs(GvSV(cGVOP_gv));
66 PL_curcop = (COP*)PL_op;
72 PUSHMARK(PL_stack_sp);
82 sv_setpvn(TARG,s,len);
83 if (SvUTF8(TOPs) && !IN_BYTE)
92 XPUSHs((SV*)cGVOP_gv);
103 RETURNOP(cLOGOP->op_other);
111 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
113 temp = left; left = right; right = temp;
115 if (PL_tainting && PL_tainted && !SvTAINTED(left))
117 SvSetMagicSV(right, left);
126 RETURNOP(cLOGOP->op_other);
128 RETURNOP(cLOGOP->op_next);
134 TAINT_NOT; /* Each statement is presumed innocent */
135 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
137 oldsave = PL_scopestack[PL_scopestack_ix - 1];
138 LEAVE_SCOPE(oldsave);
144 djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
149 bool left_utf = DO_UTF8(left);
150 bool right_utf = DO_UTF8(right);
153 if (right_utf && !left_utf)
154 sv_utf8_upgrade(left);
158 if (left_utf && !right_utf)
159 sv_utf8_upgrade(right);
160 sv_insert(TARG, 0, 0, s, len);
161 if (left_utf || right_utf)
166 sv_setpvn(TARG,s,len);
168 else if (SvGMAGICAL(TARG)) {
170 if (right_utf && !left_utf)
171 sv_utf8_upgrade(left);
173 else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) {
174 sv_setpv(TARG, ""); /* Suppress warning. */
175 s = SvPV_force(TARG, len);
177 if (left_utf && !right_utf)
178 sv_utf8_upgrade(right);
181 #if defined(PERL_Y2KWARN)
182 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
184 char *s = SvPV(TARG,n);
185 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
186 && (n == 2 || !isDIGIT(s[n-3])))
188 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
189 "about to append an integer to '19'");
193 sv_catpvn(TARG,s,len);
196 sv_setpvn(TARG,s,len); /* suppress warning */
197 if (left_utf || right_utf)
208 if (PL_op->op_flags & OPf_MOD) {
209 if (PL_op->op_private & OPpLVAL_INTRO)
210 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
211 else if (PL_op->op_private & OPpDEREF) {
213 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
222 tryAMAGICunTARGET(iter, 0);
223 PL_last_in_gv = (GV*)(*PL_stack_sp--);
224 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
225 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
226 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
229 XPUSHs((SV*)PL_last_in_gv);
232 PL_last_in_gv = (GV*)(*PL_stack_sp--);
235 return do_readline();
240 djSP; tryAMAGICbinSET(eq,0);
243 SETs(boolSV(TOPn == value));
251 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
252 DIE(aTHX_ PL_no_modify);
253 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
254 SvIVX(TOPs) != IV_MAX)
257 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
272 RETURNOP(cLOGOP->op_other);
278 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
281 SETn( left + right );
289 AV *av = GvAV(cGVOP_gv);
290 U32 lval = PL_op->op_flags & OPf_MOD;
291 SV** svp = av_fetch(av, PL_op->op_private, lval);
292 SV *sv = (svp ? *svp : &PL_sv_undef);
294 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
295 sv = sv_mortalcopy(sv);
302 djSP; dMARK; dTARGET;
304 do_join(TARG, *MARK, MARK, SP);
315 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
316 * will be enough to hold an OP*.
318 SV* sv = sv_newmortal();
319 sv_upgrade(sv, SVt_PVLV);
321 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
329 /* Oversized hot code. */
333 djSP; dMARK; dORIGMARK;
340 if (PL_op->op_flags & OPf_STACKED)
344 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
345 if (MARK == ORIGMARK) {
346 /* If using default handle then we need to make space to
347 * pass object as 1st arg, so move other args up ...
351 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
355 *MARK = SvTIED_obj((SV*)gv, mg);
358 call_method("PRINT", G_SCALAR);
366 if (!(io = GvIO(gv))) {
367 if (ckWARN(WARN_UNOPENED)) {
368 SV* sv = sv_newmortal();
369 gv_efullname3(sv, gv, Nullch);
370 Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened",
373 SETERRNO(EBADF,RMS$_IFI);
376 else if (!(fp = IoOFP(io))) {
377 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
379 SV* sv = sv_newmortal();
380 gv_efullname3(sv, gv, Nullch);
381 Perl_warner(aTHX_ WARN_IO,
382 "Filehandle %s opened only for input",
385 else if (ckWARN(WARN_CLOSED))
386 report_closed_fh(gv, io, "print", "filehandle");
388 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
395 if (!do_print(*MARK, fp))
399 if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) {
408 if (!do_print(*MARK, fp))
417 if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp))
420 if (IoFLAGS(io) & IOf_FLUSH)
421 if (PerlIO_flush(fp) == EOF)
442 tryAMAGICunDEREF(to_av);
445 if (SvTYPE(av) != SVt_PVAV)
446 DIE(aTHX_ "Not an ARRAY reference");
447 if (PL_op->op_flags & OPf_REF) {
453 if (SvTYPE(sv) == SVt_PVAV) {
455 if (PL_op->op_flags & OPf_REF) {
463 if (SvTYPE(sv) != SVt_PVGV) {
467 if (SvGMAGICAL(sv)) {
473 if (PL_op->op_flags & OPf_REF ||
474 PL_op->op_private & HINT_STRICT_REFS)
475 DIE(aTHX_ PL_no_usym, "an ARRAY");
476 if (ckWARN(WARN_UNINITIALIZED))
478 if (GIMME == G_ARRAY) {
485 if ((PL_op->op_flags & OPf_SPECIAL) &&
486 !(PL_op->op_flags & OPf_MOD))
488 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
490 && (!is_gv_magical(sym,len,0)
491 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
497 if (PL_op->op_private & HINT_STRICT_REFS)
498 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
499 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
506 if (PL_op->op_private & OPpLVAL_INTRO)
508 if (PL_op->op_flags & OPf_REF) {
515 if (GIMME == G_ARRAY) {
516 I32 maxarg = AvFILL(av) + 1;
517 (void)POPs; /* XXXX May be optimized away? */
519 if (SvRMAGICAL(av)) {
521 for (i=0; i < maxarg; i++) {
522 SV **svp = av_fetch(av, i, FALSE);
523 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
527 Copy(AvARRAY(av), SP+1, maxarg, SV*);
533 I32 maxarg = AvFILL(av) + 1;
546 tryAMAGICunDEREF(to_hv);
549 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
550 DIE(aTHX_ "Not a HASH reference");
551 if (PL_op->op_flags & OPf_REF) {
557 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
559 if (PL_op->op_flags & OPf_REF) {
567 if (SvTYPE(sv) != SVt_PVGV) {
571 if (SvGMAGICAL(sv)) {
577 if (PL_op->op_flags & OPf_REF ||
578 PL_op->op_private & HINT_STRICT_REFS)
579 DIE(aTHX_ PL_no_usym, "a HASH");
580 if (ckWARN(WARN_UNINITIALIZED))
582 if (GIMME == G_ARRAY) {
589 if ((PL_op->op_flags & OPf_SPECIAL) &&
590 !(PL_op->op_flags & OPf_MOD))
592 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
594 && (!is_gv_magical(sym,len,0)
595 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
601 if (PL_op->op_private & HINT_STRICT_REFS)
602 DIE(aTHX_ PL_no_symref, sym, "a HASH");
603 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
610 if (PL_op->op_private & OPpLVAL_INTRO)
612 if (PL_op->op_flags & OPf_REF) {
619 if (GIMME == G_ARRAY) { /* array wanted */
620 *PL_stack_sp = (SV*)hv;
625 if (SvTYPE(hv) == SVt_PVAV)
626 hv = avhv_keys((AV*)hv);
628 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
629 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
639 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
645 leftop = ((BINOP*)PL_op)->op_last;
647 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
648 leftop = ((LISTOP*)leftop)->op_first;
650 /* Skip PUSHMARK and each element already assigned to. */
651 for (i = lelem - firstlelem; i > 0; i--) {
652 leftop = leftop->op_sibling;
655 if (leftop->op_type != OP_RV2HV)
660 av_fill(ary, 0); /* clear all but the fields hash */
661 if (lastrelem >= relem) {
662 while (relem < lastrelem) { /* gobble up all the rest */
666 /* Avoid a memory leak when avhv_store_ent dies. */
667 tmpstr = sv_newmortal();
668 sv_setsv(tmpstr,relem[1]); /* value */
670 if (avhv_store_ent(ary,relem[0],tmpstr,0))
671 (void)SvREFCNT_inc(tmpstr);
672 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
678 if (relem == lastrelem)
684 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
688 if (ckWARN(WARN_MISC)) {
689 if (relem == firstrelem &&
691 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
692 SvTYPE(SvRV(*relem)) == SVt_PVHV))
694 Perl_warner(aTHX_ WARN_MISC,
695 "Reference found where even-sized list expected");
698 Perl_warner(aTHX_ WARN_MISC,
699 "Odd number of elements in hash assignment");
701 if (SvTYPE(hash) == SVt_PVAV) {
703 tmpstr = sv_newmortal();
704 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
705 (void)SvREFCNT_inc(tmpstr);
706 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
711 tmpstr = NEWSV(29,0);
712 didstore = hv_store_ent(hash,*relem,tmpstr,0);
713 if (SvMAGICAL(hash)) {
714 if (SvSMAGICAL(tmpstr))
727 SV **lastlelem = PL_stack_sp;
728 SV **lastrelem = PL_stack_base + POPMARK;
729 SV **firstrelem = PL_stack_base + POPMARK + 1;
730 SV **firstlelem = lastrelem + 1;
743 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
745 /* If there's a common identifier on both sides we have to take
746 * special care that assigning the identifier on the left doesn't
747 * clobber a value on the right that's used later in the list.
749 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
750 EXTEND_MORTAL(lastrelem - firstrelem + 1);
751 for (relem = firstrelem; relem <= lastrelem; relem++) {
754 TAINT_NOT; /* Each item is independent */
755 *relem = sv_mortalcopy(sv);
765 while (lelem <= lastlelem) {
766 TAINT_NOT; /* Each item stands on its own, taintwise. */
768 switch (SvTYPE(sv)) {
771 magic = SvMAGICAL(ary) != 0;
772 if (PL_op->op_private & OPpASSIGN_HASH) {
773 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
779 do_oddball((HV*)ary, relem, firstrelem);
781 relem = lastrelem + 1;
786 av_extend(ary, lastrelem - relem);
788 while (relem <= lastrelem) { /* gobble up all the rest */
794 didstore = av_store(ary,i++,sv);
804 case SVt_PVHV: { /* normal hash */
808 magic = SvMAGICAL(hash) != 0;
811 while (relem < lastrelem) { /* gobble up all the rest */
816 sv = &PL_sv_no, relem++;
817 tmpstr = NEWSV(29,0);
819 sv_setsv(tmpstr,*relem); /* value */
821 didstore = hv_store_ent(hash,sv,tmpstr,0);
823 if (SvSMAGICAL(tmpstr))
830 if (relem == lastrelem) {
831 do_oddball(hash, relem, firstrelem);
837 if (SvIMMORTAL(sv)) {
838 if (relem <= lastrelem)
842 if (relem <= lastrelem) {
843 sv_setsv(sv, *relem);
847 sv_setsv(sv, &PL_sv_undef);
852 if (PL_delaymagic & ~DM_DELAY) {
853 if (PL_delaymagic & DM_UID) {
855 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
858 (void)setreuid(PL_uid,PL_euid);
861 if ((PL_delaymagic & DM_UID) == DM_RUID) {
862 (void)setruid(PL_uid);
863 PL_delaymagic &= ~DM_RUID;
865 # endif /* HAS_SETRUID */
867 if ((PL_delaymagic & DM_UID) == DM_EUID) {
868 (void)seteuid(PL_uid);
869 PL_delaymagic &= ~DM_EUID;
871 # endif /* HAS_SETEUID */
872 if (PL_delaymagic & DM_UID) {
873 if (PL_uid != PL_euid)
874 DIE(aTHX_ "No setreuid available");
875 (void)PerlProc_setuid(PL_uid);
877 # endif /* HAS_SETREUID */
878 #endif /* HAS_SETRESUID */
879 PL_uid = PerlProc_getuid();
880 PL_euid = PerlProc_geteuid();
882 if (PL_delaymagic & DM_GID) {
884 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
887 (void)setregid(PL_gid,PL_egid);
890 if ((PL_delaymagic & DM_GID) == DM_RGID) {
891 (void)setrgid(PL_gid);
892 PL_delaymagic &= ~DM_RGID;
894 # endif /* HAS_SETRGID */
896 if ((PL_delaymagic & DM_GID) == DM_EGID) {
897 (void)setegid(PL_gid);
898 PL_delaymagic &= ~DM_EGID;
900 # endif /* HAS_SETEGID */
901 if (PL_delaymagic & DM_GID) {
902 if (PL_gid != PL_egid)
903 DIE(aTHX_ "No setregid available");
904 (void)PerlProc_setgid(PL_gid);
906 # endif /* HAS_SETREGID */
907 #endif /* HAS_SETRESGID */
908 PL_gid = PerlProc_getgid();
909 PL_egid = PerlProc_getegid();
911 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
918 else if (gimme == G_SCALAR) {
921 SETi(lastrelem - firstrelem + 1);
927 SP = firstrelem + (lastlelem - firstlelem);
928 lelem = firstlelem + (relem - firstrelem);
930 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
938 register PMOP *pm = cPMOP;
939 SV *rv = sv_newmortal();
940 SV *sv = newSVrv(rv, "Regexp");
941 sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
948 register PMOP *pm = cPMOP;
953 I32 r_flags = REXEC_CHECKED;
954 char *truebase; /* Start of string */
955 register REGEXP *rx = pm->op_pmregexp;
960 I32 oldsave = PL_savestack_ix;
961 I32 update_minmatch = 1;
964 if (PL_op->op_flags & OPf_STACKED)
970 PUTBACK; /* EVAL blocks need stack_sp. */
974 DIE(aTHX_ "panic: do_match");
975 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
976 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
979 if (pm->op_pmdynflags & PMdf_USED) {
981 if (gimme == G_ARRAY)
986 if (!rx->prelen && PL_curpm) {
988 rx = pm->op_pmregexp;
990 if (rx->minlen > len) goto failure;
994 /* XXXX What part of this is needed with true \G-support? */
995 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
997 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
998 MAGIC* mg = mg_find(TARG, 'g');
999 if (mg && mg->mg_len >= 0) {
1000 if (!(rx->reganch & ROPT_GPOS_SEEN))
1001 rx->endp[0] = rx->startp[0] = mg->mg_len;
1002 else if (rx->reganch & ROPT_ANCH_GPOS) {
1003 r_flags |= REXEC_IGNOREPOS;
1004 rx->endp[0] = rx->startp[0] = mg->mg_len;
1006 minmatch = (mg->mg_flags & MGf_MINMATCH);
1007 update_minmatch = 0;
1011 if ((gimme != G_ARRAY && !global && rx->nparens)
1012 || SvTEMP(TARG) || PL_sawampersand)
1013 r_flags |= REXEC_COPY_STR;
1015 r_flags |= REXEC_SCREAM;
1017 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1018 SAVEINT(PL_multiline);
1019 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1023 if (global && rx->startp[0] != -1) {
1024 t = s = rx->endp[0] + truebase;
1025 if ((s + rx->minlen) > strend)
1027 if (update_minmatch++)
1028 minmatch = had_zerolen;
1030 if (rx->reganch & RE_USE_INTUIT) {
1031 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1035 if ( (rx->reganch & ROPT_CHECK_ALL)
1037 && ((rx->reganch & ROPT_NOSCAN)
1038 || !((rx->reganch & RE_INTUIT_TAIL)
1039 && (r_flags & REXEC_SCREAM)))
1040 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1043 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1046 if (pm->op_pmflags & PMf_ONCE)
1047 pm->op_pmdynflags |= PMdf_USED;
1056 RX_MATCH_TAINTED_on(rx);
1057 TAINT_IF(RX_MATCH_TAINTED(rx));
1058 if (gimme == G_ARRAY) {
1061 iters = rx->nparens;
1062 if (global && !iters)
1066 SPAGAIN; /* EVAL blocks could move the stack. */
1067 EXTEND(SP, iters + i);
1068 EXTEND_MORTAL(iters + i);
1069 for (i = !i; i <= iters; i++) {
1070 PUSHs(sv_newmortal());
1072 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1073 len = rx->endp[i] - rx->startp[i];
1074 s = rx->startp[i] + truebase;
1075 sv_setpvn(*SP, s, len);
1076 if ((pm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) {
1078 sv_utf8_downgrade(*SP, TRUE);
1083 had_zerolen = (rx->startp[0] != -1
1084 && rx->startp[0] == rx->endp[0]);
1085 PUTBACK; /* EVAL blocks may use stack */
1086 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1091 LEAVE_SCOPE(oldsave);
1097 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1098 mg = mg_find(TARG, 'g');
1100 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1101 mg = mg_find(TARG, 'g');
1103 if (rx->startp[0] != -1) {
1104 mg->mg_len = rx->endp[0];
1105 if (rx->startp[0] == rx->endp[0])
1106 mg->mg_flags |= MGf_MINMATCH;
1108 mg->mg_flags &= ~MGf_MINMATCH;
1111 LEAVE_SCOPE(oldsave);
1115 yup: /* Confirmed by INTUIT */
1117 RX_MATCH_TAINTED_on(rx);
1118 TAINT_IF(RX_MATCH_TAINTED(rx));
1120 if (pm->op_pmflags & PMf_ONCE)
1121 pm->op_pmdynflags |= PMdf_USED;
1122 if (RX_MATCH_COPIED(rx))
1123 Safefree(rx->subbeg);
1124 RX_MATCH_COPIED_off(rx);
1125 rx->subbeg = Nullch;
1127 rx->subbeg = truebase;
1128 rx->startp[0] = s - truebase;
1129 rx->endp[0] = s - truebase + rx->minlen;
1130 rx->sublen = strend - truebase;
1133 if (PL_sawampersand) {
1136 rx->subbeg = savepvn(t, strend - t);
1137 rx->sublen = strend - t;
1138 RX_MATCH_COPIED_on(rx);
1139 off = rx->startp[0] = s - t;
1140 rx->endp[0] = off + rx->minlen;
1142 else { /* startp/endp are used by @- @+. */
1143 rx->startp[0] = s - truebase;
1144 rx->endp[0] = s - truebase + rx->minlen;
1146 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1147 LEAVE_SCOPE(oldsave);
1152 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1153 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1154 MAGIC* mg = mg_find(TARG, 'g');
1159 LEAVE_SCOPE(oldsave);
1160 if (gimme == G_ARRAY)
1166 Perl_do_readline(pTHX)
1168 dSP; dTARGETSTACKED;
1173 register IO *io = GvIO(PL_last_in_gv);
1174 register I32 type = PL_op->op_type;
1175 I32 gimme = GIMME_V;
1178 if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
1180 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1183 call_method("READLINE", gimme);
1186 if (gimme == G_SCALAR)
1187 SvSetMagicSV_nosteal(TARG, TOPs);
1194 if (IoFLAGS(io) & IOf_ARGV) {
1195 if (IoFLAGS(io) & IOf_START) {
1197 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1198 IoFLAGS(io) &= ~IOf_START;
1199 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1200 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1201 SvSETMAGIC(GvSV(PL_last_in_gv));
1206 fp = nextargv(PL_last_in_gv);
1207 if (!fp) { /* Note: fp != IoIFP(io) */
1208 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1211 else if (type == OP_GLOB) {
1212 SV *tmpcmd = NEWSV(55, 0);
1216 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
1217 /* since spawning off a process is a real performance hit */
1219 #include <descrip.h>
1220 #include <lib$routines.h>
1223 char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
1224 char vmsspec[NAM$C_MAXRSS+1];
1225 char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
1226 char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
1227 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
1230 struct dsc$descriptor_s wilddsc
1231 = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1232 struct dsc$descriptor_vs rsdsc
1233 = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
1234 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
1236 /* We could find out if there's an explicit dev/dir or version
1237 by peeking into lib$find_file's internal context at
1238 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
1239 but that's unsupported, so I don't want to do it now and
1240 have it bite someone in the future. */
1241 strcat(tmpfnam,PerlLIO_tmpnam(NULL));
1242 cp = SvPV(tmpglob,i);
1244 if (cp[i] == ';') hasver = 1;
1246 if (sts) hasver = 1;
1250 hasdir = isunix = 1;
1253 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
1258 if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
1260 if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
1261 ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
1262 else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
1263 if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
1264 while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
1265 &dfltdsc,NULL,NULL,NULL))&1)) {
1266 end = rstr + (unsigned long int) *rslt;
1267 if (!hasver) while (*end != ';') end--;
1268 *(end++) = '\n'; *end = '\0';
1269 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
1271 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
1276 while (*(--begin) != ']' && *begin != '>') ;
1279 ok = (PerlIO_puts(tmpfp,begin) != EOF);
1281 if (cxt) (void)lib$find_file_end(&cxt);
1282 if (ok && sts != RMS$_NMF &&
1283 sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
1286 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
1288 PerlIO_close(tmpfp);
1292 PerlIO_rewind(tmpfp);
1294 IoIFP(io) = fp = tmpfp;
1295 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
1300 #ifdef MACOS_TRADITIONAL
1301 sv_setpv(tmpcmd, "glob ");
1302 sv_catsv(tmpcmd, tmpglob);
1303 sv_catpv(tmpcmd, " |");
1307 sv_setpv(tmpcmd, "for a in ");
1308 sv_catsv(tmpcmd, tmpglob);
1309 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
1312 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
1313 sv_catsv(tmpcmd, tmpglob);
1315 sv_setpv(tmpcmd, "perlglob ");
1316 sv_catsv(tmpcmd, tmpglob);
1317 sv_catpv(tmpcmd, " |");
1322 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
1323 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
1324 sv_catsv(tmpcmd, tmpglob);
1325 sv_catpv(tmpcmd, "' 2>/dev/null |");
1327 sv_setpv(tmpcmd, "echo ");
1328 sv_catsv(tmpcmd, tmpglob);
1330 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
1332 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
1335 #endif /* !DOSISH */
1336 #endif /* MACOS_TRADITIONAL */
1337 (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
1338 FALSE, O_RDONLY, 0, Nullfp);
1344 else if (type == OP_GLOB)
1346 else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
1347 && (IoTYPE(io) == '>' || fp == PerlIO_stdout()
1348 || fp == PerlIO_stderr()))
1350 SV* sv = sv_newmortal();
1351 gv_efullname3(sv, PL_last_in_gv, Nullch);
1352 Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
1357 if (ckWARN2(WARN_GLOB,WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) {
1358 if (type == OP_GLOB)
1359 Perl_warner(aTHX_ WARN_GLOB,
1360 "glob failed (can't start child: %s)",
1363 report_closed_fh(PL_last_in_gv, io, "readline", "filehandle");
1365 if (gimme == G_SCALAR) {
1366 (void)SvOK_off(TARG);
1372 if (gimme == G_SCALAR) {
1376 (void)SvUPGRADE(sv, SVt_PV);
1377 tmplen = SvLEN(sv); /* remember if already alloced */
1379 Sv_Grow(sv, 80); /* try short-buffering it */
1380 if (type == OP_RCATLINE)
1386 sv = sv_2mortal(NEWSV(57, 80));
1390 /* delay EOF state for a snarfed empty file */
1391 #define SNARF_EOF(gimme,rs,io,sv) \
1392 (gimme != G_SCALAR || SvCUR(sv) \
1393 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1396 if (!sv_gets(sv, fp, offset)
1397 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1399 PerlIO_clearerr(fp);
1400 if (IoFLAGS(io) & IOf_ARGV) {
1401 fp = nextargv(PL_last_in_gv);
1404 (void)do_close(PL_last_in_gv, FALSE);
1406 else if (type == OP_GLOB) {
1407 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1408 Perl_warner(aTHX_ WARN_GLOB,
1409 "glob failed (child exited with status %d%s)",
1410 (int)(STATUS_CURRENT >> 8),
1411 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1414 if (gimme == G_SCALAR) {
1415 (void)SvOK_off(TARG);
1420 /* This should not be marked tainted if the fp is marked clean */
1421 if (!(IoFLAGS(io) & IOf_UNTAINT)) {
1426 IoFLAGS(io) |= IOf_NOLINE;
1429 if (type == OP_GLOB) {
1432 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1433 tmps = SvEND(sv) - 1;
1434 if (*tmps == *SvPVX(PL_rs)) {
1439 for (tmps = SvPVX(sv); *tmps; tmps++)
1440 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1441 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1443 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1444 (void)POPs; /* Unmatched wildcard? Chuck it... */
1448 if (gimme == G_ARRAY) {
1449 if (SvLEN(sv) - SvCUR(sv) > 20) {
1450 SvLEN_set(sv, SvCUR(sv)+1);
1451 Renew(SvPVX(sv), SvLEN(sv), char);
1453 sv = sv_2mortal(NEWSV(58, 80));
1456 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1457 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1461 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1462 Renew(SvPVX(sv), SvLEN(sv), char);
1471 register PERL_CONTEXT *cx;
1472 I32 gimme = OP_GIMME(PL_op, -1);
1475 if (cxstack_ix >= 0)
1476 gimme = cxstack[cxstack_ix].blk_gimme;
1484 PUSHBLOCK(cx, CXt_BLOCK, SP);
1496 U32 lval = PL_op->op_flags & OPf_MOD;
1497 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1500 if (SvTYPE(hv) == SVt_PVHV) {
1501 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1502 svp = he ? &HeVAL(he) : 0;
1504 else if (SvTYPE(hv) == SVt_PVAV) {
1505 if (PL_op->op_private & OPpLVAL_INTRO)
1506 DIE(aTHX_ "Can't localize pseudo-hash element");
1507 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
1513 if (!svp || *svp == &PL_sv_undef) {
1518 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1520 lv = sv_newmortal();
1521 sv_upgrade(lv, SVt_PVLV);
1523 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1524 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1525 LvTARG(lv) = SvREFCNT_inc(hv);
1530 if (PL_op->op_private & OPpLVAL_INTRO) {
1531 if (HvNAME(hv) && isGV(*svp))
1532 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1534 save_helem(hv, keysv, svp);
1536 else if (PL_op->op_private & OPpDEREF)
1537 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1539 sv = (svp ? *svp : &PL_sv_undef);
1540 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1541 * Pushing the magical RHS on to the stack is useless, since
1542 * that magic is soon destined to be misled by the local(),
1543 * and thus the later pp_sassign() will fail to mg_get() the
1544 * old value. This should also cure problems with delayed
1545 * mg_get()s. GSAR 98-07-03 */
1546 if (!lval && SvGMAGICAL(sv))
1547 sv = sv_mortalcopy(sv);
1555 register PERL_CONTEXT *cx;
1561 if (PL_op->op_flags & OPf_SPECIAL) {
1562 cx = &cxstack[cxstack_ix];
1563 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1568 gimme = OP_GIMME(PL_op, -1);
1570 if (cxstack_ix >= 0)
1571 gimme = cxstack[cxstack_ix].blk_gimme;
1577 if (gimme == G_VOID)
1579 else if (gimme == G_SCALAR) {
1582 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1585 *MARK = sv_mortalcopy(TOPs);
1588 *MARK = &PL_sv_undef;
1592 else if (gimme == G_ARRAY) {
1593 /* in case LEAVE wipes old return values */
1594 for (mark = newsp + 1; mark <= SP; mark++) {
1595 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1596 *mark = sv_mortalcopy(*mark);
1597 TAINT_NOT; /* Each item is independent */
1601 PL_curpm = newpm; /* Don't pop $1 et al till now */
1611 register PERL_CONTEXT *cx;
1617 cx = &cxstack[cxstack_ix];
1618 if (CxTYPE(cx) != CXt_LOOP)
1619 DIE(aTHX_ "panic: pp_iter");
1621 itersvp = CxITERVAR(cx);
1622 av = cx->blk_loop.iterary;
1623 if (SvTYPE(av) != SVt_PVAV) {
1624 /* iterate ($min .. $max) */
1625 if (cx->blk_loop.iterlval) {
1626 /* string increment */
1627 register SV* cur = cx->blk_loop.iterlval;
1629 char *max = SvPV((SV*)av, maxlen);
1630 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1631 #ifndef USE_THREADS /* don't risk potential race */
1632 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1633 /* safe to reuse old SV */
1634 sv_setsv(*itersvp, cur);
1639 /* we need a fresh SV every time so that loop body sees a
1640 * completely new SV for closures/references to work as
1642 SvREFCNT_dec(*itersvp);
1643 *itersvp = newSVsv(cur);
1645 if (strEQ(SvPVX(cur), max))
1646 sv_setiv(cur, 0); /* terminate next time */
1653 /* integer increment */
1654 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1657 #ifndef USE_THREADS /* don't risk potential race */
1658 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1659 /* safe to reuse old SV */
1660 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1665 /* we need a fresh SV every time so that loop body sees a
1666 * completely new SV for closures/references to work as they
1668 SvREFCNT_dec(*itersvp);
1669 *itersvp = newSViv(cx->blk_loop.iterix++);
1675 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1678 SvREFCNT_dec(*itersvp);
1680 if ((sv = SvMAGICAL(av)
1681 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1682 : AvARRAY(av)[++cx->blk_loop.iterix]))
1686 if (av != PL_curstack && SvIMMORTAL(sv)) {
1687 SV *lv = cx->blk_loop.iterlval;
1688 if (lv && SvREFCNT(lv) > 1) {
1693 SvREFCNT_dec(LvTARG(lv));
1695 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1696 sv_upgrade(lv, SVt_PVLV);
1698 sv_magic(lv, Nullsv, 'y', Nullch, 0);
1700 LvTARG(lv) = SvREFCNT_inc(av);
1701 LvTARGOFF(lv) = cx->blk_loop.iterix;
1702 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1706 *itersvp = SvREFCNT_inc(sv);
1713 register PMOP *pm = cPMOP;
1729 register REGEXP *rx = pm->op_pmregexp;
1731 int force_on_match = 0;
1732 I32 oldsave = PL_savestack_ix;
1734 /* known replacement string? */
1735 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1736 if (PL_op->op_flags & OPf_STACKED)
1742 if (SvREADONLY(TARG)
1743 || (SvTYPE(TARG) > SVt_PVLV
1744 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1745 DIE(aTHX_ PL_no_modify);
1748 s = SvPV(TARG, len);
1749 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1751 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1752 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1759 DIE(aTHX_ "panic: do_subst");
1762 maxiters = 2*(strend - s) + 10; /* We can match twice at each
1763 position, once with zero-length,
1764 second time with non-zero. */
1766 if (!rx->prelen && PL_curpm) {
1768 rx = pm->op_pmregexp;
1770 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1771 ? REXEC_COPY_STR : 0;
1773 r_flags |= REXEC_SCREAM;
1774 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1775 SAVEINT(PL_multiline);
1776 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1779 if (rx->reganch & RE_USE_INTUIT) {
1780 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1784 /* How to do it in subst? */
1785 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1787 && ((rx->reganch & ROPT_NOSCAN)
1788 || !((rx->reganch & RE_INTUIT_TAIL)
1789 && (r_flags & REXEC_SCREAM))))
1794 /* only replace once? */
1795 once = !(rpm->op_pmflags & PMf_GLOBAL);
1797 /* known replacement string? */
1798 c = dstr ? SvPV(dstr, clen) : Nullch;
1800 /* can do inplace substitution? */
1801 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1802 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1803 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1804 r_flags | REXEC_CHECKED))
1808 LEAVE_SCOPE(oldsave);
1811 if (force_on_match) {
1813 s = SvPV_force(TARG, len);
1818 SvSCREAM_off(TARG); /* disable possible screamer */
1820 rxtainted |= RX_MATCH_TAINTED(rx);
1821 m = orig + rx->startp[0];
1822 d = orig + rx->endp[0];
1824 if (m - s > strend - d) { /* faster to shorten from end */
1826 Copy(c, m, clen, char);
1831 Move(d, m, i, char);
1835 SvCUR_set(TARG, m - s);
1838 else if ((i = m - s)) { /* faster from front */
1846 Copy(c, m, clen, char);
1851 Copy(c, d, clen, char);
1856 TAINT_IF(rxtainted & 1);
1862 if (iters++ > maxiters)
1863 DIE(aTHX_ "Substitution loop");
1864 rxtainted |= RX_MATCH_TAINTED(rx);
1865 m = rx->startp[0] + orig;
1869 Move(s, d, i, char);
1873 Copy(c, d, clen, char);
1876 s = rx->endp[0] + orig;
1877 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
1879 /* don't match same null twice */
1880 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
1883 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1884 Move(s, d, i+1, char); /* include the NUL */
1886 TAINT_IF(rxtainted & 1);
1888 PUSHs(sv_2mortal(newSViv((I32)iters)));
1890 (void)SvPOK_only_UTF8(TARG);
1891 TAINT_IF(rxtainted);
1892 if (SvSMAGICAL(TARG)) {
1898 LEAVE_SCOPE(oldsave);
1902 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1903 r_flags | REXEC_CHECKED))
1905 if (force_on_match) {
1907 s = SvPV_force(TARG, len);
1910 rxtainted |= RX_MATCH_TAINTED(rx);
1911 dstr = NEWSV(25, len);
1912 sv_setpvn(dstr, m, s-m);
1915 register PERL_CONTEXT *cx;
1918 RETURNOP(cPMOP->op_pmreplroot);
1920 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1922 if (iters++ > maxiters)
1923 DIE(aTHX_ "Substitution loop");
1924 rxtainted |= RX_MATCH_TAINTED(rx);
1925 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
1930 strend = s + (strend - m);
1932 m = rx->startp[0] + orig;
1933 sv_catpvn(dstr, s, m-s);
1934 s = rx->endp[0] + orig;
1936 sv_catpvn(dstr, c, clen);
1939 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags));
1940 sv_catpvn(dstr, s, strend - s);
1942 (void)SvOOK_off(TARG);
1943 Safefree(SvPVX(TARG));
1944 SvPVX(TARG) = SvPVX(dstr);
1945 SvCUR_set(TARG, SvCUR(dstr));
1946 SvLEN_set(TARG, SvLEN(dstr));
1950 TAINT_IF(rxtainted & 1);
1952 PUSHs(sv_2mortal(newSViv((I32)iters)));
1954 (void)SvPOK_only(TARG);
1955 TAINT_IF(rxtainted);
1958 LEAVE_SCOPE(oldsave);
1967 LEAVE_SCOPE(oldsave);
1976 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
1977 ++*PL_markstack_ptr;
1978 LEAVE; /* exit inner scope */
1981 if (PL_stack_base + *PL_markstack_ptr > SP) {
1983 I32 gimme = GIMME_V;
1985 LEAVE; /* exit outer scope */
1986 (void)POPMARK; /* pop src */
1987 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1988 (void)POPMARK; /* pop dst */
1989 SP = PL_stack_base + POPMARK; /* pop original mark */
1990 if (gimme == G_SCALAR) {
1994 else if (gimme == G_ARRAY)
2001 ENTER; /* enter inner scope */
2004 src = PL_stack_base[*PL_markstack_ptr];
2008 RETURNOP(cLOGOP->op_other);
2019 register PERL_CONTEXT *cx;
2025 if (gimme == G_SCALAR) {
2028 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2030 *MARK = SvREFCNT_inc(TOPs);
2035 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2037 *MARK = sv_mortalcopy(sv);
2042 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2046 *MARK = &PL_sv_undef;
2050 else if (gimme == G_ARRAY) {
2051 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2052 if (!SvTEMP(*MARK)) {
2053 *MARK = sv_mortalcopy(*MARK);
2054 TAINT_NOT; /* Each item is independent */
2060 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2061 PL_curpm = newpm; /* ... and pop $1 et al */
2065 return pop_return();
2068 /* This duplicates the above code because the above code must not
2069 * get any slower by more conditions */
2077 register PERL_CONTEXT *cx;
2084 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2085 /* We are an argument to a function or grep().
2086 * This kind of lvalueness was legal before lvalue
2087 * subroutines too, so be backward compatible:
2088 * cannot report errors. */
2090 /* Scalar context *is* possible, on the LHS of -> only,
2091 * as in f()->meth(). But this is not an lvalue. */
2092 if (gimme == G_SCALAR)
2094 if (gimme == G_ARRAY) {
2095 if (!CvLVALUE(cx->blk_sub.cv))
2096 goto temporise_array;
2097 EXTEND_MORTAL(SP - newsp);
2098 for (mark = newsp + 1; mark <= SP; mark++) {
2101 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2102 *mark = sv_mortalcopy(*mark);
2104 /* Can be a localized value subject to deletion. */
2105 PL_tmps_stack[++PL_tmps_ix] = *mark;
2106 (void)SvREFCNT_inc(*mark);
2111 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2112 /* Here we go for robustness, not for speed, so we change all
2113 * the refcounts so the caller gets a live guy. Cannot set
2114 * TEMP, so sv_2mortal is out of question. */
2115 if (!CvLVALUE(cx->blk_sub.cv)) {
2120 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2122 if (gimme == G_SCALAR) {
2126 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2131 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2132 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2134 else { /* Can be a localized value
2135 * subject to deletion. */
2136 PL_tmps_stack[++PL_tmps_ix] = *mark;
2137 (void)SvREFCNT_inc(*mark);
2140 else { /* Should not happen? */
2145 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2146 (MARK > SP ? "Empty array" : "Array"));
2150 else if (gimme == G_ARRAY) {
2151 EXTEND_MORTAL(SP - newsp);
2152 for (mark = newsp + 1; mark <= SP; mark++) {
2153 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2154 /* Might be flattened array after $#array = */
2160 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2161 (*mark != &PL_sv_undef)
2163 ? "a readonly value" : "a temporary")
2164 : "an uninitialized value");
2167 /* Can be a localized value subject to deletion. */
2168 PL_tmps_stack[++PL_tmps_ix] = *mark;
2169 (void)SvREFCNT_inc(*mark);
2175 if (gimme == G_SCALAR) {
2179 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2181 *MARK = SvREFCNT_inc(TOPs);
2186 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2188 *MARK = sv_mortalcopy(sv);
2193 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2197 *MARK = &PL_sv_undef;
2201 else if (gimme == G_ARRAY) {
2203 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2204 if (!SvTEMP(*MARK)) {
2205 *MARK = sv_mortalcopy(*MARK);
2206 TAINT_NOT; /* Each item is independent */
2213 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2214 PL_curpm = newpm; /* ... and pop $1 et al */
2218 return pop_return();
2223 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2226 SV *dbsv = GvSV(PL_DBsub);
2228 if (!PERLDB_SUB_NN) {
2232 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2233 || strEQ(GvNAME(gv), "END")
2234 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2235 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2236 && (gv = (GV*)*svp) ))) {
2237 /* Use GV from the stack as a fallback. */
2238 /* GV is potentially non-unique, or contain different CV. */
2239 sv_setsv(dbsv, newRV((SV*)cv));
2242 gv_efullname3(dbsv, gv, Nullch);
2246 (void)SvUPGRADE(dbsv, SVt_PVIV);
2247 (void)SvIOK_on(dbsv);
2248 SAVEIV(SvIVX(dbsv));
2249 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2253 PL_curcopdb = PL_curcop;
2254 cv = GvCV(PL_DBsub);
2264 register PERL_CONTEXT *cx;
2266 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2269 DIE(aTHX_ "Not a CODE reference");
2270 switch (SvTYPE(sv)) {
2276 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2278 SP = PL_stack_base + POPMARK;
2281 if (SvGMAGICAL(sv)) {
2283 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2286 sym = SvPV(sv, n_a);
2288 DIE(aTHX_ PL_no_usym, "a subroutine");
2289 if (PL_op->op_private & HINT_STRICT_REFS)
2290 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2291 cv = get_cv(sym, TRUE);
2295 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2296 tryAMAGICunDEREF(to_cv);
2299 if (SvTYPE(cv) == SVt_PVCV)
2304 DIE(aTHX_ "Not a CODE reference");
2309 if (!(cv = GvCVu((GV*)sv)))
2310 cv = sv_2cv(sv, &stash, &gv, FALSE);
2323 if (!CvROOT(cv) && !CvXSUB(cv)) {
2327 /* anonymous or undef'd function leaves us no recourse */
2328 if (CvANON(cv) || !(gv = CvGV(cv)))
2329 DIE(aTHX_ "Undefined subroutine called");
2331 /* autoloaded stub? */
2332 if (cv != GvCV(gv)) {
2335 /* should call AUTOLOAD now? */
2338 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2345 sub_name = sv_newmortal();
2346 gv_efullname3(sub_name, gv, Nullch);
2347 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2351 DIE(aTHX_ "Not a CODE reference");
2356 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2357 cv = get_db_sub(&sv, cv);
2359 DIE(aTHX_ "No DBsub routine");
2364 * First we need to check if the sub or method requires locking.
2365 * If so, we gain a lock on the CV, the first argument or the
2366 * stash (for static methods), as appropriate. This has to be
2367 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2368 * reschedule by returning a new op.
2370 MUTEX_LOCK(CvMUTEXP(cv));
2371 if (CvFLAGS(cv) & CVf_LOCKED) {
2373 if (CvFLAGS(cv) & CVf_METHOD) {
2374 if (SP > PL_stack_base + TOPMARK)
2375 sv = *(PL_stack_base + TOPMARK + 1);
2377 AV *av = (AV*)PL_curpad[0];
2378 if (hasargs || !av || AvFILLp(av) < 0
2379 || !(sv = AvARRAY(av)[0]))
2381 MUTEX_UNLOCK(CvMUTEXP(cv));
2382 DIE(aTHX_ "no argument for locked method call");
2389 char *stashname = SvPV(sv, len);
2390 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2396 MUTEX_UNLOCK(CvMUTEXP(cv));
2397 mg = condpair_magic(sv);
2398 MUTEX_LOCK(MgMUTEXP(mg));
2399 if (MgOWNER(mg) == thr)
2400 MUTEX_UNLOCK(MgMUTEXP(mg));
2403 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2405 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2407 MUTEX_UNLOCK(MgMUTEXP(mg));
2408 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2410 MUTEX_LOCK(CvMUTEXP(cv));
2413 * Now we have permission to enter the sub, we must distinguish
2414 * four cases. (0) It's an XSUB (in which case we don't care
2415 * about ownership); (1) it's ours already (and we're recursing);
2416 * (2) it's free (but we may already be using a cached clone);
2417 * (3) another thread owns it. Case (1) is easy: we just use it.
2418 * Case (2) means we look for a clone--if we have one, use it
2419 * otherwise grab ownership of cv. Case (3) means we look for a
2420 * clone (for non-XSUBs) and have to create one if we don't
2422 * Why look for a clone in case (2) when we could just grab
2423 * ownership of cv straight away? Well, we could be recursing,
2424 * i.e. we originally tried to enter cv while another thread
2425 * owned it (hence we used a clone) but it has been freed up
2426 * and we're now recursing into it. It may or may not be "better"
2427 * to use the clone but at least CvDEPTH can be trusted.
2429 if (CvOWNER(cv) == thr || CvXSUB(cv))
2430 MUTEX_UNLOCK(CvMUTEXP(cv));
2432 /* Case (2) or (3) */
2436 * XXX Might it be better to release CvMUTEXP(cv) while we
2437 * do the hv_fetch? We might find someone has pinched it
2438 * when we look again, in which case we would be in case
2439 * (3) instead of (2) so we'd have to clone. Would the fact
2440 * that we released the mutex more quickly make up for this?
2442 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2444 /* We already have a clone to use */
2445 MUTEX_UNLOCK(CvMUTEXP(cv));
2447 DEBUG_S(PerlIO_printf(Perl_debug_log,
2448 "entersub: %p already has clone %p:%s\n",
2449 thr, cv, SvPEEK((SV*)cv)));
2452 if (CvDEPTH(cv) == 0)
2453 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2456 /* (2) => grab ownership of cv. (3) => make clone */
2460 MUTEX_UNLOCK(CvMUTEXP(cv));
2461 DEBUG_S(PerlIO_printf(Perl_debug_log,
2462 "entersub: %p grabbing %p:%s in stash %s\n",
2463 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2464 HvNAME(CvSTASH(cv)) : "(none)"));
2467 /* Make a new clone. */
2469 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2470 MUTEX_UNLOCK(CvMUTEXP(cv));
2471 DEBUG_S((PerlIO_printf(Perl_debug_log,
2472 "entersub: %p cloning %p:%s\n",
2473 thr, cv, SvPEEK((SV*)cv))));
2475 * We're creating a new clone so there's no race
2476 * between the original MUTEX_UNLOCK and the
2477 * SvREFCNT_inc since no one will be trying to undef
2478 * it out from underneath us. At least, I don't think
2481 clonecv = cv_clone(cv);
2482 SvREFCNT_dec(cv); /* finished with this */
2483 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2484 CvOWNER(clonecv) = thr;
2488 DEBUG_S(if (CvDEPTH(cv) != 0)
2489 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2491 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2494 #endif /* USE_THREADS */
2497 #ifdef PERL_XSUB_OLDSTYLE
2498 if (CvOLDSTYLE(cv)) {
2499 I32 (*fp3)(int,int,int);
2501 register I32 items = SP - MARK;
2502 /* We dont worry to copy from @_. */
2507 PL_stack_sp = mark + 1;
2508 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2509 items = (*fp3)(CvXSUBANY(cv).any_i32,
2510 MARK - PL_stack_base + 1,
2512 PL_stack_sp = PL_stack_base + items;
2515 #endif /* PERL_XSUB_OLDSTYLE */
2517 I32 markix = TOPMARK;
2522 /* Need to copy @_ to stack. Alternative may be to
2523 * switch stack to @_, and copy return values
2524 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2528 av = (AV*)PL_curpad[0];
2530 av = GvAV(PL_defgv);
2531 #endif /* USE_THREADS */
2532 items = AvFILLp(av) + 1; /* @_ is not tieable */
2535 /* Mark is at the end of the stack. */
2537 Copy(AvARRAY(av), SP + 1, items, SV*);
2542 /* We assume first XSUB in &DB::sub is the called one. */
2544 SAVEVPTR(PL_curcop);
2545 PL_curcop = PL_curcopdb;
2548 /* Do we need to open block here? XXXX */
2549 (void)(*CvXSUB(cv))(aTHXo_ cv);
2551 /* Enforce some sanity in scalar context. */
2552 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2553 if (markix > PL_stack_sp - PL_stack_base)
2554 *(PL_stack_base + markix) = &PL_sv_undef;
2556 *(PL_stack_base + markix) = *PL_stack_sp;
2557 PL_stack_sp = PL_stack_base + markix;
2565 register I32 items = SP - MARK;
2566 AV* padlist = CvPADLIST(cv);
2567 SV** svp = AvARRAY(padlist);
2568 push_return(PL_op->op_next);
2569 PUSHBLOCK(cx, CXt_SUB, MARK);
2572 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2573 * that eval'' ops within this sub know the correct lexical space.
2574 * Owing the speed considerations, we choose to search for the cv
2575 * in doeval() instead.
2577 if (CvDEPTH(cv) < 2)
2578 (void)SvREFCNT_inc(cv);
2579 else { /* save temporaries on recursion? */
2580 PERL_STACK_OVERFLOW_CHECK();
2581 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2583 AV *newpad = newAV();
2584 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2585 I32 ix = AvFILLp((AV*)svp[1]);
2586 I32 names_fill = AvFILLp((AV*)svp[0]);
2587 svp = AvARRAY(svp[0]);
2588 for ( ;ix > 0; ix--) {
2589 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2590 char *name = SvPVX(svp[ix]);
2591 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2592 || *name == '&') /* anonymous code? */
2594 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2596 else { /* our own lexical */
2598 av_store(newpad, ix, sv = (SV*)newAV());
2599 else if (*name == '%')
2600 av_store(newpad, ix, sv = (SV*)newHV());
2602 av_store(newpad, ix, sv = NEWSV(0,0));
2606 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2607 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2610 av_store(newpad, ix, sv = NEWSV(0,0));
2614 av = newAV(); /* will be @_ */
2616 av_store(newpad, 0, (SV*)av);
2617 AvFLAGS(av) = AVf_REIFY;
2618 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2619 AvFILLp(padlist) = CvDEPTH(cv);
2620 svp = AvARRAY(padlist);
2625 AV* av = (AV*)PL_curpad[0];
2627 items = AvFILLp(av) + 1;
2629 /* Mark is at the end of the stack. */
2631 Copy(AvARRAY(av), SP + 1, items, SV*);
2636 #endif /* USE_THREADS */
2637 SAVEVPTR(PL_curpad);
2638 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2641 #endif /* USE_THREADS */
2647 DEBUG_S(PerlIO_printf(Perl_debug_log,
2648 "%p entersub preparing @_\n", thr));
2650 av = (AV*)PL_curpad[0];
2652 /* @_ is normally not REAL--this should only ever
2653 * happen when DB::sub() calls things that modify @_ */
2659 cx->blk_sub.savearray = GvAV(PL_defgv);
2660 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2661 #endif /* USE_THREADS */
2662 cx->blk_sub.oldcurpad = PL_curpad;
2663 cx->blk_sub.argarray = av;
2666 if (items > AvMAX(av) + 1) {
2668 if (AvARRAY(av) != ary) {
2669 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2670 SvPVX(av) = (char*)ary;
2672 if (items > AvMAX(av) + 1) {
2673 AvMAX(av) = items - 1;
2674 Renew(ary,items,SV*);
2676 SvPVX(av) = (char*)ary;
2679 Copy(MARK,AvARRAY(av),items,SV*);
2680 AvFILLp(av) = items - 1;
2688 /* warning must come *after* we fully set up the context
2689 * stuff so that __WARN__ handlers can safely dounwind()
2692 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2693 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2694 sub_crush_depth(cv);
2696 DEBUG_S(PerlIO_printf(Perl_debug_log,
2697 "%p entersub returning %p\n", thr, CvSTART(cv)));
2699 RETURNOP(CvSTART(cv));
2704 Perl_sub_crush_depth(pTHX_ CV *cv)
2707 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2709 SV* tmpstr = sv_newmortal();
2710 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2711 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2722 U32 lval = PL_op->op_flags & OPf_MOD;
2723 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2727 elem -= PL_curcop->cop_arybase;
2728 if (SvTYPE(av) != SVt_PVAV)
2730 svp = av_fetch(av, elem, lval && !defer);
2732 if (!svp || *svp == &PL_sv_undef) {
2735 DIE(aTHX_ PL_no_aelem, elem);
2736 lv = sv_newmortal();
2737 sv_upgrade(lv, SVt_PVLV);
2739 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2740 LvTARG(lv) = SvREFCNT_inc(av);
2741 LvTARGOFF(lv) = elem;
2746 if (PL_op->op_private & OPpLVAL_INTRO)
2747 save_aelem(av, elem, svp);
2748 else if (PL_op->op_private & OPpDEREF)
2749 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2751 sv = (svp ? *svp : &PL_sv_undef);
2752 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2753 sv = sv_mortalcopy(sv);
2759 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2765 Perl_croak(aTHX_ PL_no_modify);
2766 if (SvTYPE(sv) < SVt_RV)
2767 sv_upgrade(sv, SVt_RV);
2768 else if (SvTYPE(sv) >= SVt_PV) {
2769 (void)SvOOK_off(sv);
2770 Safefree(SvPVX(sv));
2771 SvLEN(sv) = SvCUR(sv) = 0;
2775 SvRV(sv) = NEWSV(355,0);
2778 SvRV(sv) = (SV*)newAV();
2781 SvRV(sv) = (SV*)newHV();
2796 if (SvTYPE(rsv) == SVt_PVCV) {
2802 SETs(method_common(sv, Null(U32*)));
2809 SV* sv = cSVOP->op_sv;
2810 U32 hash = SvUVX(sv);
2812 XPUSHs(method_common(sv, &hash));
2817 S_method_common(pTHX_ SV* meth, U32* hashp)
2828 name = SvPV(meth, namelen);
2829 sv = *(PL_stack_base + TOPMARK + 1);
2840 !(packname = SvPV(sv, packlen)) ||
2841 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2842 !(ob=(SV*)GvIO(iogv)))
2845 ((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
2846 ? !isIDFIRST_utf8((U8*)packname)
2847 : !isIDFIRST(*packname)
2850 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2851 SvOK(sv) ? "without a package or object reference"
2852 : "on an undefined value");
2854 stash = gv_stashpvn(packname, packlen, TRUE);
2857 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2860 if (!ob || !(SvOBJECT(ob)
2861 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2864 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2868 stash = SvSTASH(ob);
2871 /* shortcut for simple names */
2873 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2875 gv = (GV*)HeVAL(he);
2876 if (isGV(gv) && GvCV(gv) &&
2877 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2878 return (SV*)GvCV(gv);
2882 gv = gv_fetchmethod(stash, name);
2889 for (p = name; *p; p++) {
2891 sep = p, leaf = p + 1;
2892 else if (*p == ':' && *(p + 1) == ':')
2893 sep = p, leaf = p + 2;
2895 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
2896 packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
2897 packlen = strlen(packname);
2901 packlen = sep - name;
2903 gv = gv_fetchpv(packname, 0, SVt_PVHV);
2904 if (gv && isGV(gv)) {
2906 "Can't locate object method \"%s\" via package \"%s\"",
2911 "Can't locate object method \"%s\" via package \"%s\""
2912 " (perhaps you forgot to load \"%s\"?)",
2913 leaf, packname, packname);
2916 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
2921 unset_cvowner(pTHXo_ void *cvarg)
2923 register CV* cv = (CV *) cvarg;
2926 #endif /* DEBUGGING */
2928 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
2929 thr, cv, SvPEEK((SV*)cv))));
2930 MUTEX_LOCK(CvMUTEXP(cv));
2931 DEBUG_S(if (CvDEPTH(cv) != 0)
2932 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2934 assert(thr == CvOWNER(cv));
2936 MUTEX_UNLOCK(CvMUTEXP(cv));
2939 #endif /* USE_THREADS */