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);
79 if (SvUTF8(TOPs) && !IN_BYTE)
88 XPUSHs((SV*)cGVOP_gv);
99 RETURNOP(cLOGOP->op_other);
107 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
109 temp = left; left = right; right = temp;
111 if (PL_tainting && PL_tainted && !SvTAINTED(left))
113 SvSetMagicSV(right, left);
122 RETURNOP(cLOGOP->op_other);
124 RETURNOP(cLOGOP->op_next);
130 TAINT_NOT; /* Each statement is presumed innocent */
131 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
133 oldsave = PL_scopestack[PL_scopestack_ix - 1];
134 LEAVE_SCOPE(oldsave);
140 djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
143 STRLEN len, llen, rlen;
148 r = (U8*)SvPV(right,rlen);
151 l = (U8*)SvPV(left,llen);
152 else if (SvGMAGICAL(left))
155 left_utf8 = DO_UTF8(left);
156 right_utf8 = DO_UTF8(right);
158 if (!left_utf8 && !right_utf8 && SvUTF8(TARG)) {
162 if (left_utf8 != right_utf8 && !IN_BYTE) {
163 if (TARG == right && !right_utf8) {
164 sv_utf8_upgrade(TARG); /* Now straight binary copy */
168 /* Set TARG to PV(left), then add right */
173 /* Take a copy since we're about to overwrite TARG */
174 olds = s = (U8*)savepvn((char*)s, len);
176 if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) {
177 if (SvREADONLY(left))
178 left = sv_2mortal(newSVsv(left));
180 sv_setpv(left, ""); /* Suppress warning. */
183 sv_setpvn(TARG, (char*)l, llen);
186 sv_utf8_upgrade(TARG);
188 /* Extend TARG to length of right (s) */
189 targlen = SvCUR(TARG) + len;
191 /* plus one for each hi-byte char if we have to upgrade */
192 for (c = s; c < s + len; c++) {
193 if (UTF8_IS_CONTINUED(*c))
197 SvGROW(TARG, targlen+1);
198 /* And now copy, maybe upgrading right to UTF8 on the fly */
200 Copy(s, SvEND(TARG), len, U8);
202 for (c = (U8*)SvEND(TARG); len--; s++)
203 c = uv_to_utf8(c, *s);
205 SvCUR_set(TARG, targlen);
216 sv_insert(TARG, 0, 0, (char*)l, llen);
220 sv_setpvn(TARG, (char *)l, llen);
222 else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG)
223 sv_setpv(TARG, ""); /* Suppress warning. */
226 #if defined(PERL_Y2KWARN)
227 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
229 char *s = SvPV(TARG,n);
230 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
231 && (n == 2 || !isDIGIT(s[n-3])))
233 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
234 "about to append an integer to '19'");
238 sv_catpvn(TARG, (char *)s, len);
241 sv_setpvn(TARG, (char *)s, len); /* suppress warning */
242 if (left_utf8 && !IN_BYTE)
253 if (PL_op->op_flags & OPf_MOD) {
254 if (PL_op->op_private & OPpLVAL_INTRO)
255 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
256 else if (PL_op->op_private & OPpDEREF) {
258 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
267 tryAMAGICunTARGET(iter, 0);
268 PL_last_in_gv = (GV*)(*PL_stack_sp--);
269 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
270 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
271 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
274 XPUSHs((SV*)PL_last_in_gv);
277 PL_last_in_gv = (GV*)(*PL_stack_sp--);
280 return do_readline();
285 djSP; tryAMAGICbinSET(eq,0);
286 #ifdef PERL_PRESERVE_IVUV
289 /* Unless the left argument is integer in range we are going to have to
290 use NV maths. Hence only attempt to coerce the right argument if
291 we know the left is integer. */
294 bool auvok = SvUOK(TOPm1s);
295 bool buvok = SvUOK(TOPs);
297 if (!auvok && !buvok) { /* ## IV == IV ## */
298 IV aiv = SvIVX(TOPm1s);
299 IV biv = SvIVX(TOPs);
302 SETs(boolSV(aiv == biv));
305 if (auvok && buvok) { /* ## UV == UV ## */
306 UV auv = SvUVX(TOPm1s);
307 UV buv = SvUVX(TOPs);
310 SETs(boolSV(auv == buv));
313 { /* ## Mixed IV,UV ## */
317 /* == is commutative so swap if needed (save code) */
319 /* swap. top of stack (b) is the iv */
323 /* As (a) is a UV, it's >0, so it cannot be == */
332 /* As (b) is a UV, it's >0, so it cannot be == */
336 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
338 /* we know iv is >= 0 */
339 if (uv > (UV) IV_MAX) {
343 SETs(boolSV((UV)iv == uv));
351 SETs(boolSV(TOPn == value));
359 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
360 DIE(aTHX_ PL_no_modify);
361 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
362 SvIVX(TOPs) != IV_MAX)
365 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
367 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
380 RETURNOP(cLOGOP->op_other);
386 djSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
387 useleft = USE_LEFT(TOPm1s);
388 #ifdef PERL_PRESERVE_IVUV
389 /* We must see if we can perform the addition with integers if possible,
390 as the integer code detects overflow while the NV code doesn't.
391 If either argument hasn't had a numeric conversion yet attempt to get
392 the IV. It's important to do this now, rather than just assuming that
393 it's not IOK as a PV of "9223372036854775806" may not take well to NV
394 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
395 integer in case the second argument is IV=9223372036854775806
396 We can (now) rely on sv_2iv to do the right thing, only setting the
397 public IOK flag if the value in the NV (or PV) slot is truly integer.
399 A side effect is that this also aggressively prefers integer maths over
400 fp maths for integer values. */
403 /* Unless the left argument is integer in range we are going to have to
404 use NV maths. Hence only attempt to coerce the right argument if
405 we know the left is integer. */
407 /* left operand is undef, treat as zero. + 0 is identity. */
409 dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
418 /* Left operand is defined, so is it IV? */
421 bool auvok = SvUOK(TOPm1s);
422 bool buvok = SvUOK(TOPs);
424 if (!auvok && !buvok) { /* ## IV + IV ## */
425 IV aiv = SvIVX(TOPm1s);
426 IV biv = SvIVX(TOPs);
427 IV result = aiv + biv;
429 if (biv >= 0 ? (result >= aiv) : (result < aiv)) {
434 if (biv >=0 && aiv >= 0) {
435 UV result = (UV)aiv + (UV)biv;
436 /* UV + UV can only get bigger... */
437 if (result >= (UV) aiv) {
443 /* Overflow, drop through to NVs (beyond next if () else ) */
444 } else if (auvok && buvok) { /* ## UV + UV ## */
445 UV auv = SvUVX(TOPm1s);
446 UV buv = SvUVX(TOPs);
447 UV result = auv + buv;
453 /* Overflow, drop through to NVs (beyond next if () else ) */
454 } else { /* ## Mixed IV,UV ## */
458 /* addition is commutative so swap if needed (save code) */
468 UV result = (UV)aiv + buv;
474 } else if (buv > (UV) IV_MAX) {
475 /* assuming 2s complement means that IV_MIN == -IV_MIN,
476 and (UV)-IV_MIN *is* the value -IV_MIN (or IV_MAX + 1)
477 as buv > IV_MAX, it is >= (IV_MAX + 1), and therefore
478 as the value we can be subtracting from it only lies in
479 the range (-IV_MIN to -1) it can't overflow a UV */
481 SETu( buv - (UV)-aiv );
484 IV result = (IV) buv + aiv;
485 /* aiv < 0 so it must get smaller. */
486 if (result < (IV) buv) {
492 } /* end of IV+IV / UV+UV / mixed */
499 /* left operand is undef, treat as zero. + 0.0 is identity. */
503 SETn( value + TOPn );
511 AV *av = GvAV(cGVOP_gv);
512 U32 lval = PL_op->op_flags & OPf_MOD;
513 SV** svp = av_fetch(av, PL_op->op_private, lval);
514 SV *sv = (svp ? *svp : &PL_sv_undef);
516 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
517 sv = sv_mortalcopy(sv);
524 djSP; dMARK; dTARGET;
526 do_join(TARG, *MARK, MARK, SP);
537 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
538 * will be enough to hold an OP*.
540 SV* sv = sv_newmortal();
541 sv_upgrade(sv, SVt_PVLV);
543 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
551 /* Oversized hot code. */
555 djSP; dMARK; dORIGMARK;
562 if (PL_op->op_flags & OPf_STACKED)
566 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
568 if (MARK == ORIGMARK) {
569 /* If using default handle then we need to make space to
570 * pass object as 1st arg, so move other args up ...
574 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
578 *MARK = SvTIED_obj((SV*)gv, mg);
581 call_method("PRINT", G_SCALAR);
589 if (!(io = GvIO(gv))) {
590 if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
592 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
593 report_evil_fh(gv, io, PL_op->op_type);
594 SETERRNO(EBADF,RMS$_IFI);
597 else if (!(fp = IoOFP(io))) {
598 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
600 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
601 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
602 report_evil_fh(gv, io, PL_op->op_type);
604 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
609 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
611 if (!do_print(*MARK, fp))
615 if (!do_print(PL_ofs_sv, fp)) { /* $, */
624 if (!do_print(*MARK, fp))
632 if (PL_ors_sv && SvOK(PL_ors_sv))
633 if (!do_print(PL_ors_sv, fp)) /* $\ */
636 if (IoFLAGS(io) & IOf_FLUSH)
637 if (PerlIO_flush(fp) == EOF)
658 tryAMAGICunDEREF(to_av);
661 if (SvTYPE(av) != SVt_PVAV)
662 DIE(aTHX_ "Not an ARRAY reference");
663 if (PL_op->op_flags & OPf_REF) {
669 if (SvTYPE(sv) == SVt_PVAV) {
671 if (PL_op->op_flags & OPf_REF) {
679 if (SvTYPE(sv) != SVt_PVGV) {
683 if (SvGMAGICAL(sv)) {
689 if (PL_op->op_flags & OPf_REF ||
690 PL_op->op_private & HINT_STRICT_REFS)
691 DIE(aTHX_ PL_no_usym, "an ARRAY");
692 if (ckWARN(WARN_UNINITIALIZED))
694 if (GIMME == G_ARRAY) {
701 if ((PL_op->op_flags & OPf_SPECIAL) &&
702 !(PL_op->op_flags & OPf_MOD))
704 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
706 && (!is_gv_magical(sym,len,0)
707 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
713 if (PL_op->op_private & HINT_STRICT_REFS)
714 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
715 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
722 if (PL_op->op_private & OPpLVAL_INTRO)
724 if (PL_op->op_flags & OPf_REF) {
731 if (GIMME == G_ARRAY) {
732 I32 maxarg = AvFILL(av) + 1;
733 (void)POPs; /* XXXX May be optimized away? */
735 if (SvRMAGICAL(av)) {
737 for (i=0; i < maxarg; i++) {
738 SV **svp = av_fetch(av, i, FALSE);
739 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
743 Copy(AvARRAY(av), SP+1, maxarg, SV*);
749 I32 maxarg = AvFILL(av) + 1;
762 tryAMAGICunDEREF(to_hv);
765 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
766 DIE(aTHX_ "Not a HASH reference");
767 if (PL_op->op_flags & OPf_REF) {
773 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
775 if (PL_op->op_flags & OPf_REF) {
783 if (SvTYPE(sv) != SVt_PVGV) {
787 if (SvGMAGICAL(sv)) {
793 if (PL_op->op_flags & OPf_REF ||
794 PL_op->op_private & HINT_STRICT_REFS)
795 DIE(aTHX_ PL_no_usym, "a HASH");
796 if (ckWARN(WARN_UNINITIALIZED))
798 if (GIMME == G_ARRAY) {
805 if ((PL_op->op_flags & OPf_SPECIAL) &&
806 !(PL_op->op_flags & OPf_MOD))
808 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
810 && (!is_gv_magical(sym,len,0)
811 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
817 if (PL_op->op_private & HINT_STRICT_REFS)
818 DIE(aTHX_ PL_no_symref, sym, "a HASH");
819 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
826 if (PL_op->op_private & OPpLVAL_INTRO)
828 if (PL_op->op_flags & OPf_REF) {
835 if (GIMME == G_ARRAY) { /* array wanted */
836 *PL_stack_sp = (SV*)hv;
841 if (SvTYPE(hv) == SVt_PVAV)
842 hv = avhv_keys((AV*)hv);
844 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
845 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
855 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
861 leftop = ((BINOP*)PL_op)->op_last;
863 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
864 leftop = ((LISTOP*)leftop)->op_first;
866 /* Skip PUSHMARK and each element already assigned to. */
867 for (i = lelem - firstlelem; i > 0; i--) {
868 leftop = leftop->op_sibling;
871 if (leftop->op_type != OP_RV2HV)
876 av_fill(ary, 0); /* clear all but the fields hash */
877 if (lastrelem >= relem) {
878 while (relem < lastrelem) { /* gobble up all the rest */
882 /* Avoid a memory leak when avhv_store_ent dies. */
883 tmpstr = sv_newmortal();
884 sv_setsv(tmpstr,relem[1]); /* value */
886 if (avhv_store_ent(ary,relem[0],tmpstr,0))
887 (void)SvREFCNT_inc(tmpstr);
888 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
894 if (relem == lastrelem)
900 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
904 if (ckWARN(WARN_MISC)) {
905 if (relem == firstrelem &&
907 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
908 SvTYPE(SvRV(*relem)) == SVt_PVHV))
910 Perl_warner(aTHX_ WARN_MISC,
911 "Reference found where even-sized list expected");
914 Perl_warner(aTHX_ WARN_MISC,
915 "Odd number of elements in hash assignment");
917 if (SvTYPE(hash) == SVt_PVAV) {
919 tmpstr = sv_newmortal();
920 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
921 (void)SvREFCNT_inc(tmpstr);
922 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
927 tmpstr = NEWSV(29,0);
928 didstore = hv_store_ent(hash,*relem,tmpstr,0);
929 if (SvMAGICAL(hash)) {
930 if (SvSMAGICAL(tmpstr))
943 SV **lastlelem = PL_stack_sp;
944 SV **lastrelem = PL_stack_base + POPMARK;
945 SV **firstrelem = PL_stack_base + POPMARK + 1;
946 SV **firstlelem = lastrelem + 1;
959 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
961 /* If there's a common identifier on both sides we have to take
962 * special care that assigning the identifier on the left doesn't
963 * clobber a value on the right that's used later in the list.
965 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
966 EXTEND_MORTAL(lastrelem - firstrelem + 1);
967 for (relem = firstrelem; relem <= lastrelem; relem++) {
970 TAINT_NOT; /* Each item is independent */
971 *relem = sv_mortalcopy(sv);
981 while (lelem <= lastlelem) {
982 TAINT_NOT; /* Each item stands on its own, taintwise. */
984 switch (SvTYPE(sv)) {
987 magic = SvMAGICAL(ary) != 0;
988 if (PL_op->op_private & OPpASSIGN_HASH) {
989 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
995 do_oddball((HV*)ary, relem, firstrelem);
997 relem = lastrelem + 1;
1002 av_extend(ary, lastrelem - relem);
1004 while (relem <= lastrelem) { /* gobble up all the rest */
1008 sv_setsv(sv,*relem);
1010 didstore = av_store(ary,i++,sv);
1020 case SVt_PVHV: { /* normal hash */
1024 magic = SvMAGICAL(hash) != 0;
1027 while (relem < lastrelem) { /* gobble up all the rest */
1032 sv = &PL_sv_no, relem++;
1033 tmpstr = NEWSV(29,0);
1035 sv_setsv(tmpstr,*relem); /* value */
1036 *(relem++) = tmpstr;
1037 didstore = hv_store_ent(hash,sv,tmpstr,0);
1039 if (SvSMAGICAL(tmpstr))
1046 if (relem == lastrelem) {
1047 do_oddball(hash, relem, firstrelem);
1053 if (SvIMMORTAL(sv)) {
1054 if (relem <= lastrelem)
1058 if (relem <= lastrelem) {
1059 sv_setsv(sv, *relem);
1063 sv_setsv(sv, &PL_sv_undef);
1068 if (PL_delaymagic & ~DM_DELAY) {
1069 if (PL_delaymagic & DM_UID) {
1070 #ifdef HAS_SETRESUID
1071 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1073 # ifdef HAS_SETREUID
1074 (void)setreuid(PL_uid,PL_euid);
1077 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1078 (void)setruid(PL_uid);
1079 PL_delaymagic &= ~DM_RUID;
1081 # endif /* HAS_SETRUID */
1083 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1084 (void)seteuid(PL_uid);
1085 PL_delaymagic &= ~DM_EUID;
1087 # endif /* HAS_SETEUID */
1088 if (PL_delaymagic & DM_UID) {
1089 if (PL_uid != PL_euid)
1090 DIE(aTHX_ "No setreuid available");
1091 (void)PerlProc_setuid(PL_uid);
1093 # endif /* HAS_SETREUID */
1094 #endif /* HAS_SETRESUID */
1095 PL_uid = PerlProc_getuid();
1096 PL_euid = PerlProc_geteuid();
1098 if (PL_delaymagic & DM_GID) {
1099 #ifdef HAS_SETRESGID
1100 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1102 # ifdef HAS_SETREGID
1103 (void)setregid(PL_gid,PL_egid);
1106 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1107 (void)setrgid(PL_gid);
1108 PL_delaymagic &= ~DM_RGID;
1110 # endif /* HAS_SETRGID */
1112 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1113 (void)setegid(PL_gid);
1114 PL_delaymagic &= ~DM_EGID;
1116 # endif /* HAS_SETEGID */
1117 if (PL_delaymagic & DM_GID) {
1118 if (PL_gid != PL_egid)
1119 DIE(aTHX_ "No setregid available");
1120 (void)PerlProc_setgid(PL_gid);
1122 # endif /* HAS_SETREGID */
1123 #endif /* HAS_SETRESGID */
1124 PL_gid = PerlProc_getgid();
1125 PL_egid = PerlProc_getegid();
1127 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1132 if (gimme == G_VOID)
1133 SP = firstrelem - 1;
1134 else if (gimme == G_SCALAR) {
1137 SETi(lastrelem - firstrelem + 1);
1143 SP = firstrelem + (lastlelem - firstlelem);
1144 lelem = firstlelem + (relem - firstrelem);
1146 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1154 register PMOP *pm = cPMOP;
1155 SV *rv = sv_newmortal();
1156 SV *sv = newSVrv(rv, "Regexp");
1157 sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
1164 register PMOP *pm = cPMOP;
1169 I32 r_flags = REXEC_CHECKED;
1170 char *truebase; /* Start of string */
1171 register REGEXP *rx = pm->op_pmregexp;
1176 I32 oldsave = PL_savestack_ix;
1177 I32 update_minmatch = 1;
1178 I32 had_zerolen = 0;
1180 if (PL_op->op_flags & OPf_STACKED)
1187 PUTBACK; /* EVAL blocks need stack_sp. */
1188 s = SvPV(TARG, len);
1191 DIE(aTHX_ "panic: pp_match");
1192 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1193 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1196 if (pm->op_pmdynflags & PMdf_USED) {
1198 if (gimme == G_ARRAY)
1203 if (!rx->prelen && PL_curpm) {
1205 rx = pm->op_pmregexp;
1207 if (rx->minlen > len) goto failure;
1211 /* XXXX What part of this is needed with true \G-support? */
1212 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1214 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1215 MAGIC* mg = mg_find(TARG, 'g');
1216 if (mg && mg->mg_len >= 0) {
1217 if (!(rx->reganch & ROPT_GPOS_SEEN))
1218 rx->endp[0] = rx->startp[0] = mg->mg_len;
1219 else if (rx->reganch & ROPT_ANCH_GPOS) {
1220 r_flags |= REXEC_IGNOREPOS;
1221 rx->endp[0] = rx->startp[0] = mg->mg_len;
1223 minmatch = (mg->mg_flags & MGf_MINMATCH);
1224 update_minmatch = 0;
1228 if ((gimme != G_ARRAY && !global && rx->nparens)
1229 || SvTEMP(TARG) || PL_sawampersand)
1230 r_flags |= REXEC_COPY_STR;
1232 r_flags |= REXEC_SCREAM;
1234 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1235 SAVEINT(PL_multiline);
1236 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1240 if (global && rx->startp[0] != -1) {
1241 t = s = rx->endp[0] + truebase;
1242 if ((s + rx->minlen) > strend)
1244 if (update_minmatch++)
1245 minmatch = had_zerolen;
1247 if (rx->reganch & RE_USE_INTUIT &&
1248 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1249 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1253 if ( (rx->reganch & ROPT_CHECK_ALL)
1255 && ((rx->reganch & ROPT_NOSCAN)
1256 || !((rx->reganch & RE_INTUIT_TAIL)
1257 && (r_flags & REXEC_SCREAM)))
1258 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1261 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1264 if (pm->op_pmflags & PMf_ONCE)
1265 pm->op_pmdynflags |= PMdf_USED;
1274 RX_MATCH_TAINTED_on(rx);
1275 TAINT_IF(RX_MATCH_TAINTED(rx));
1276 if (gimme == G_ARRAY) {
1277 I32 nparens, i, len;
1279 nparens = rx->nparens;
1280 if (global && !nparens)
1284 SPAGAIN; /* EVAL blocks could move the stack. */
1285 EXTEND(SP, nparens + i);
1286 EXTEND_MORTAL(nparens + i);
1287 for (i = !i; i <= nparens; i++) {
1288 PUSHs(sv_newmortal());
1290 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1291 len = rx->endp[i] - rx->startp[i];
1292 s = rx->startp[i] + truebase;
1293 sv_setpvn(*SP, s, len);
1299 had_zerolen = (rx->startp[0] != -1
1300 && rx->startp[0] == rx->endp[0]);
1301 PUTBACK; /* EVAL blocks may use stack */
1302 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1307 LEAVE_SCOPE(oldsave);
1313 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1314 mg = mg_find(TARG, 'g');
1316 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1317 mg = mg_find(TARG, 'g');
1319 if (rx->startp[0] != -1) {
1320 mg->mg_len = rx->endp[0];
1321 if (rx->startp[0] == rx->endp[0])
1322 mg->mg_flags |= MGf_MINMATCH;
1324 mg->mg_flags &= ~MGf_MINMATCH;
1327 LEAVE_SCOPE(oldsave);
1331 yup: /* Confirmed by INTUIT */
1333 RX_MATCH_TAINTED_on(rx);
1334 TAINT_IF(RX_MATCH_TAINTED(rx));
1336 if (pm->op_pmflags & PMf_ONCE)
1337 pm->op_pmdynflags |= PMdf_USED;
1338 if (RX_MATCH_COPIED(rx))
1339 Safefree(rx->subbeg);
1340 RX_MATCH_COPIED_off(rx);
1341 rx->subbeg = Nullch;
1343 rx->subbeg = truebase;
1344 rx->startp[0] = s - truebase;
1345 if (DO_UTF8(PL_reg_sv)) {
1346 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1347 rx->endp[0] = t - truebase;
1350 rx->endp[0] = s - truebase + rx->minlen;
1352 rx->sublen = strend - truebase;
1355 if (PL_sawampersand) {
1358 rx->subbeg = savepvn(t, strend - t);
1359 rx->sublen = strend - t;
1360 RX_MATCH_COPIED_on(rx);
1361 off = rx->startp[0] = s - t;
1362 rx->endp[0] = off + rx->minlen;
1364 else { /* startp/endp are used by @- @+. */
1365 rx->startp[0] = s - truebase;
1366 rx->endp[0] = s - truebase + rx->minlen;
1368 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1369 LEAVE_SCOPE(oldsave);
1374 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1375 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1376 MAGIC* mg = mg_find(TARG, 'g');
1381 LEAVE_SCOPE(oldsave);
1382 if (gimme == G_ARRAY)
1388 Perl_do_readline(pTHX)
1390 dSP; dTARGETSTACKED;
1395 register IO *io = GvIO(PL_last_in_gv);
1396 register I32 type = PL_op->op_type;
1397 I32 gimme = GIMME_V;
1400 if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
1402 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1405 call_method("READLINE", gimme);
1408 if (gimme == G_SCALAR)
1409 SvSetMagicSV_nosteal(TARG, TOPs);
1416 if (IoFLAGS(io) & IOf_ARGV) {
1417 if (IoFLAGS(io) & IOf_START) {
1419 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1420 IoFLAGS(io) &= ~IOf_START;
1421 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1422 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1423 SvSETMAGIC(GvSV(PL_last_in_gv));
1428 fp = nextargv(PL_last_in_gv);
1429 if (!fp) { /* Note: fp != IoIFP(io) */
1430 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1433 else if (type == OP_GLOB)
1434 fp = Perl_start_glob(aTHX_ POPs, io);
1436 else if (type == OP_GLOB)
1438 else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
1439 && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
1440 || fp == PerlIO_stderr()))
1441 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1444 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1445 && (!io || !(IoFLAGS(io) & IOf_START))) {
1446 if (type == OP_GLOB)
1447 Perl_warner(aTHX_ WARN_GLOB,
1448 "glob failed (can't start child: %s)",
1451 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1453 if (gimme == G_SCALAR) {
1454 (void)SvOK_off(TARG);
1460 if (gimme == G_SCALAR) {
1464 (void)SvUPGRADE(sv, SVt_PV);
1465 tmplen = SvLEN(sv); /* remember if already alloced */
1467 Sv_Grow(sv, 80); /* try short-buffering it */
1468 if (type == OP_RCATLINE)
1474 sv = sv_2mortal(NEWSV(57, 80));
1478 /* This should not be marked tainted if the fp is marked clean */
1479 #define MAYBE_TAINT_LINE(io, sv) \
1480 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1485 /* delay EOF state for a snarfed empty file */
1486 #define SNARF_EOF(gimme,rs,io,sv) \
1487 (gimme != G_SCALAR || SvCUR(sv) \
1488 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1491 if (!sv_gets(sv, fp, offset)
1492 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1494 PerlIO_clearerr(fp);
1495 if (IoFLAGS(io) & IOf_ARGV) {
1496 fp = nextargv(PL_last_in_gv);
1499 (void)do_close(PL_last_in_gv, FALSE);
1501 else if (type == OP_GLOB) {
1502 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1503 Perl_warner(aTHX_ WARN_GLOB,
1504 "glob failed (child exited with status %d%s)",
1505 (int)(STATUS_CURRENT >> 8),
1506 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1509 if (gimme == G_SCALAR) {
1510 (void)SvOK_off(TARG);
1513 MAYBE_TAINT_LINE(io, sv);
1516 MAYBE_TAINT_LINE(io, sv);
1518 IoFLAGS(io) |= IOf_NOLINE;
1521 if (type == OP_GLOB) {
1524 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1525 tmps = SvEND(sv) - 1;
1526 if (*tmps == *SvPVX(PL_rs)) {
1531 for (tmps = SvPVX(sv); *tmps; tmps++)
1532 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1533 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1535 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1536 (void)POPs; /* Unmatched wildcard? Chuck it... */
1540 if (gimme == G_ARRAY) {
1541 if (SvLEN(sv) - SvCUR(sv) > 20) {
1542 SvLEN_set(sv, SvCUR(sv)+1);
1543 Renew(SvPVX(sv), SvLEN(sv), char);
1545 sv = sv_2mortal(NEWSV(58, 80));
1548 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1549 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1553 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1554 Renew(SvPVX(sv), SvLEN(sv), char);
1563 register PERL_CONTEXT *cx;
1564 I32 gimme = OP_GIMME(PL_op, -1);
1567 if (cxstack_ix >= 0)
1568 gimme = cxstack[cxstack_ix].blk_gimme;
1576 PUSHBLOCK(cx, CXt_BLOCK, SP);
1588 U32 lval = PL_op->op_flags & OPf_MOD;
1589 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1591 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1594 if (SvTYPE(hv) == SVt_PVHV) {
1595 if (PL_op->op_private & OPpLVAL_INTRO)
1596 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1597 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1598 svp = he ? &HeVAL(he) : 0;
1600 else if (SvTYPE(hv) == SVt_PVAV) {
1601 if (PL_op->op_private & OPpLVAL_INTRO)
1602 DIE(aTHX_ "Can't localize pseudo-hash element");
1603 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1609 if (!svp || *svp == &PL_sv_undef) {
1614 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1616 lv = sv_newmortal();
1617 sv_upgrade(lv, SVt_PVLV);
1619 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1620 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1621 LvTARG(lv) = SvREFCNT_inc(hv);
1626 if (PL_op->op_private & OPpLVAL_INTRO) {
1627 if (HvNAME(hv) && isGV(*svp))
1628 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1632 char *key = SvPV(keysv, keylen);
1633 save_delete(hv, key, keylen);
1635 save_helem(hv, keysv, svp);
1638 else if (PL_op->op_private & OPpDEREF)
1639 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1641 sv = (svp ? *svp : &PL_sv_undef);
1642 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1643 * Pushing the magical RHS on to the stack is useless, since
1644 * that magic is soon destined to be misled by the local(),
1645 * and thus the later pp_sassign() will fail to mg_get() the
1646 * old value. This should also cure problems with delayed
1647 * mg_get()s. GSAR 98-07-03 */
1648 if (!lval && SvGMAGICAL(sv))
1649 sv = sv_mortalcopy(sv);
1657 register PERL_CONTEXT *cx;
1663 if (PL_op->op_flags & OPf_SPECIAL) {
1664 cx = &cxstack[cxstack_ix];
1665 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1670 gimme = OP_GIMME(PL_op, -1);
1672 if (cxstack_ix >= 0)
1673 gimme = cxstack[cxstack_ix].blk_gimme;
1679 if (gimme == G_VOID)
1681 else if (gimme == G_SCALAR) {
1684 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1687 *MARK = sv_mortalcopy(TOPs);
1690 *MARK = &PL_sv_undef;
1694 else if (gimme == G_ARRAY) {
1695 /* in case LEAVE wipes old return values */
1696 for (mark = newsp + 1; mark <= SP; mark++) {
1697 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1698 *mark = sv_mortalcopy(*mark);
1699 TAINT_NOT; /* Each item is independent */
1703 PL_curpm = newpm; /* Don't pop $1 et al till now */
1713 register PERL_CONTEXT *cx;
1719 cx = &cxstack[cxstack_ix];
1720 if (CxTYPE(cx) != CXt_LOOP)
1721 DIE(aTHX_ "panic: pp_iter");
1723 itersvp = CxITERVAR(cx);
1724 av = cx->blk_loop.iterary;
1725 if (SvTYPE(av) != SVt_PVAV) {
1726 /* iterate ($min .. $max) */
1727 if (cx->blk_loop.iterlval) {
1728 /* string increment */
1729 register SV* cur = cx->blk_loop.iterlval;
1731 char *max = SvPV((SV*)av, maxlen);
1732 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1733 #ifndef USE_THREADS /* don't risk potential race */
1734 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1735 /* safe to reuse old SV */
1736 sv_setsv(*itersvp, cur);
1741 /* we need a fresh SV every time so that loop body sees a
1742 * completely new SV for closures/references to work as
1744 SvREFCNT_dec(*itersvp);
1745 *itersvp = newSVsv(cur);
1747 if (strEQ(SvPVX(cur), max))
1748 sv_setiv(cur, 0); /* terminate next time */
1755 /* integer increment */
1756 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1759 #ifndef USE_THREADS /* don't risk potential race */
1760 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1761 /* safe to reuse old SV */
1762 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1767 /* we need a fresh SV every time so that loop body sees a
1768 * completely new SV for closures/references to work as they
1770 SvREFCNT_dec(*itersvp);
1771 *itersvp = newSViv(cx->blk_loop.iterix++);
1777 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1780 SvREFCNT_dec(*itersvp);
1782 if ((sv = SvMAGICAL(av)
1783 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1784 : AvARRAY(av)[++cx->blk_loop.iterix]))
1788 if (av != PL_curstack && SvIMMORTAL(sv)) {
1789 SV *lv = cx->blk_loop.iterlval;
1790 if (lv && SvREFCNT(lv) > 1) {
1795 SvREFCNT_dec(LvTARG(lv));
1797 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1798 sv_upgrade(lv, SVt_PVLV);
1800 sv_magic(lv, Nullsv, 'y', Nullch, 0);
1802 LvTARG(lv) = SvREFCNT_inc(av);
1803 LvTARGOFF(lv) = cx->blk_loop.iterix;
1804 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1808 *itersvp = SvREFCNT_inc(sv);
1815 register PMOP *pm = cPMOP;
1831 register REGEXP *rx = pm->op_pmregexp;
1833 int force_on_match = 0;
1834 I32 oldsave = PL_savestack_ix;
1838 /* known replacement string? */
1839 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1840 if (PL_op->op_flags & OPf_STACKED)
1847 do_utf8 = DO_UTF8(PL_reg_sv);
1848 if (SvFAKE(TARG) && SvREADONLY(TARG))
1849 sv_force_normal(TARG);
1850 if (SvREADONLY(TARG)
1851 || (SvTYPE(TARG) > SVt_PVLV
1852 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1853 DIE(aTHX_ PL_no_modify);
1856 s = SvPV(TARG, len);
1857 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1859 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1860 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1867 DIE(aTHX_ "panic: pp_subst");
1870 slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1871 maxiters = 2 * slen + 10; /* We can match twice at each
1872 position, once with zero-length,
1873 second time with non-zero. */
1875 if (!rx->prelen && PL_curpm) {
1877 rx = pm->op_pmregexp;
1879 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1880 ? REXEC_COPY_STR : 0;
1882 r_flags |= REXEC_SCREAM;
1883 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1884 SAVEINT(PL_multiline);
1885 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1888 if (rx->reganch & RE_USE_INTUIT) {
1889 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1893 /* How to do it in subst? */
1894 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1896 && ((rx->reganch & ROPT_NOSCAN)
1897 || !((rx->reganch & RE_INTUIT_TAIL)
1898 && (r_flags & REXEC_SCREAM))))
1903 /* only replace once? */
1904 once = !(rpm->op_pmflags & PMf_GLOBAL);
1906 /* known replacement string? */
1907 c = dstr ? SvPV(dstr, clen) : Nullch;
1909 /* can do inplace substitution? */
1910 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1911 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1912 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1913 r_flags | REXEC_CHECKED))
1917 LEAVE_SCOPE(oldsave);
1920 if (force_on_match) {
1922 s = SvPV_force(TARG, len);
1927 SvSCREAM_off(TARG); /* disable possible screamer */
1929 rxtainted |= RX_MATCH_TAINTED(rx);
1930 m = orig + rx->startp[0];
1931 d = orig + rx->endp[0];
1933 if (m - s > strend - d) { /* faster to shorten from end */
1935 Copy(c, m, clen, char);
1940 Move(d, m, i, char);
1944 SvCUR_set(TARG, m - s);
1947 else if ((i = m - s)) { /* faster from front */
1955 Copy(c, m, clen, char);
1960 Copy(c, d, clen, char);
1965 TAINT_IF(rxtainted & 1);
1971 if (iters++ > maxiters)
1972 DIE(aTHX_ "Substitution loop");
1973 rxtainted |= RX_MATCH_TAINTED(rx);
1974 m = rx->startp[0] + orig;
1978 Move(s, d, i, char);
1982 Copy(c, d, clen, char);
1985 s = rx->endp[0] + orig;
1986 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
1988 /* don't match same null twice */
1989 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
1992 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1993 Move(s, d, i+1, char); /* include the NUL */
1995 TAINT_IF(rxtainted & 1);
1997 PUSHs(sv_2mortal(newSViv((I32)iters)));
1999 (void)SvPOK_only_UTF8(TARG);
2000 TAINT_IF(rxtainted);
2001 if (SvSMAGICAL(TARG)) {
2007 LEAVE_SCOPE(oldsave);
2011 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2012 r_flags | REXEC_CHECKED))
2016 if (force_on_match) {
2018 s = SvPV_force(TARG, len);
2021 rxtainted |= RX_MATCH_TAINTED(rx);
2022 dstr = NEWSV(25, len);
2023 sv_setpvn(dstr, m, s-m);
2028 register PERL_CONTEXT *cx;
2031 RETURNOP(cPMOP->op_pmreplroot);
2033 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2035 if (iters++ > maxiters)
2036 DIE(aTHX_ "Substitution loop");
2037 rxtainted |= RX_MATCH_TAINTED(rx);
2038 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2043 strend = s + (strend - m);
2045 m = rx->startp[0] + orig;
2046 sv_catpvn(dstr, s, m-s);
2047 s = rx->endp[0] + orig;
2049 sv_catpvn(dstr, c, clen);
2052 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2053 TARG, NULL, r_flags));
2054 sv_catpvn(dstr, s, strend - s);
2056 (void)SvOOK_off(TARG);
2057 Safefree(SvPVX(TARG));
2058 SvPVX(TARG) = SvPVX(dstr);
2059 SvCUR_set(TARG, SvCUR(dstr));
2060 SvLEN_set(TARG, SvLEN(dstr));
2061 isutf8 = DO_UTF8(dstr);
2065 TAINT_IF(rxtainted & 1);
2067 PUSHs(sv_2mortal(newSViv((I32)iters)));
2069 (void)SvPOK_only(TARG);
2072 TAINT_IF(rxtainted);
2075 LEAVE_SCOPE(oldsave);
2084 LEAVE_SCOPE(oldsave);
2093 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2094 ++*PL_markstack_ptr;
2095 LEAVE; /* exit inner scope */
2098 if (PL_stack_base + *PL_markstack_ptr > SP) {
2100 I32 gimme = GIMME_V;
2102 LEAVE; /* exit outer scope */
2103 (void)POPMARK; /* pop src */
2104 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2105 (void)POPMARK; /* pop dst */
2106 SP = PL_stack_base + POPMARK; /* pop original mark */
2107 if (gimme == G_SCALAR) {
2111 else if (gimme == G_ARRAY)
2118 ENTER; /* enter inner scope */
2121 src = PL_stack_base[*PL_markstack_ptr];
2125 RETURNOP(cLOGOP->op_other);
2136 register PERL_CONTEXT *cx;
2142 if (gimme == G_SCALAR) {
2145 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2147 *MARK = SvREFCNT_inc(TOPs);
2152 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2154 *MARK = sv_mortalcopy(sv);
2159 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2163 *MARK = &PL_sv_undef;
2167 else if (gimme == G_ARRAY) {
2168 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2169 if (!SvTEMP(*MARK)) {
2170 *MARK = sv_mortalcopy(*MARK);
2171 TAINT_NOT; /* Each item is independent */
2177 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2178 PL_curpm = newpm; /* ... and pop $1 et al */
2182 return pop_return();
2185 /* This duplicates the above code because the above code must not
2186 * get any slower by more conditions */
2194 register PERL_CONTEXT *cx;
2201 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2202 /* We are an argument to a function or grep().
2203 * This kind of lvalueness was legal before lvalue
2204 * subroutines too, so be backward compatible:
2205 * cannot report errors. */
2207 /* Scalar context *is* possible, on the LHS of -> only,
2208 * as in f()->meth(). But this is not an lvalue. */
2209 if (gimme == G_SCALAR)
2211 if (gimme == G_ARRAY) {
2212 if (!CvLVALUE(cx->blk_sub.cv))
2213 goto temporise_array;
2214 EXTEND_MORTAL(SP - newsp);
2215 for (mark = newsp + 1; mark <= SP; mark++) {
2218 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2219 *mark = sv_mortalcopy(*mark);
2221 /* Can be a localized value subject to deletion. */
2222 PL_tmps_stack[++PL_tmps_ix] = *mark;
2223 (void)SvREFCNT_inc(*mark);
2228 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2229 /* Here we go for robustness, not for speed, so we change all
2230 * the refcounts so the caller gets a live guy. Cannot set
2231 * TEMP, so sv_2mortal is out of question. */
2232 if (!CvLVALUE(cx->blk_sub.cv)) {
2237 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2239 if (gimme == G_SCALAR) {
2243 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2248 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2249 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2251 else { /* Can be a localized value
2252 * subject to deletion. */
2253 PL_tmps_stack[++PL_tmps_ix] = *mark;
2254 (void)SvREFCNT_inc(*mark);
2257 else { /* Should not happen? */
2262 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2263 (MARK > SP ? "Empty array" : "Array"));
2267 else if (gimme == G_ARRAY) {
2268 EXTEND_MORTAL(SP - newsp);
2269 for (mark = newsp + 1; mark <= SP; mark++) {
2270 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2271 /* Might be flattened array after $#array = */
2277 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2278 (*mark != &PL_sv_undef)
2280 ? "a readonly value" : "a temporary")
2281 : "an uninitialized value");
2284 /* Can be a localized value subject to deletion. */
2285 PL_tmps_stack[++PL_tmps_ix] = *mark;
2286 (void)SvREFCNT_inc(*mark);
2292 if (gimme == G_SCALAR) {
2296 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2298 *MARK = SvREFCNT_inc(TOPs);
2303 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2305 *MARK = sv_mortalcopy(sv);
2310 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2314 *MARK = &PL_sv_undef;
2318 else if (gimme == G_ARRAY) {
2320 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2321 if (!SvTEMP(*MARK)) {
2322 *MARK = sv_mortalcopy(*MARK);
2323 TAINT_NOT; /* Each item is independent */
2330 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2331 PL_curpm = newpm; /* ... and pop $1 et al */
2335 return pop_return();
2340 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2342 SV *dbsv = GvSV(PL_DBsub);
2344 if (!PERLDB_SUB_NN) {
2348 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2349 || strEQ(GvNAME(gv), "END")
2350 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2351 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2352 && (gv = (GV*)*svp) ))) {
2353 /* Use GV from the stack as a fallback. */
2354 /* GV is potentially non-unique, or contain different CV. */
2355 SV *tmp = newRV((SV*)cv);
2356 sv_setsv(dbsv, tmp);
2360 gv_efullname3(dbsv, gv, Nullch);
2364 (void)SvUPGRADE(dbsv, SVt_PVIV);
2365 (void)SvIOK_on(dbsv);
2366 SAVEIV(SvIVX(dbsv));
2367 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2371 PL_curcopdb = PL_curcop;
2372 cv = GvCV(PL_DBsub);
2382 register PERL_CONTEXT *cx;
2384 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2387 DIE(aTHX_ "Not a CODE reference");
2388 switch (SvTYPE(sv)) {
2394 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2396 SP = PL_stack_base + POPMARK;
2399 if (SvGMAGICAL(sv)) {
2401 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2404 sym = SvPV(sv, n_a);
2406 DIE(aTHX_ PL_no_usym, "a subroutine");
2407 if (PL_op->op_private & HINT_STRICT_REFS)
2408 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2409 cv = get_cv(sym, TRUE);
2413 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2414 tryAMAGICunDEREF(to_cv);
2417 if (SvTYPE(cv) == SVt_PVCV)
2422 DIE(aTHX_ "Not a CODE reference");
2427 if (!(cv = GvCVu((GV*)sv)))
2428 cv = sv_2cv(sv, &stash, &gv, FALSE);
2441 if (!CvROOT(cv) && !CvXSUB(cv)) {
2445 /* anonymous or undef'd function leaves us no recourse */
2446 if (CvANON(cv) || !(gv = CvGV(cv)))
2447 DIE(aTHX_ "Undefined subroutine called");
2449 /* autoloaded stub? */
2450 if (cv != GvCV(gv)) {
2453 /* should call AUTOLOAD now? */
2456 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2463 sub_name = sv_newmortal();
2464 gv_efullname3(sub_name, gv, Nullch);
2465 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2469 DIE(aTHX_ "Not a CODE reference");
2474 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2475 cv = get_db_sub(&sv, cv);
2477 DIE(aTHX_ "No DBsub routine");
2482 * First we need to check if the sub or method requires locking.
2483 * If so, we gain a lock on the CV, the first argument or the
2484 * stash (for static methods), as appropriate. This has to be
2485 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2486 * reschedule by returning a new op.
2488 MUTEX_LOCK(CvMUTEXP(cv));
2489 if (CvFLAGS(cv) & CVf_LOCKED) {
2491 if (CvFLAGS(cv) & CVf_METHOD) {
2492 if (SP > PL_stack_base + TOPMARK)
2493 sv = *(PL_stack_base + TOPMARK + 1);
2495 AV *av = (AV*)PL_curpad[0];
2496 if (hasargs || !av || AvFILLp(av) < 0
2497 || !(sv = AvARRAY(av)[0]))
2499 MUTEX_UNLOCK(CvMUTEXP(cv));
2500 DIE(aTHX_ "no argument for locked method call");
2507 char *stashname = SvPV(sv, len);
2508 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2514 MUTEX_UNLOCK(CvMUTEXP(cv));
2515 mg = condpair_magic(sv);
2516 MUTEX_LOCK(MgMUTEXP(mg));
2517 if (MgOWNER(mg) == thr)
2518 MUTEX_UNLOCK(MgMUTEXP(mg));
2521 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2523 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2525 MUTEX_UNLOCK(MgMUTEXP(mg));
2526 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2528 MUTEX_LOCK(CvMUTEXP(cv));
2531 * Now we have permission to enter the sub, we must distinguish
2532 * four cases. (0) It's an XSUB (in which case we don't care
2533 * about ownership); (1) it's ours already (and we're recursing);
2534 * (2) it's free (but we may already be using a cached clone);
2535 * (3) another thread owns it. Case (1) is easy: we just use it.
2536 * Case (2) means we look for a clone--if we have one, use it
2537 * otherwise grab ownership of cv. Case (3) means we look for a
2538 * clone (for non-XSUBs) and have to create one if we don't
2540 * Why look for a clone in case (2) when we could just grab
2541 * ownership of cv straight away? Well, we could be recursing,
2542 * i.e. we originally tried to enter cv while another thread
2543 * owned it (hence we used a clone) but it has been freed up
2544 * and we're now recursing into it. It may or may not be "better"
2545 * to use the clone but at least CvDEPTH can be trusted.
2547 if (CvOWNER(cv) == thr || CvXSUB(cv))
2548 MUTEX_UNLOCK(CvMUTEXP(cv));
2550 /* Case (2) or (3) */
2554 * XXX Might it be better to release CvMUTEXP(cv) while we
2555 * do the hv_fetch? We might find someone has pinched it
2556 * when we look again, in which case we would be in case
2557 * (3) instead of (2) so we'd have to clone. Would the fact
2558 * that we released the mutex more quickly make up for this?
2560 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2562 /* We already have a clone to use */
2563 MUTEX_UNLOCK(CvMUTEXP(cv));
2565 DEBUG_S(PerlIO_printf(Perl_debug_log,
2566 "entersub: %p already has clone %p:%s\n",
2567 thr, cv, SvPEEK((SV*)cv)));
2570 if (CvDEPTH(cv) == 0)
2571 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2574 /* (2) => grab ownership of cv. (3) => make clone */
2578 MUTEX_UNLOCK(CvMUTEXP(cv));
2579 DEBUG_S(PerlIO_printf(Perl_debug_log,
2580 "entersub: %p grabbing %p:%s in stash %s\n",
2581 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2582 HvNAME(CvSTASH(cv)) : "(none)"));
2585 /* Make a new clone. */
2587 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2588 MUTEX_UNLOCK(CvMUTEXP(cv));
2589 DEBUG_S((PerlIO_printf(Perl_debug_log,
2590 "entersub: %p cloning %p:%s\n",
2591 thr, cv, SvPEEK((SV*)cv))));
2593 * We're creating a new clone so there's no race
2594 * between the original MUTEX_UNLOCK and the
2595 * SvREFCNT_inc since no one will be trying to undef
2596 * it out from underneath us. At least, I don't think
2599 clonecv = cv_clone(cv);
2600 SvREFCNT_dec(cv); /* finished with this */
2601 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2602 CvOWNER(clonecv) = thr;
2606 DEBUG_S(if (CvDEPTH(cv) != 0)
2607 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2609 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2612 #endif /* USE_THREADS */
2615 #ifdef PERL_XSUB_OLDSTYLE
2616 if (CvOLDSTYLE(cv)) {
2617 I32 (*fp3)(int,int,int);
2619 register I32 items = SP - MARK;
2620 /* We dont worry to copy from @_. */
2625 PL_stack_sp = mark + 1;
2626 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2627 items = (*fp3)(CvXSUBANY(cv).any_i32,
2628 MARK - PL_stack_base + 1,
2630 PL_stack_sp = PL_stack_base + items;
2633 #endif /* PERL_XSUB_OLDSTYLE */
2635 I32 markix = TOPMARK;
2640 /* Need to copy @_ to stack. Alternative may be to
2641 * switch stack to @_, and copy return values
2642 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2646 av = (AV*)PL_curpad[0];
2648 av = GvAV(PL_defgv);
2649 #endif /* USE_THREADS */
2650 items = AvFILLp(av) + 1; /* @_ is not tieable */
2653 /* Mark is at the end of the stack. */
2655 Copy(AvARRAY(av), SP + 1, items, SV*);
2660 /* We assume first XSUB in &DB::sub is the called one. */
2662 SAVEVPTR(PL_curcop);
2663 PL_curcop = PL_curcopdb;
2666 /* Do we need to open block here? XXXX */
2667 (void)(*CvXSUB(cv))(aTHXo_ cv);
2669 /* Enforce some sanity in scalar context. */
2670 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2671 if (markix > PL_stack_sp - PL_stack_base)
2672 *(PL_stack_base + markix) = &PL_sv_undef;
2674 *(PL_stack_base + markix) = *PL_stack_sp;
2675 PL_stack_sp = PL_stack_base + markix;
2683 register I32 items = SP - MARK;
2684 AV* padlist = CvPADLIST(cv);
2685 SV** svp = AvARRAY(padlist);
2686 push_return(PL_op->op_next);
2687 PUSHBLOCK(cx, CXt_SUB, MARK);
2690 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2691 * that eval'' ops within this sub know the correct lexical space.
2692 * Owing the speed considerations, we choose to search for the cv
2693 * in doeval() instead.
2695 if (CvDEPTH(cv) < 2)
2696 (void)SvREFCNT_inc(cv);
2697 else { /* save temporaries on recursion? */
2698 PERL_STACK_OVERFLOW_CHECK();
2699 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2701 AV *newpad = newAV();
2702 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2703 I32 ix = AvFILLp((AV*)svp[1]);
2704 I32 names_fill = AvFILLp((AV*)svp[0]);
2705 svp = AvARRAY(svp[0]);
2706 for ( ;ix > 0; ix--) {
2707 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2708 char *name = SvPVX(svp[ix]);
2709 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2710 || *name == '&') /* anonymous code? */
2712 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2714 else { /* our own lexical */
2716 av_store(newpad, ix, sv = (SV*)newAV());
2717 else if (*name == '%')
2718 av_store(newpad, ix, sv = (SV*)newHV());
2720 av_store(newpad, ix, sv = NEWSV(0,0));
2724 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2725 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2728 av_store(newpad, ix, sv = NEWSV(0,0));
2732 av = newAV(); /* will be @_ */
2734 av_store(newpad, 0, (SV*)av);
2735 AvFLAGS(av) = AVf_REIFY;
2736 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2737 AvFILLp(padlist) = CvDEPTH(cv);
2738 svp = AvARRAY(padlist);
2743 AV* av = (AV*)PL_curpad[0];
2745 items = AvFILLp(av) + 1;
2747 /* Mark is at the end of the stack. */
2749 Copy(AvARRAY(av), SP + 1, items, SV*);
2754 #endif /* USE_THREADS */
2755 SAVEVPTR(PL_curpad);
2756 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2759 #endif /* USE_THREADS */
2765 DEBUG_S(PerlIO_printf(Perl_debug_log,
2766 "%p entersub preparing @_\n", thr));
2768 av = (AV*)PL_curpad[0];
2770 /* @_ is normally not REAL--this should only ever
2771 * happen when DB::sub() calls things that modify @_ */
2777 cx->blk_sub.savearray = GvAV(PL_defgv);
2778 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2779 #endif /* USE_THREADS */
2780 cx->blk_sub.oldcurpad = PL_curpad;
2781 cx->blk_sub.argarray = av;
2784 if (items > AvMAX(av) + 1) {
2786 if (AvARRAY(av) != ary) {
2787 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2788 SvPVX(av) = (char*)ary;
2790 if (items > AvMAX(av) + 1) {
2791 AvMAX(av) = items - 1;
2792 Renew(ary,items,SV*);
2794 SvPVX(av) = (char*)ary;
2797 Copy(MARK,AvARRAY(av),items,SV*);
2798 AvFILLp(av) = items - 1;
2806 /* warning must come *after* we fully set up the context
2807 * stuff so that __WARN__ handlers can safely dounwind()
2810 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2811 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2812 sub_crush_depth(cv);
2814 DEBUG_S(PerlIO_printf(Perl_debug_log,
2815 "%p entersub returning %p\n", thr, CvSTART(cv)));
2817 RETURNOP(CvSTART(cv));
2822 Perl_sub_crush_depth(pTHX_ CV *cv)
2825 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2827 SV* tmpstr = sv_newmortal();
2828 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2829 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2839 IV elem = SvIV(elemsv);
2841 U32 lval = PL_op->op_flags & OPf_MOD;
2842 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2845 if (SvROK(elemsv) && ckWARN(WARN_MISC))
2846 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2848 elem -= PL_curcop->cop_arybase;
2849 if (SvTYPE(av) != SVt_PVAV)
2851 svp = av_fetch(av, elem, lval && !defer);
2853 if (!svp || *svp == &PL_sv_undef) {
2856 DIE(aTHX_ PL_no_aelem, elem);
2857 lv = sv_newmortal();
2858 sv_upgrade(lv, SVt_PVLV);
2860 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2861 LvTARG(lv) = SvREFCNT_inc(av);
2862 LvTARGOFF(lv) = elem;
2867 if (PL_op->op_private & OPpLVAL_INTRO)
2868 save_aelem(av, elem, svp);
2869 else if (PL_op->op_private & OPpDEREF)
2870 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2872 sv = (svp ? *svp : &PL_sv_undef);
2873 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2874 sv = sv_mortalcopy(sv);
2880 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2886 Perl_croak(aTHX_ PL_no_modify);
2887 if (SvTYPE(sv) < SVt_RV)
2888 sv_upgrade(sv, SVt_RV);
2889 else if (SvTYPE(sv) >= SVt_PV) {
2890 (void)SvOOK_off(sv);
2891 Safefree(SvPVX(sv));
2892 SvLEN(sv) = SvCUR(sv) = 0;
2896 SvRV(sv) = NEWSV(355,0);
2899 SvRV(sv) = (SV*)newAV();
2902 SvRV(sv) = (SV*)newHV();
2917 if (SvTYPE(rsv) == SVt_PVCV) {
2923 SETs(method_common(sv, Null(U32*)));
2930 SV* sv = cSVOP->op_sv;
2931 U32 hash = SvUVX(sv);
2933 XPUSHs(method_common(sv, &hash));
2938 S_method_common(pTHX_ SV* meth, U32* hashp)
2949 name = SvPV(meth, namelen);
2950 sv = *(PL_stack_base + TOPMARK + 1);
2953 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2964 !(packname = SvPV(sv, packlen)) ||
2965 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2966 !(ob=(SV*)GvIO(iogv)))
2969 ((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
2970 ? !isIDFIRST_utf8((U8*)packname)
2971 : !isIDFIRST(*packname)
2974 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2975 SvOK(sv) ? "without a package or object reference"
2976 : "on an undefined value");
2978 stash = gv_stashpvn(packname, packlen, TRUE);
2981 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2984 if (!ob || !(SvOBJECT(ob)
2985 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2988 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2992 stash = SvSTASH(ob);
2995 /* shortcut for simple names */
2997 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2999 gv = (GV*)HeVAL(he);
3000 if (isGV(gv) && GvCV(gv) &&
3001 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3002 return (SV*)GvCV(gv);
3006 gv = gv_fetchmethod(stash, name);
3013 for (p = name; *p; p++) {
3015 sep = p, leaf = p + 1;
3016 else if (*p == ':' && *(p + 1) == ':')
3017 sep = p, leaf = p + 2;
3019 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3020 packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
3021 packlen = strlen(packname);
3025 packlen = sep - name;
3027 gv = gv_fetchpv(packname, 0, SVt_PVHV);
3028 if (gv && isGV(gv)) {
3030 "Can't locate object method \"%s\" via package \"%s\"",
3035 "Can't locate object method \"%s\" via package \"%s\""
3036 " (perhaps you forgot to load \"%s\"?)",
3037 leaf, packname, packname);
3040 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3045 unset_cvowner(pTHXo_ void *cvarg)
3047 register CV* cv = (CV *) cvarg;
3049 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3050 thr, cv, SvPEEK((SV*)cv))));
3051 MUTEX_LOCK(CvMUTEXP(cv));
3052 DEBUG_S(if (CvDEPTH(cv) != 0)
3053 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3055 assert(thr == CvOWNER(cv));
3057 MUTEX_UNLOCK(CvMUTEXP(cv));
3060 #endif /* USE_THREADS */