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
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 && !IN_BYTE) {
159 if (TARG == right && !right_utf8) {
160 sv_utf8_upgrade(TARG); /* Now straight binary copy */
164 /* Set TARG to PV(left), then add right */
169 /* Take a copy since we're about to overwrite TARG */
170 olds = s = (U8*)savepvn((char*)s, len);
172 if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) {
173 if (SvREADONLY(left))
174 left = sv_2mortal(newSVsv(left));
176 sv_setpv(left, ""); /* Suppress warning. */
179 sv_setpvn(TARG, (char*)l, llen);
182 sv_utf8_upgrade(TARG);
184 /* Extend TARG to length of right (s) */
185 targlen = SvCUR(TARG) + len;
187 /* plus one for each hi-byte char if we have to upgrade */
188 for (c = s; c < s + len; c++) {
189 if (UTF8_IS_CONTINUED(*c))
193 SvGROW(TARG, targlen+1);
194 /* And now copy, maybe upgrading right to UTF8 on the fly */
196 Copy(s, SvEND(TARG), len, U8);
198 for (c = (U8*)SvEND(TARG); len--; s++)
199 c = uv_to_utf8(c, *s);
201 SvCUR_set(TARG, targlen);
212 sv_insert(TARG, 0, 0, (char*)l, llen);
216 sv_setpvn(TARG, (char *)l, llen);
218 else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG)
219 sv_setpv(TARG, ""); /* Suppress warning. */
222 #if defined(PERL_Y2KWARN)
223 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
225 char *s = SvPV(TARG,n);
226 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
227 && (n == 2 || !isDIGIT(s[n-3])))
229 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
230 "about to append an integer to '19'");
234 sv_catpvn(TARG, (char *)s, len);
237 sv_setpvn(TARG, (char *)s, len); /* suppress warning */
238 if (left_utf8 && !IN_BYTE)
249 if (PL_op->op_flags & OPf_MOD) {
250 if (PL_op->op_private & OPpLVAL_INTRO)
251 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
252 else if (PL_op->op_private & OPpDEREF) {
254 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
263 tryAMAGICunTARGET(iter, 0);
264 PL_last_in_gv = (GV*)(*PL_stack_sp--);
265 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
266 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
267 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
270 XPUSHs((SV*)PL_last_in_gv);
273 PL_last_in_gv = (GV*)(*PL_stack_sp--);
276 return do_readline();
281 djSP; tryAMAGICbinSET(eq,0);
282 #ifdef PERL_PRESERVE_IVUV
285 /* Unless the left argument is integer in range we are going to have to
286 use NV maths. Hence only attempt to coerce the right argument if
287 we know the left is integer. */
290 bool auvok = SvUOK(TOPm1s);
291 bool buvok = SvUOK(TOPs);
293 if (!auvok && !buvok) { /* ## IV == IV ## */
294 IV aiv = SvIVX(TOPm1s);
295 IV biv = SvIVX(TOPs);
298 SETs(boolSV(aiv == biv));
301 if (auvok && buvok) { /* ## UV == UV ## */
302 UV auv = SvUVX(TOPm1s);
303 UV buv = SvUVX(TOPs);
306 SETs(boolSV(auv == buv));
309 { /* ## Mixed IV,UV ## */
313 /* == is commutative so swap if needed (save code) */
315 /* swap. top of stack (b) is the iv */
319 /* As (a) is a UV, it's >0, so it cannot be == */
328 /* As (b) is a UV, it's >0, so it cannot be == */
332 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
334 /* we know iv is >= 0 */
335 if (uv > (UV) IV_MAX) {
339 SETs(boolSV((UV)iv == uv));
347 SETs(boolSV(TOPn == value));
355 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
356 DIE(aTHX_ PL_no_modify);
357 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
358 SvIVX(TOPs) != IV_MAX)
361 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
363 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
376 RETURNOP(cLOGOP->op_other);
382 djSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
383 useleft = USE_LEFT(TOPm1s);
384 #ifdef PERL_PRESERVE_IVUV
385 /* We must see if we can perform the addition with integers if possible,
386 as the integer code detects overflow while the NV code doesn't.
387 If either argument hasn't had a numeric conversion yet attempt to get
388 the IV. It's important to do this now, rather than just assuming that
389 it's not IOK as a PV of "9223372036854775806" may not take well to NV
390 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
391 integer in case the second argument is IV=9223372036854775806
392 We can (now) rely on sv_2iv to do the right thing, only setting the
393 public IOK flag if the value in the NV (or PV) slot is truly integer.
395 A side effect is that this also aggressively prefers integer maths over
396 fp maths for integer values. */
399 /* Unless the left argument is integer in range we are going to have to
400 use NV maths. Hence only attempt to coerce the right argument if
401 we know the left is integer. */
403 /* left operand is undef, treat as zero. + 0 is identity. */
405 dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
414 /* Left operand is defined, so is it IV? */
417 bool auvok = SvUOK(TOPm1s);
418 bool buvok = SvUOK(TOPs);
420 if (!auvok && !buvok) { /* ## IV + IV ## */
421 IV aiv = SvIVX(TOPm1s);
422 IV biv = SvIVX(TOPs);
423 IV result = aiv + biv;
425 if (biv >= 0 ? (result >= aiv) : (result < aiv)) {
430 if (biv >=0 && aiv >= 0) {
431 UV result = (UV)aiv + (UV)biv;
432 /* UV + UV can only get bigger... */
433 if (result >= (UV) aiv) {
439 /* Overflow, drop through to NVs (beyond next if () else ) */
440 } else if (auvok && buvok) { /* ## UV + UV ## */
441 UV auv = SvUVX(TOPm1s);
442 UV buv = SvUVX(TOPs);
443 UV result = auv + buv;
449 /* Overflow, drop through to NVs (beyond next if () else ) */
450 } else { /* ## Mixed IV,UV ## */
454 /* addition is commutative so swap if needed (save code) */
464 UV result = (UV)aiv + buv;
470 } else if (buv > (UV) IV_MAX) {
471 /* assuming 2s complement means that IV_MIN == -IV_MIN,
472 and (UV)-IV_MIN *is* the value -IV_MIN (or IV_MAX + 1)
473 as buv > IV_MAX, it is >= (IV_MAX + 1), and therefore
474 as the value we can be subtracting from it only lies in
475 the range (-IV_MIN to -1) it can't overflow a UV */
477 SETu( buv - (UV)-aiv );
480 IV result = (IV) buv + aiv;
481 /* aiv < 0 so it must get smaller. */
482 if (result < (IV) buv) {
488 } /* end of IV+IV / UV+UV / mixed */
495 /* left operand is undef, treat as zero. + 0.0 is identity. */
499 SETn( value + TOPn );
507 AV *av = GvAV(cGVOP_gv);
508 U32 lval = PL_op->op_flags & OPf_MOD;
509 SV** svp = av_fetch(av, PL_op->op_private, lval);
510 SV *sv = (svp ? *svp : &PL_sv_undef);
512 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
513 sv = sv_mortalcopy(sv);
520 djSP; dMARK; dTARGET;
522 do_join(TARG, *MARK, MARK, SP);
533 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
534 * will be enough to hold an OP*.
536 SV* sv = sv_newmortal();
537 sv_upgrade(sv, SVt_PVLV);
539 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
547 /* Oversized hot code. */
551 djSP; dMARK; dORIGMARK;
558 if (PL_op->op_flags & OPf_STACKED)
562 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
564 if (MARK == ORIGMARK) {
565 /* If using default handle then we need to make space to
566 * pass object as 1st arg, so move other args up ...
570 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
574 *MARK = SvTIED_obj((SV*)gv, mg);
577 call_method("PRINT", G_SCALAR);
585 if (!(io = GvIO(gv))) {
586 if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
588 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
589 report_evil_fh(gv, io, PL_op->op_type);
590 SETERRNO(EBADF,RMS$_IFI);
593 else if (!(fp = IoOFP(io))) {
594 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
596 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
597 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
598 report_evil_fh(gv, io, PL_op->op_type);
600 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
605 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
607 if (!do_print(*MARK, fp))
611 if (!do_print(PL_ofs_sv, fp)) { /* $, */
620 if (!do_print(*MARK, fp))
628 if (PL_ors_sv && SvOK(PL_ors_sv))
629 if (!do_print(PL_ors_sv, fp)) /* $\ */
632 if (IoFLAGS(io) & IOf_FLUSH)
633 if (PerlIO_flush(fp) == EOF)
654 tryAMAGICunDEREF(to_av);
657 if (SvTYPE(av) != SVt_PVAV)
658 DIE(aTHX_ "Not an ARRAY reference");
659 if (PL_op->op_flags & OPf_REF) {
665 if (SvTYPE(sv) == SVt_PVAV) {
667 if (PL_op->op_flags & OPf_REF) {
675 if (SvTYPE(sv) != SVt_PVGV) {
679 if (SvGMAGICAL(sv)) {
685 if (PL_op->op_flags & OPf_REF ||
686 PL_op->op_private & HINT_STRICT_REFS)
687 DIE(aTHX_ PL_no_usym, "an ARRAY");
688 if (ckWARN(WARN_UNINITIALIZED))
690 if (GIMME == G_ARRAY) {
697 if ((PL_op->op_flags & OPf_SPECIAL) &&
698 !(PL_op->op_flags & OPf_MOD))
700 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
702 && (!is_gv_magical(sym,len,0)
703 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
709 if (PL_op->op_private & HINT_STRICT_REFS)
710 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
711 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
718 if (PL_op->op_private & OPpLVAL_INTRO)
720 if (PL_op->op_flags & OPf_REF) {
727 if (GIMME == G_ARRAY) {
728 I32 maxarg = AvFILL(av) + 1;
729 (void)POPs; /* XXXX May be optimized away? */
731 if (SvRMAGICAL(av)) {
733 for (i=0; i < maxarg; i++) {
734 SV **svp = av_fetch(av, i, FALSE);
735 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
739 Copy(AvARRAY(av), SP+1, maxarg, SV*);
745 I32 maxarg = AvFILL(av) + 1;
758 tryAMAGICunDEREF(to_hv);
761 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
762 DIE(aTHX_ "Not a HASH reference");
763 if (PL_op->op_flags & OPf_REF) {
769 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
771 if (PL_op->op_flags & OPf_REF) {
779 if (SvTYPE(sv) != SVt_PVGV) {
783 if (SvGMAGICAL(sv)) {
789 if (PL_op->op_flags & OPf_REF ||
790 PL_op->op_private & HINT_STRICT_REFS)
791 DIE(aTHX_ PL_no_usym, "a HASH");
792 if (ckWARN(WARN_UNINITIALIZED))
794 if (GIMME == G_ARRAY) {
801 if ((PL_op->op_flags & OPf_SPECIAL) &&
802 !(PL_op->op_flags & OPf_MOD))
804 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
806 && (!is_gv_magical(sym,len,0)
807 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
813 if (PL_op->op_private & HINT_STRICT_REFS)
814 DIE(aTHX_ PL_no_symref, sym, "a HASH");
815 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
822 if (PL_op->op_private & OPpLVAL_INTRO)
824 if (PL_op->op_flags & OPf_REF) {
831 if (GIMME == G_ARRAY) { /* array wanted */
832 *PL_stack_sp = (SV*)hv;
837 if (SvTYPE(hv) == SVt_PVAV)
838 hv = avhv_keys((AV*)hv);
840 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
841 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
851 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
857 leftop = ((BINOP*)PL_op)->op_last;
859 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
860 leftop = ((LISTOP*)leftop)->op_first;
862 /* Skip PUSHMARK and each element already assigned to. */
863 for (i = lelem - firstlelem; i > 0; i--) {
864 leftop = leftop->op_sibling;
867 if (leftop->op_type != OP_RV2HV)
872 av_fill(ary, 0); /* clear all but the fields hash */
873 if (lastrelem >= relem) {
874 while (relem < lastrelem) { /* gobble up all the rest */
878 /* Avoid a memory leak when avhv_store_ent dies. */
879 tmpstr = sv_newmortal();
880 sv_setsv(tmpstr,relem[1]); /* value */
882 if (avhv_store_ent(ary,relem[0],tmpstr,0))
883 (void)SvREFCNT_inc(tmpstr);
884 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
890 if (relem == lastrelem)
896 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
900 if (ckWARN(WARN_MISC)) {
901 if (relem == firstrelem &&
903 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
904 SvTYPE(SvRV(*relem)) == SVt_PVHV))
906 Perl_warner(aTHX_ WARN_MISC,
907 "Reference found where even-sized list expected");
910 Perl_warner(aTHX_ WARN_MISC,
911 "Odd number of elements in hash assignment");
913 if (SvTYPE(hash) == SVt_PVAV) {
915 tmpstr = sv_newmortal();
916 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
917 (void)SvREFCNT_inc(tmpstr);
918 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
923 tmpstr = NEWSV(29,0);
924 didstore = hv_store_ent(hash,*relem,tmpstr,0);
925 if (SvMAGICAL(hash)) {
926 if (SvSMAGICAL(tmpstr))
939 SV **lastlelem = PL_stack_sp;
940 SV **lastrelem = PL_stack_base + POPMARK;
941 SV **firstrelem = PL_stack_base + POPMARK + 1;
942 SV **firstlelem = lastrelem + 1;
955 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
957 /* If there's a common identifier on both sides we have to take
958 * special care that assigning the identifier on the left doesn't
959 * clobber a value on the right that's used later in the list.
961 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
962 EXTEND_MORTAL(lastrelem - firstrelem + 1);
963 for (relem = firstrelem; relem <= lastrelem; relem++) {
966 TAINT_NOT; /* Each item is independent */
967 *relem = sv_mortalcopy(sv);
977 while (lelem <= lastlelem) {
978 TAINT_NOT; /* Each item stands on its own, taintwise. */
980 switch (SvTYPE(sv)) {
983 magic = SvMAGICAL(ary) != 0;
984 if (PL_op->op_private & OPpASSIGN_HASH) {
985 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
991 do_oddball((HV*)ary, relem, firstrelem);
993 relem = lastrelem + 1;
998 av_extend(ary, lastrelem - relem);
1000 while (relem <= lastrelem) { /* gobble up all the rest */
1004 sv_setsv(sv,*relem);
1006 didstore = av_store(ary,i++,sv);
1016 case SVt_PVHV: { /* normal hash */
1020 magic = SvMAGICAL(hash) != 0;
1023 while (relem < lastrelem) { /* gobble up all the rest */
1028 sv = &PL_sv_no, relem++;
1029 tmpstr = NEWSV(29,0);
1031 sv_setsv(tmpstr,*relem); /* value */
1032 *(relem++) = tmpstr;
1033 didstore = hv_store_ent(hash,sv,tmpstr,0);
1035 if (SvSMAGICAL(tmpstr))
1042 if (relem == lastrelem) {
1043 do_oddball(hash, relem, firstrelem);
1049 if (SvIMMORTAL(sv)) {
1050 if (relem <= lastrelem)
1054 if (relem <= lastrelem) {
1055 sv_setsv(sv, *relem);
1059 sv_setsv(sv, &PL_sv_undef);
1064 if (PL_delaymagic & ~DM_DELAY) {
1065 if (PL_delaymagic & DM_UID) {
1066 #ifdef HAS_SETRESUID
1067 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1069 # ifdef HAS_SETREUID
1070 (void)setreuid(PL_uid,PL_euid);
1073 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1074 (void)setruid(PL_uid);
1075 PL_delaymagic &= ~DM_RUID;
1077 # endif /* HAS_SETRUID */
1079 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1080 (void)seteuid(PL_uid);
1081 PL_delaymagic &= ~DM_EUID;
1083 # endif /* HAS_SETEUID */
1084 if (PL_delaymagic & DM_UID) {
1085 if (PL_uid != PL_euid)
1086 DIE(aTHX_ "No setreuid available");
1087 (void)PerlProc_setuid(PL_uid);
1089 # endif /* HAS_SETREUID */
1090 #endif /* HAS_SETRESUID */
1091 PL_uid = PerlProc_getuid();
1092 PL_euid = PerlProc_geteuid();
1094 if (PL_delaymagic & DM_GID) {
1095 #ifdef HAS_SETRESGID
1096 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1098 # ifdef HAS_SETREGID
1099 (void)setregid(PL_gid,PL_egid);
1102 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1103 (void)setrgid(PL_gid);
1104 PL_delaymagic &= ~DM_RGID;
1106 # endif /* HAS_SETRGID */
1108 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1109 (void)setegid(PL_gid);
1110 PL_delaymagic &= ~DM_EGID;
1112 # endif /* HAS_SETEGID */
1113 if (PL_delaymagic & DM_GID) {
1114 if (PL_gid != PL_egid)
1115 DIE(aTHX_ "No setregid available");
1116 (void)PerlProc_setgid(PL_gid);
1118 # endif /* HAS_SETREGID */
1119 #endif /* HAS_SETRESGID */
1120 PL_gid = PerlProc_getgid();
1121 PL_egid = PerlProc_getegid();
1123 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1128 if (gimme == G_VOID)
1129 SP = firstrelem - 1;
1130 else if (gimme == G_SCALAR) {
1133 SETi(lastrelem - firstrelem + 1);
1139 SP = firstrelem + (lastlelem - firstlelem);
1140 lelem = firstlelem + (relem - firstrelem);
1142 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1150 register PMOP *pm = cPMOP;
1151 SV *rv = sv_newmortal();
1152 SV *sv = newSVrv(rv, "Regexp");
1153 sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
1160 register PMOP *pm = cPMOP;
1165 I32 r_flags = REXEC_CHECKED;
1166 char *truebase; /* Start of string */
1167 register REGEXP *rx = pm->op_pmregexp;
1172 I32 oldsave = PL_savestack_ix;
1173 I32 update_minmatch = 1;
1174 I32 had_zerolen = 0;
1176 if (PL_op->op_flags & OPf_STACKED)
1183 PUTBACK; /* EVAL blocks need stack_sp. */
1184 s = SvPV(TARG, len);
1187 DIE(aTHX_ "panic: pp_match");
1188 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1189 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1192 if (pm->op_pmdynflags & PMdf_USED) {
1194 if (gimme == G_ARRAY)
1199 if (!rx->prelen && PL_curpm) {
1201 rx = pm->op_pmregexp;
1203 if (rx->minlen > len) goto failure;
1207 /* XXXX What part of this is needed with true \G-support? */
1208 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1210 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1211 MAGIC* mg = mg_find(TARG, 'g');
1212 if (mg && mg->mg_len >= 0) {
1213 if (!(rx->reganch & ROPT_GPOS_SEEN))
1214 rx->endp[0] = rx->startp[0] = mg->mg_len;
1215 else if (rx->reganch & ROPT_ANCH_GPOS) {
1216 r_flags |= REXEC_IGNOREPOS;
1217 rx->endp[0] = rx->startp[0] = mg->mg_len;
1219 minmatch = (mg->mg_flags & MGf_MINMATCH);
1220 update_minmatch = 0;
1224 if ((gimme != G_ARRAY && !global && rx->nparens)
1225 || SvTEMP(TARG) || PL_sawampersand)
1226 r_flags |= REXEC_COPY_STR;
1228 r_flags |= REXEC_SCREAM;
1230 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1231 SAVEINT(PL_multiline);
1232 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1236 if (global && rx->startp[0] != -1) {
1237 t = s = rx->endp[0] + truebase;
1238 if ((s + rx->minlen) > strend)
1240 if (update_minmatch++)
1241 minmatch = had_zerolen;
1243 if (rx->reganch & RE_USE_INTUIT &&
1244 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1245 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1249 if ( (rx->reganch & ROPT_CHECK_ALL)
1251 && ((rx->reganch & ROPT_NOSCAN)
1252 || !((rx->reganch & RE_INTUIT_TAIL)
1253 && (r_flags & REXEC_SCREAM)))
1254 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1257 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1260 if (pm->op_pmflags & PMf_ONCE)
1261 pm->op_pmdynflags |= PMdf_USED;
1270 RX_MATCH_TAINTED_on(rx);
1271 TAINT_IF(RX_MATCH_TAINTED(rx));
1272 if (gimme == G_ARRAY) {
1273 I32 nparens, i, len;
1275 nparens = rx->nparens;
1276 if (global && !nparens)
1280 SPAGAIN; /* EVAL blocks could move the stack. */
1281 EXTEND(SP, nparens + i);
1282 EXTEND_MORTAL(nparens + i);
1283 for (i = !i; i <= nparens; i++) {
1284 PUSHs(sv_newmortal());
1286 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1287 len = rx->endp[i] - rx->startp[i];
1288 s = rx->startp[i] + truebase;
1289 sv_setpvn(*SP, s, len);
1295 had_zerolen = (rx->startp[0] != -1
1296 && rx->startp[0] == rx->endp[0]);
1297 PUTBACK; /* EVAL blocks may use stack */
1298 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1303 LEAVE_SCOPE(oldsave);
1309 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1310 mg = mg_find(TARG, 'g');
1312 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1313 mg = mg_find(TARG, 'g');
1315 if (rx->startp[0] != -1) {
1316 mg->mg_len = rx->endp[0];
1317 if (rx->startp[0] == rx->endp[0])
1318 mg->mg_flags |= MGf_MINMATCH;
1320 mg->mg_flags &= ~MGf_MINMATCH;
1323 LEAVE_SCOPE(oldsave);
1327 yup: /* Confirmed by INTUIT */
1329 RX_MATCH_TAINTED_on(rx);
1330 TAINT_IF(RX_MATCH_TAINTED(rx));
1332 if (pm->op_pmflags & PMf_ONCE)
1333 pm->op_pmdynflags |= PMdf_USED;
1334 if (RX_MATCH_COPIED(rx))
1335 Safefree(rx->subbeg);
1336 RX_MATCH_COPIED_off(rx);
1337 rx->subbeg = Nullch;
1339 rx->subbeg = truebase;
1340 rx->startp[0] = s - truebase;
1341 if (DO_UTF8(PL_reg_sv)) {
1342 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1343 rx->endp[0] = t - truebase;
1346 rx->endp[0] = s - truebase + rx->minlen;
1348 rx->sublen = strend - truebase;
1351 if (PL_sawampersand) {
1354 rx->subbeg = savepvn(t, strend - t);
1355 rx->sublen = strend - t;
1356 RX_MATCH_COPIED_on(rx);
1357 off = rx->startp[0] = s - t;
1358 rx->endp[0] = off + rx->minlen;
1360 else { /* startp/endp are used by @- @+. */
1361 rx->startp[0] = s - truebase;
1362 rx->endp[0] = s - truebase + rx->minlen;
1364 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1365 LEAVE_SCOPE(oldsave);
1370 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1371 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1372 MAGIC* mg = mg_find(TARG, 'g');
1377 LEAVE_SCOPE(oldsave);
1378 if (gimme == G_ARRAY)
1384 Perl_do_readline(pTHX)
1386 dSP; dTARGETSTACKED;
1391 register IO *io = GvIO(PL_last_in_gv);
1392 register I32 type = PL_op->op_type;
1393 I32 gimme = GIMME_V;
1396 if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
1398 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1401 call_method("READLINE", gimme);
1404 if (gimme == G_SCALAR)
1405 SvSetMagicSV_nosteal(TARG, TOPs);
1412 if (IoFLAGS(io) & IOf_ARGV) {
1413 if (IoFLAGS(io) & IOf_START) {
1415 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1416 IoFLAGS(io) &= ~IOf_START;
1417 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1418 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1419 SvSETMAGIC(GvSV(PL_last_in_gv));
1424 fp = nextargv(PL_last_in_gv);
1425 if (!fp) { /* Note: fp != IoIFP(io) */
1426 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1429 else if (type == OP_GLOB)
1430 fp = Perl_start_glob(aTHX_ POPs, io);
1432 else if (type == OP_GLOB)
1434 else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
1435 && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
1436 || fp == PerlIO_stderr()))
1437 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1440 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1441 && (!io || !(IoFLAGS(io) & IOf_START))) {
1442 if (type == OP_GLOB)
1443 Perl_warner(aTHX_ WARN_GLOB,
1444 "glob failed (can't start child: %s)",
1447 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1449 if (gimme == G_SCALAR) {
1450 (void)SvOK_off(TARG);
1456 if (gimme == G_SCALAR) {
1460 (void)SvUPGRADE(sv, SVt_PV);
1461 tmplen = SvLEN(sv); /* remember if already alloced */
1463 Sv_Grow(sv, 80); /* try short-buffering it */
1464 if (type == OP_RCATLINE)
1470 sv = sv_2mortal(NEWSV(57, 80));
1474 /* This should not be marked tainted if the fp is marked clean */
1475 #define MAYBE_TAINT_LINE(io, sv) \
1476 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1481 /* delay EOF state for a snarfed empty file */
1482 #define SNARF_EOF(gimme,rs,io,sv) \
1483 (gimme != G_SCALAR || SvCUR(sv) \
1484 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1487 if (!sv_gets(sv, fp, offset)
1488 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1490 PerlIO_clearerr(fp);
1491 if (IoFLAGS(io) & IOf_ARGV) {
1492 fp = nextargv(PL_last_in_gv);
1495 (void)do_close(PL_last_in_gv, FALSE);
1497 else if (type == OP_GLOB) {
1498 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1499 Perl_warner(aTHX_ WARN_GLOB,
1500 "glob failed (child exited with status %d%s)",
1501 (int)(STATUS_CURRENT >> 8),
1502 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1505 if (gimme == G_SCALAR) {
1506 (void)SvOK_off(TARG);
1509 MAYBE_TAINT_LINE(io, sv);
1512 MAYBE_TAINT_LINE(io, sv);
1514 IoFLAGS(io) |= IOf_NOLINE;
1517 if (type == OP_GLOB) {
1520 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1521 tmps = SvEND(sv) - 1;
1522 if (*tmps == *SvPVX(PL_rs)) {
1527 for (tmps = SvPVX(sv); *tmps; tmps++)
1528 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1529 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1531 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1532 (void)POPs; /* Unmatched wildcard? Chuck it... */
1536 if (gimme == G_ARRAY) {
1537 if (SvLEN(sv) - SvCUR(sv) > 20) {
1538 SvLEN_set(sv, SvCUR(sv)+1);
1539 Renew(SvPVX(sv), SvLEN(sv), char);
1541 sv = sv_2mortal(NEWSV(58, 80));
1544 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1545 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1549 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1550 Renew(SvPVX(sv), SvLEN(sv), char);
1559 register PERL_CONTEXT *cx;
1560 I32 gimme = OP_GIMME(PL_op, -1);
1563 if (cxstack_ix >= 0)
1564 gimme = cxstack[cxstack_ix].blk_gimme;
1572 PUSHBLOCK(cx, CXt_BLOCK, SP);
1584 U32 lval = PL_op->op_flags & OPf_MOD;
1585 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1587 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1590 if (SvTYPE(hv) == SVt_PVHV) {
1591 if (PL_op->op_private & OPpLVAL_INTRO)
1592 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1593 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1594 svp = he ? &HeVAL(he) : 0;
1596 else if (SvTYPE(hv) == SVt_PVAV) {
1597 if (PL_op->op_private & OPpLVAL_INTRO)
1598 DIE(aTHX_ "Can't localize pseudo-hash element");
1599 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1605 if (!svp || *svp == &PL_sv_undef) {
1610 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1612 lv = sv_newmortal();
1613 sv_upgrade(lv, SVt_PVLV);
1615 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1616 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1617 LvTARG(lv) = SvREFCNT_inc(hv);
1622 if (PL_op->op_private & OPpLVAL_INTRO) {
1623 if (HvNAME(hv) && isGV(*svp))
1624 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1628 char *key = SvPV(keysv, keylen);
1629 save_delete(hv, key, keylen);
1631 save_helem(hv, keysv, svp);
1634 else if (PL_op->op_private & OPpDEREF)
1635 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1637 sv = (svp ? *svp : &PL_sv_undef);
1638 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1639 * Pushing the magical RHS on to the stack is useless, since
1640 * that magic is soon destined to be misled by the local(),
1641 * and thus the later pp_sassign() will fail to mg_get() the
1642 * old value. This should also cure problems with delayed
1643 * mg_get()s. GSAR 98-07-03 */
1644 if (!lval && SvGMAGICAL(sv))
1645 sv = sv_mortalcopy(sv);
1653 register PERL_CONTEXT *cx;
1659 if (PL_op->op_flags & OPf_SPECIAL) {
1660 cx = &cxstack[cxstack_ix];
1661 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1666 gimme = OP_GIMME(PL_op, -1);
1668 if (cxstack_ix >= 0)
1669 gimme = cxstack[cxstack_ix].blk_gimme;
1675 if (gimme == G_VOID)
1677 else if (gimme == G_SCALAR) {
1680 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1683 *MARK = sv_mortalcopy(TOPs);
1686 *MARK = &PL_sv_undef;
1690 else if (gimme == G_ARRAY) {
1691 /* in case LEAVE wipes old return values */
1692 for (mark = newsp + 1; mark <= SP; mark++) {
1693 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1694 *mark = sv_mortalcopy(*mark);
1695 TAINT_NOT; /* Each item is independent */
1699 PL_curpm = newpm; /* Don't pop $1 et al till now */
1709 register PERL_CONTEXT *cx;
1715 cx = &cxstack[cxstack_ix];
1716 if (CxTYPE(cx) != CXt_LOOP)
1717 DIE(aTHX_ "panic: pp_iter");
1719 itersvp = CxITERVAR(cx);
1720 av = cx->blk_loop.iterary;
1721 if (SvTYPE(av) != SVt_PVAV) {
1722 /* iterate ($min .. $max) */
1723 if (cx->blk_loop.iterlval) {
1724 /* string increment */
1725 register SV* cur = cx->blk_loop.iterlval;
1727 char *max = SvPV((SV*)av, maxlen);
1728 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1729 #ifndef USE_THREADS /* don't risk potential race */
1730 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1731 /* safe to reuse old SV */
1732 sv_setsv(*itersvp, cur);
1737 /* we need a fresh SV every time so that loop body sees a
1738 * completely new SV for closures/references to work as
1740 SvREFCNT_dec(*itersvp);
1741 *itersvp = newSVsv(cur);
1743 if (strEQ(SvPVX(cur), max))
1744 sv_setiv(cur, 0); /* terminate next time */
1751 /* integer increment */
1752 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1755 #ifndef USE_THREADS /* don't risk potential race */
1756 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1757 /* safe to reuse old SV */
1758 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1763 /* we need a fresh SV every time so that loop body sees a
1764 * completely new SV for closures/references to work as they
1766 SvREFCNT_dec(*itersvp);
1767 *itersvp = newSViv(cx->blk_loop.iterix++);
1773 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1776 SvREFCNT_dec(*itersvp);
1778 if ((sv = SvMAGICAL(av)
1779 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1780 : AvARRAY(av)[++cx->blk_loop.iterix]))
1784 if (av != PL_curstack && SvIMMORTAL(sv)) {
1785 SV *lv = cx->blk_loop.iterlval;
1786 if (lv && SvREFCNT(lv) > 1) {
1791 SvREFCNT_dec(LvTARG(lv));
1793 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1794 sv_upgrade(lv, SVt_PVLV);
1796 sv_magic(lv, Nullsv, 'y', Nullch, 0);
1798 LvTARG(lv) = SvREFCNT_inc(av);
1799 LvTARGOFF(lv) = cx->blk_loop.iterix;
1800 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1804 *itersvp = SvREFCNT_inc(sv);
1811 register PMOP *pm = cPMOP;
1827 register REGEXP *rx = pm->op_pmregexp;
1829 int force_on_match = 0;
1830 I32 oldsave = PL_savestack_ix;
1834 /* known replacement string? */
1835 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1836 if (PL_op->op_flags & OPf_STACKED)
1843 do_utf8 = DO_UTF8(PL_reg_sv);
1844 if (SvFAKE(TARG) && SvREADONLY(TARG))
1845 sv_force_normal(TARG);
1846 if (SvREADONLY(TARG)
1847 || (SvTYPE(TARG) > SVt_PVLV
1848 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1849 DIE(aTHX_ PL_no_modify);
1852 s = SvPV(TARG, len);
1853 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1855 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1856 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1863 DIE(aTHX_ "panic: pp_subst");
1866 slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1867 maxiters = 2 * slen + 10; /* We can match twice at each
1868 position, once with zero-length,
1869 second time with non-zero. */
1871 if (!rx->prelen && PL_curpm) {
1873 rx = pm->op_pmregexp;
1875 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1876 ? REXEC_COPY_STR : 0;
1878 r_flags |= REXEC_SCREAM;
1879 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1880 SAVEINT(PL_multiline);
1881 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1884 if (rx->reganch & RE_USE_INTUIT) {
1885 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1889 /* How to do it in subst? */
1890 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1892 && ((rx->reganch & ROPT_NOSCAN)
1893 || !((rx->reganch & RE_INTUIT_TAIL)
1894 && (r_flags & REXEC_SCREAM))))
1899 /* only replace once? */
1900 once = !(rpm->op_pmflags & PMf_GLOBAL);
1902 /* known replacement string? */
1903 c = dstr ? SvPV(dstr, clen) : Nullch;
1905 /* can do inplace substitution? */
1906 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1907 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1908 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1909 r_flags | REXEC_CHECKED))
1913 LEAVE_SCOPE(oldsave);
1916 if (force_on_match) {
1918 s = SvPV_force(TARG, len);
1923 SvSCREAM_off(TARG); /* disable possible screamer */
1925 rxtainted |= RX_MATCH_TAINTED(rx);
1926 m = orig + rx->startp[0];
1927 d = orig + rx->endp[0];
1929 if (m - s > strend - d) { /* faster to shorten from end */
1931 Copy(c, m, clen, char);
1936 Move(d, m, i, char);
1940 SvCUR_set(TARG, m - s);
1943 else if ((i = m - s)) { /* faster from front */
1951 Copy(c, m, clen, char);
1956 Copy(c, d, clen, char);
1961 TAINT_IF(rxtainted & 1);
1967 if (iters++ > maxiters)
1968 DIE(aTHX_ "Substitution loop");
1969 rxtainted |= RX_MATCH_TAINTED(rx);
1970 m = rx->startp[0] + orig;
1974 Move(s, d, i, char);
1978 Copy(c, d, clen, char);
1981 s = rx->endp[0] + orig;
1982 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
1984 /* don't match same null twice */
1985 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
1988 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1989 Move(s, d, i+1, char); /* include the NUL */
1991 TAINT_IF(rxtainted & 1);
1993 PUSHs(sv_2mortal(newSViv((I32)iters)));
1995 (void)SvPOK_only_UTF8(TARG);
1996 TAINT_IF(rxtainted);
1997 if (SvSMAGICAL(TARG)) {
2003 LEAVE_SCOPE(oldsave);
2007 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2008 r_flags | REXEC_CHECKED))
2012 if (force_on_match) {
2014 s = SvPV_force(TARG, len);
2017 rxtainted |= RX_MATCH_TAINTED(rx);
2018 dstr = NEWSV(25, len);
2019 sv_setpvn(dstr, m, s-m);
2024 register PERL_CONTEXT *cx;
2027 RETURNOP(cPMOP->op_pmreplroot);
2029 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2031 if (iters++ > maxiters)
2032 DIE(aTHX_ "Substitution loop");
2033 rxtainted |= RX_MATCH_TAINTED(rx);
2034 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2039 strend = s + (strend - m);
2041 m = rx->startp[0] + orig;
2042 sv_catpvn(dstr, s, m-s);
2043 s = rx->endp[0] + orig;
2045 sv_catpvn(dstr, c, clen);
2048 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2049 TARG, NULL, r_flags));
2050 sv_catpvn(dstr, s, strend - s);
2052 (void)SvOOK_off(TARG);
2053 Safefree(SvPVX(TARG));
2054 SvPVX(TARG) = SvPVX(dstr);
2055 SvCUR_set(TARG, SvCUR(dstr));
2056 SvLEN_set(TARG, SvLEN(dstr));
2057 isutf8 = DO_UTF8(dstr);
2061 TAINT_IF(rxtainted & 1);
2063 PUSHs(sv_2mortal(newSViv((I32)iters)));
2065 (void)SvPOK_only(TARG);
2068 TAINT_IF(rxtainted);
2071 LEAVE_SCOPE(oldsave);
2080 LEAVE_SCOPE(oldsave);
2089 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2090 ++*PL_markstack_ptr;
2091 LEAVE; /* exit inner scope */
2094 if (PL_stack_base + *PL_markstack_ptr > SP) {
2096 I32 gimme = GIMME_V;
2098 LEAVE; /* exit outer scope */
2099 (void)POPMARK; /* pop src */
2100 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2101 (void)POPMARK; /* pop dst */
2102 SP = PL_stack_base + POPMARK; /* pop original mark */
2103 if (gimme == G_SCALAR) {
2107 else if (gimme == G_ARRAY)
2114 ENTER; /* enter inner scope */
2117 src = PL_stack_base[*PL_markstack_ptr];
2121 RETURNOP(cLOGOP->op_other);
2132 register PERL_CONTEXT *cx;
2138 if (gimme == G_SCALAR) {
2141 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2143 *MARK = SvREFCNT_inc(TOPs);
2148 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2150 *MARK = sv_mortalcopy(sv);
2155 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2159 *MARK = &PL_sv_undef;
2163 else if (gimme == G_ARRAY) {
2164 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2165 if (!SvTEMP(*MARK)) {
2166 *MARK = sv_mortalcopy(*MARK);
2167 TAINT_NOT; /* Each item is independent */
2173 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2174 PL_curpm = newpm; /* ... and pop $1 et al */
2178 return pop_return();
2181 /* This duplicates the above code because the above code must not
2182 * get any slower by more conditions */
2190 register PERL_CONTEXT *cx;
2197 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2198 /* We are an argument to a function or grep().
2199 * This kind of lvalueness was legal before lvalue
2200 * subroutines too, so be backward compatible:
2201 * cannot report errors. */
2203 /* Scalar context *is* possible, on the LHS of -> only,
2204 * as in f()->meth(). But this is not an lvalue. */
2205 if (gimme == G_SCALAR)
2207 if (gimme == G_ARRAY) {
2208 if (!CvLVALUE(cx->blk_sub.cv))
2209 goto temporise_array;
2210 EXTEND_MORTAL(SP - newsp);
2211 for (mark = newsp + 1; mark <= SP; mark++) {
2214 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2215 *mark = sv_mortalcopy(*mark);
2217 /* Can be a localized value subject to deletion. */
2218 PL_tmps_stack[++PL_tmps_ix] = *mark;
2219 (void)SvREFCNT_inc(*mark);
2224 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2225 /* Here we go for robustness, not for speed, so we change all
2226 * the refcounts so the caller gets a live guy. Cannot set
2227 * TEMP, so sv_2mortal is out of question. */
2228 if (!CvLVALUE(cx->blk_sub.cv)) {
2233 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2235 if (gimme == G_SCALAR) {
2239 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2244 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2245 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2247 else { /* Can be a localized value
2248 * subject to deletion. */
2249 PL_tmps_stack[++PL_tmps_ix] = *mark;
2250 (void)SvREFCNT_inc(*mark);
2253 else { /* Should not happen? */
2258 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2259 (MARK > SP ? "Empty array" : "Array"));
2263 else if (gimme == G_ARRAY) {
2264 EXTEND_MORTAL(SP - newsp);
2265 for (mark = newsp + 1; mark <= SP; mark++) {
2266 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2267 /* Might be flattened array after $#array = */
2273 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2274 (*mark != &PL_sv_undef)
2276 ? "a readonly value" : "a temporary")
2277 : "an uninitialized value");
2280 /* Can be a localized value subject to deletion. */
2281 PL_tmps_stack[++PL_tmps_ix] = *mark;
2282 (void)SvREFCNT_inc(*mark);
2288 if (gimme == G_SCALAR) {
2292 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2294 *MARK = SvREFCNT_inc(TOPs);
2299 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2301 *MARK = sv_mortalcopy(sv);
2306 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2310 *MARK = &PL_sv_undef;
2314 else if (gimme == G_ARRAY) {
2316 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2317 if (!SvTEMP(*MARK)) {
2318 *MARK = sv_mortalcopy(*MARK);
2319 TAINT_NOT; /* Each item is independent */
2326 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2327 PL_curpm = newpm; /* ... and pop $1 et al */
2331 return pop_return();
2336 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2338 SV *dbsv = GvSV(PL_DBsub);
2340 if (!PERLDB_SUB_NN) {
2344 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2345 || strEQ(GvNAME(gv), "END")
2346 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2347 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2348 && (gv = (GV*)*svp) ))) {
2349 /* Use GV from the stack as a fallback. */
2350 /* GV is potentially non-unique, or contain different CV. */
2351 SV *tmp = newRV((SV*)cv);
2352 sv_setsv(dbsv, tmp);
2356 gv_efullname3(dbsv, gv, Nullch);
2360 (void)SvUPGRADE(dbsv, SVt_PVIV);
2361 (void)SvIOK_on(dbsv);
2362 SAVEIV(SvIVX(dbsv));
2363 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2367 PL_curcopdb = PL_curcop;
2368 cv = GvCV(PL_DBsub);
2378 register PERL_CONTEXT *cx;
2380 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2383 DIE(aTHX_ "Not a CODE reference");
2384 switch (SvTYPE(sv)) {
2390 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2392 SP = PL_stack_base + POPMARK;
2395 if (SvGMAGICAL(sv)) {
2397 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2400 sym = SvPV(sv, n_a);
2402 DIE(aTHX_ PL_no_usym, "a subroutine");
2403 if (PL_op->op_private & HINT_STRICT_REFS)
2404 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2405 cv = get_cv(sym, TRUE);
2409 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2410 tryAMAGICunDEREF(to_cv);
2413 if (SvTYPE(cv) == SVt_PVCV)
2418 DIE(aTHX_ "Not a CODE reference");
2423 if (!(cv = GvCVu((GV*)sv)))
2424 cv = sv_2cv(sv, &stash, &gv, FALSE);
2437 if (!CvROOT(cv) && !CvXSUB(cv)) {
2441 /* anonymous or undef'd function leaves us no recourse */
2442 if (CvANON(cv) || !(gv = CvGV(cv)))
2443 DIE(aTHX_ "Undefined subroutine called");
2445 /* autoloaded stub? */
2446 if (cv != GvCV(gv)) {
2449 /* should call AUTOLOAD now? */
2452 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2459 sub_name = sv_newmortal();
2460 gv_efullname3(sub_name, gv, Nullch);
2461 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2465 DIE(aTHX_ "Not a CODE reference");
2470 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2471 cv = get_db_sub(&sv, cv);
2473 DIE(aTHX_ "No DBsub routine");
2478 * First we need to check if the sub or method requires locking.
2479 * If so, we gain a lock on the CV, the first argument or the
2480 * stash (for static methods), as appropriate. This has to be
2481 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2482 * reschedule by returning a new op.
2484 MUTEX_LOCK(CvMUTEXP(cv));
2485 if (CvFLAGS(cv) & CVf_LOCKED) {
2487 if (CvFLAGS(cv) & CVf_METHOD) {
2488 if (SP > PL_stack_base + TOPMARK)
2489 sv = *(PL_stack_base + TOPMARK + 1);
2491 AV *av = (AV*)PL_curpad[0];
2492 if (hasargs || !av || AvFILLp(av) < 0
2493 || !(sv = AvARRAY(av)[0]))
2495 MUTEX_UNLOCK(CvMUTEXP(cv));
2496 DIE(aTHX_ "no argument for locked method call");
2503 char *stashname = SvPV(sv, len);
2504 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2510 MUTEX_UNLOCK(CvMUTEXP(cv));
2511 mg = condpair_magic(sv);
2512 MUTEX_LOCK(MgMUTEXP(mg));
2513 if (MgOWNER(mg) == thr)
2514 MUTEX_UNLOCK(MgMUTEXP(mg));
2517 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2519 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2521 MUTEX_UNLOCK(MgMUTEXP(mg));
2522 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2524 MUTEX_LOCK(CvMUTEXP(cv));
2527 * Now we have permission to enter the sub, we must distinguish
2528 * four cases. (0) It's an XSUB (in which case we don't care
2529 * about ownership); (1) it's ours already (and we're recursing);
2530 * (2) it's free (but we may already be using a cached clone);
2531 * (3) another thread owns it. Case (1) is easy: we just use it.
2532 * Case (2) means we look for a clone--if we have one, use it
2533 * otherwise grab ownership of cv. Case (3) means we look for a
2534 * clone (for non-XSUBs) and have to create one if we don't
2536 * Why look for a clone in case (2) when we could just grab
2537 * ownership of cv straight away? Well, we could be recursing,
2538 * i.e. we originally tried to enter cv while another thread
2539 * owned it (hence we used a clone) but it has been freed up
2540 * and we're now recursing into it. It may or may not be "better"
2541 * to use the clone but at least CvDEPTH can be trusted.
2543 if (CvOWNER(cv) == thr || CvXSUB(cv))
2544 MUTEX_UNLOCK(CvMUTEXP(cv));
2546 /* Case (2) or (3) */
2550 * XXX Might it be better to release CvMUTEXP(cv) while we
2551 * do the hv_fetch? We might find someone has pinched it
2552 * when we look again, in which case we would be in case
2553 * (3) instead of (2) so we'd have to clone. Would the fact
2554 * that we released the mutex more quickly make up for this?
2556 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2558 /* We already have a clone to use */
2559 MUTEX_UNLOCK(CvMUTEXP(cv));
2561 DEBUG_S(PerlIO_printf(Perl_debug_log,
2562 "entersub: %p already has clone %p:%s\n",
2563 thr, cv, SvPEEK((SV*)cv)));
2566 if (CvDEPTH(cv) == 0)
2567 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2570 /* (2) => grab ownership of cv. (3) => make clone */
2574 MUTEX_UNLOCK(CvMUTEXP(cv));
2575 DEBUG_S(PerlIO_printf(Perl_debug_log,
2576 "entersub: %p grabbing %p:%s in stash %s\n",
2577 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2578 HvNAME(CvSTASH(cv)) : "(none)"));
2581 /* Make a new clone. */
2583 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2584 MUTEX_UNLOCK(CvMUTEXP(cv));
2585 DEBUG_S((PerlIO_printf(Perl_debug_log,
2586 "entersub: %p cloning %p:%s\n",
2587 thr, cv, SvPEEK((SV*)cv))));
2589 * We're creating a new clone so there's no race
2590 * between the original MUTEX_UNLOCK and the
2591 * SvREFCNT_inc since no one will be trying to undef
2592 * it out from underneath us. At least, I don't think
2595 clonecv = cv_clone(cv);
2596 SvREFCNT_dec(cv); /* finished with this */
2597 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2598 CvOWNER(clonecv) = thr;
2602 DEBUG_S(if (CvDEPTH(cv) != 0)
2603 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2605 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2608 #endif /* USE_THREADS */
2611 #ifdef PERL_XSUB_OLDSTYLE
2612 if (CvOLDSTYLE(cv)) {
2613 I32 (*fp3)(int,int,int);
2615 register I32 items = SP - MARK;
2616 /* We dont worry to copy from @_. */
2621 PL_stack_sp = mark + 1;
2622 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2623 items = (*fp3)(CvXSUBANY(cv).any_i32,
2624 MARK - PL_stack_base + 1,
2626 PL_stack_sp = PL_stack_base + items;
2629 #endif /* PERL_XSUB_OLDSTYLE */
2631 I32 markix = TOPMARK;
2636 /* Need to copy @_ to stack. Alternative may be to
2637 * switch stack to @_, and copy return values
2638 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2642 av = (AV*)PL_curpad[0];
2644 av = GvAV(PL_defgv);
2645 #endif /* USE_THREADS */
2646 items = AvFILLp(av) + 1; /* @_ is not tieable */
2649 /* Mark is at the end of the stack. */
2651 Copy(AvARRAY(av), SP + 1, items, SV*);
2656 /* We assume first XSUB in &DB::sub is the called one. */
2658 SAVEVPTR(PL_curcop);
2659 PL_curcop = PL_curcopdb;
2662 /* Do we need to open block here? XXXX */
2663 (void)(*CvXSUB(cv))(aTHXo_ cv);
2665 /* Enforce some sanity in scalar context. */
2666 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2667 if (markix > PL_stack_sp - PL_stack_base)
2668 *(PL_stack_base + markix) = &PL_sv_undef;
2670 *(PL_stack_base + markix) = *PL_stack_sp;
2671 PL_stack_sp = PL_stack_base + markix;
2679 register I32 items = SP - MARK;
2680 AV* padlist = CvPADLIST(cv);
2681 SV** svp = AvARRAY(padlist);
2682 push_return(PL_op->op_next);
2683 PUSHBLOCK(cx, CXt_SUB, MARK);
2686 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2687 * that eval'' ops within this sub know the correct lexical space.
2688 * Owing the speed considerations, we choose to search for the cv
2689 * in doeval() instead.
2691 if (CvDEPTH(cv) < 2)
2692 (void)SvREFCNT_inc(cv);
2693 else { /* save temporaries on recursion? */
2694 PERL_STACK_OVERFLOW_CHECK();
2695 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2697 AV *newpad = newAV();
2698 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2699 I32 ix = AvFILLp((AV*)svp[1]);
2700 I32 names_fill = AvFILLp((AV*)svp[0]);
2701 svp = AvARRAY(svp[0]);
2702 for ( ;ix > 0; ix--) {
2703 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2704 char *name = SvPVX(svp[ix]);
2705 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2706 || *name == '&') /* anonymous code? */
2708 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2710 else { /* our own lexical */
2712 av_store(newpad, ix, sv = (SV*)newAV());
2713 else if (*name == '%')
2714 av_store(newpad, ix, sv = (SV*)newHV());
2716 av_store(newpad, ix, sv = NEWSV(0,0));
2720 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2721 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2724 av_store(newpad, ix, sv = NEWSV(0,0));
2728 av = newAV(); /* will be @_ */
2730 av_store(newpad, 0, (SV*)av);
2731 AvFLAGS(av) = AVf_REIFY;
2732 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2733 AvFILLp(padlist) = CvDEPTH(cv);
2734 svp = AvARRAY(padlist);
2739 AV* av = (AV*)PL_curpad[0];
2741 items = AvFILLp(av) + 1;
2743 /* Mark is at the end of the stack. */
2745 Copy(AvARRAY(av), SP + 1, items, SV*);
2750 #endif /* USE_THREADS */
2751 SAVEVPTR(PL_curpad);
2752 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2755 #endif /* USE_THREADS */
2761 DEBUG_S(PerlIO_printf(Perl_debug_log,
2762 "%p entersub preparing @_\n", thr));
2764 av = (AV*)PL_curpad[0];
2766 /* @_ is normally not REAL--this should only ever
2767 * happen when DB::sub() calls things that modify @_ */
2773 cx->blk_sub.savearray = GvAV(PL_defgv);
2774 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2775 #endif /* USE_THREADS */
2776 cx->blk_sub.oldcurpad = PL_curpad;
2777 cx->blk_sub.argarray = av;
2780 if (items > AvMAX(av) + 1) {
2782 if (AvARRAY(av) != ary) {
2783 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2784 SvPVX(av) = (char*)ary;
2786 if (items > AvMAX(av) + 1) {
2787 AvMAX(av) = items - 1;
2788 Renew(ary,items,SV*);
2790 SvPVX(av) = (char*)ary;
2793 Copy(MARK,AvARRAY(av),items,SV*);
2794 AvFILLp(av) = items - 1;
2802 /* warning must come *after* we fully set up the context
2803 * stuff so that __WARN__ handlers can safely dounwind()
2806 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2807 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2808 sub_crush_depth(cv);
2810 DEBUG_S(PerlIO_printf(Perl_debug_log,
2811 "%p entersub returning %p\n", thr, CvSTART(cv)));
2813 RETURNOP(CvSTART(cv));
2818 Perl_sub_crush_depth(pTHX_ CV *cv)
2821 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2823 SV* tmpstr = sv_newmortal();
2824 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2825 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2835 IV elem = SvIV(elemsv);
2837 U32 lval = PL_op->op_flags & OPf_MOD;
2838 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2841 if (SvROK(elemsv) && ckWARN(WARN_MISC))
2842 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2844 elem -= PL_curcop->cop_arybase;
2845 if (SvTYPE(av) != SVt_PVAV)
2847 svp = av_fetch(av, elem, lval && !defer);
2849 if (!svp || *svp == &PL_sv_undef) {
2852 DIE(aTHX_ PL_no_aelem, elem);
2853 lv = sv_newmortal();
2854 sv_upgrade(lv, SVt_PVLV);
2856 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2857 LvTARG(lv) = SvREFCNT_inc(av);
2858 LvTARGOFF(lv) = elem;
2863 if (PL_op->op_private & OPpLVAL_INTRO)
2864 save_aelem(av, elem, svp);
2865 else if (PL_op->op_private & OPpDEREF)
2866 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2868 sv = (svp ? *svp : &PL_sv_undef);
2869 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2870 sv = sv_mortalcopy(sv);
2876 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2882 Perl_croak(aTHX_ PL_no_modify);
2883 if (SvTYPE(sv) < SVt_RV)
2884 sv_upgrade(sv, SVt_RV);
2885 else if (SvTYPE(sv) >= SVt_PV) {
2886 (void)SvOOK_off(sv);
2887 Safefree(SvPVX(sv));
2888 SvLEN(sv) = SvCUR(sv) = 0;
2892 SvRV(sv) = NEWSV(355,0);
2895 SvRV(sv) = (SV*)newAV();
2898 SvRV(sv) = (SV*)newHV();
2913 if (SvTYPE(rsv) == SVt_PVCV) {
2919 SETs(method_common(sv, Null(U32*)));
2926 SV* sv = cSVOP->op_sv;
2927 U32 hash = SvUVX(sv);
2929 XPUSHs(method_common(sv, &hash));
2934 S_method_common(pTHX_ SV* meth, U32* hashp)
2945 name = SvPV(meth, namelen);
2946 sv = *(PL_stack_base + TOPMARK + 1);
2949 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2960 !(packname = SvPV(sv, packlen)) ||
2961 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2962 !(ob=(SV*)GvIO(iogv)))
2965 ((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
2966 ? !isIDFIRST_utf8((U8*)packname)
2967 : !isIDFIRST(*packname)
2970 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2971 SvOK(sv) ? "without a package or object reference"
2972 : "on an undefined value");
2974 stash = gv_stashpvn(packname, packlen, TRUE);
2977 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2980 if (!ob || !(SvOBJECT(ob)
2981 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2984 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2988 stash = SvSTASH(ob);
2991 /* shortcut for simple names */
2993 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2995 gv = (GV*)HeVAL(he);
2996 if (isGV(gv) && GvCV(gv) &&
2997 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2998 return (SV*)GvCV(gv);
3002 gv = gv_fetchmethod(stash, name);
3009 for (p = name; *p; p++) {
3011 sep = p, leaf = p + 1;
3012 else if (*p == ':' && *(p + 1) == ':')
3013 sep = p, leaf = p + 2;
3015 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3016 packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
3017 packlen = strlen(packname);
3021 packlen = sep - name;
3023 gv = gv_fetchpv(packname, 0, SVt_PVHV);
3024 if (gv && isGV(gv)) {
3026 "Can't locate object method \"%s\" via package \"%s\"",
3031 "Can't locate object method \"%s\" via package \"%s\""
3032 " (perhaps you forgot to load \"%s\"?)",
3033 leaf, packname, packname);
3036 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3041 unset_cvowner(pTHXo_ void *cvarg)
3043 register CV* cv = (CV *) cvarg;
3045 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3046 thr, cv, SvPEEK((SV*)cv))));
3047 MUTEX_LOCK(CvMUTEXP(cv));
3048 DEBUG_S(if (CvDEPTH(cv) != 0)
3049 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3051 assert(thr == CvOWNER(cv));
3053 MUTEX_UNLOCK(CvMUTEXP(cv));
3056 #endif /* USE_THREADS */