3 * Copyright (c) 1991-2002, 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
24 #ifdef USE_5005THREADS
25 static void unset_cvowner(pTHX_ void *cvarg);
26 #endif /* USE_5005THREADS */
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);
83 XPUSHs((SV*)cGVOP_gv);
94 RETURNOP(cLOGOP->op_other);
102 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
104 temp = left; left = right; right = temp;
106 if (PL_tainting && PL_tainted && !SvTAINTED(left))
108 SvSetMagicSV(right, left);
117 RETURNOP(cLOGOP->op_other);
119 RETURNOP(cLOGOP->op_next);
125 TAINT_NOT; /* Each statement is presumed innocent */
126 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
128 oldsave = PL_scopestack[PL_scopestack_ix - 1];
129 LEAVE_SCOPE(oldsave);
135 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
142 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
143 bool rbyte = !SvUTF8(right);
145 if (TARG == right && right != left) {
146 right = sv_2mortal(newSVpvn(rpv, rlen));
147 rpv = SvPV(right, rlen); /* no point setting UTF8 here */
151 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
152 lbyte = !SvUTF8(left);
153 sv_setpvn(TARG, lpv, llen);
159 else { /* TARG == left */
160 if (SvGMAGICAL(left))
161 mg_get(left); /* or mg_get(left) may happen here */
164 lpv = SvPV_nomg(left, llen);
165 lbyte = !SvUTF8(left);
168 #if defined(PERL_Y2KWARN)
169 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
170 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
171 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
173 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
174 "about to append an integer to '19'");
179 if (lbyte != rbyte) {
181 sv_utf8_upgrade_nomg(TARG);
183 sv_utf8_upgrade_nomg(right);
184 rpv = SvPV(right, rlen);
187 sv_catpvn_nomg(TARG, rpv, rlen);
198 if (PL_op->op_flags & OPf_MOD) {
199 if (PL_op->op_private & OPpLVAL_INTRO)
200 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
201 else if (PL_op->op_private & OPpDEREF) {
203 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
212 tryAMAGICunTARGET(iter, 0);
213 PL_last_in_gv = (GV*)(*PL_stack_sp--);
214 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
215 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
216 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
219 XPUSHs((SV*)PL_last_in_gv);
222 PL_last_in_gv = (GV*)(*PL_stack_sp--);
225 return do_readline();
230 dSP; tryAMAGICbinSET(eq,0);
231 #ifndef NV_PRESERVES_UV
232 if (SvROK(TOPs) && SvROK(TOPm1s)) {
234 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
238 #ifdef PERL_PRESERVE_IVUV
241 /* Unless the left argument is integer in range we are going
242 to have to use NV maths. Hence only attempt to coerce the
243 right argument if we know the left is integer. */
246 bool auvok = SvUOK(TOPm1s);
247 bool buvok = SvUOK(TOPs);
249 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
250 /* Casting IV to UV before comparison isn't going to matter
251 on 2s complement. On 1s complement or sign&magnitude
252 (if we have any of them) it could to make negative zero
253 differ from normal zero. As I understand it. (Need to
254 check - is negative zero implementation defined behaviour
256 UV buv = SvUVX(POPs);
257 UV auv = SvUVX(TOPs);
259 SETs(boolSV(auv == buv));
262 { /* ## Mixed IV,UV ## */
266 /* == is commutative so doesn't matter which is left or right */
268 /* top of stack (b) is the iv */
277 /* As uv is a UV, it's >0, so it cannot be == */
281 /* we know iv is >= 0 */
282 SETs(boolSV((UV)iv == SvUVX(uvp)));
290 SETs(boolSV(TOPn == value));
298 if (SvTYPE(TOPs) > SVt_PVLV)
299 DIE(aTHX_ PL_no_modify);
300 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
301 && SvIVX(TOPs) != IV_MAX)
304 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
306 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
319 RETURNOP(cLOGOP->op_other);
325 /* Most of this is lifted straight from pp_defined */
330 if (!sv || !SvANY(sv)) {
332 RETURNOP(cLOGOP->op_other);
335 switch (SvTYPE(sv)) {
337 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
341 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
345 if (CvROOT(sv) || CvXSUB(sv))
356 RETURNOP(cLOGOP->op_other);
361 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
362 useleft = USE_LEFT(TOPm1s);
363 #ifdef PERL_PRESERVE_IVUV
364 /* We must see if we can perform the addition with integers if possible,
365 as the integer code detects overflow while the NV code doesn't.
366 If either argument hasn't had a numeric conversion yet attempt to get
367 the IV. It's important to do this now, rather than just assuming that
368 it's not IOK as a PV of "9223372036854775806" may not take well to NV
369 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
370 integer in case the second argument is IV=9223372036854775806
371 We can (now) rely on sv_2iv to do the right thing, only setting the
372 public IOK flag if the value in the NV (or PV) slot is truly integer.
374 A side effect is that this also aggressively prefers integer maths over
375 fp maths for integer values.
377 How to detect overflow?
379 C 99 section 6.2.6.1 says
381 The range of nonnegative values of a signed integer type is a subrange
382 of the corresponding unsigned integer type, and the representation of
383 the same value in each type is the same. A computation involving
384 unsigned operands can never overflow, because a result that cannot be
385 represented by the resulting unsigned integer type is reduced modulo
386 the number that is one greater than the largest value that can be
387 represented by the resulting type.
391 which I read as "unsigned ints wrap."
393 signed integer overflow seems to be classed as "exception condition"
395 If an exceptional condition occurs during the evaluation of an
396 expression (that is, if the result is not mathematically defined or not
397 in the range of representable values for its type), the behavior is
400 (6.5, the 5th paragraph)
402 I had assumed that on 2s complement machines signed arithmetic would
403 wrap, hence coded pp_add and pp_subtract on the assumption that
404 everything perl builds on would be happy. After much wailing and
405 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
406 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
407 unsigned code below is actually shorter than the old code. :-)
412 /* Unless the left argument is integer in range we are going to have to
413 use NV maths. Hence only attempt to coerce the right argument if
414 we know the left is integer. */
422 /* left operand is undef, treat as zero. + 0 is identity,
423 Could SETi or SETu right now, but space optimise by not adding
424 lots of code to speed up what is probably a rarish case. */
426 /* Left operand is defined, so is it IV? */
429 if ((auvok = SvUOK(TOPm1s)))
432 register IV aiv = SvIVX(TOPm1s);
435 auvok = 1; /* Now acting as a sign flag. */
436 } else { /* 2s complement assumption for IV_MIN */
444 bool result_good = 0;
447 bool buvok = SvUOK(TOPs);
452 register IV biv = SvIVX(TOPs);
459 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
460 else "IV" now, independent of how it came in.
461 if a, b represents positive, A, B negative, a maps to -A etc
466 all UV maths. negate result if A negative.
467 add if signs same, subtract if signs differ. */
473 /* Must get smaller */
479 /* result really should be -(auv-buv). as its negation
480 of true value, need to swap our result flag */
497 if (result <= (UV)IV_MIN)
500 /* result valid, but out of range for IV. */
505 } /* Overflow, drop through to NVs. */
512 /* left operand is undef, treat as zero. + 0.0 is identity. */
516 SETn( value + TOPn );
524 AV *av = GvAV(cGVOP_gv);
525 U32 lval = PL_op->op_flags & OPf_MOD;
526 SV** svp = av_fetch(av, PL_op->op_private, lval);
527 SV *sv = (svp ? *svp : &PL_sv_undef);
529 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
530 sv = sv_mortalcopy(sv);
539 do_join(TARG, *MARK, MARK, SP);
550 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
551 * will be enough to hold an OP*.
553 SV* sv = sv_newmortal();
554 sv_upgrade(sv, SVt_PVLV);
556 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
564 /* Oversized hot code. */
568 dSP; dMARK; dORIGMARK;
574 if (PL_op->op_flags & OPf_STACKED)
579 if (gv && (io = GvIO(gv))
580 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
583 if (MARK == ORIGMARK) {
584 /* If using default handle then we need to make space to
585 * pass object as 1st arg, so move other args up ...
589 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
593 *MARK = SvTIED_obj((SV*)io, mg);
596 call_method("PRINT", G_SCALAR);
604 if (!(io = GvIO(gv))) {
605 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
606 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
608 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
609 report_evil_fh(gv, io, PL_op->op_type);
610 SETERRNO(EBADF,RMS_IFI);
613 else if (!(fp = IoOFP(io))) {
614 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
616 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
617 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
618 report_evil_fh(gv, io, PL_op->op_type);
620 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
625 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
627 if (!do_print(*MARK, fp))
631 if (!do_print(PL_ofs_sv, fp)) { /* $, */
640 if (!do_print(*MARK, fp))
648 if (PL_ors_sv && SvOK(PL_ors_sv))
649 if (!do_print(PL_ors_sv, fp)) /* $\ */
652 if (IoFLAGS(io) & IOf_FLUSH)
653 if (PerlIO_flush(fp) == EOF)
674 tryAMAGICunDEREF(to_av);
677 if (SvTYPE(av) != SVt_PVAV)
678 DIE(aTHX_ "Not an ARRAY reference");
679 if (PL_op->op_flags & OPf_REF) {
684 if (GIMME == G_SCALAR)
685 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
691 if (SvTYPE(sv) == SVt_PVAV) {
693 if (PL_op->op_flags & OPf_REF) {
698 if (GIMME == G_SCALAR)
699 Perl_croak(aTHX_ "Can't return array to lvalue"
708 if (SvTYPE(sv) != SVt_PVGV) {
712 if (SvGMAGICAL(sv)) {
718 if (PL_op->op_flags & OPf_REF ||
719 PL_op->op_private & HINT_STRICT_REFS)
720 DIE(aTHX_ PL_no_usym, "an ARRAY");
721 if (ckWARN(WARN_UNINITIALIZED))
723 if (GIMME == G_ARRAY) {
730 if ((PL_op->op_flags & OPf_SPECIAL) &&
731 !(PL_op->op_flags & OPf_MOD))
733 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
735 && (!is_gv_magical(sym,len,0)
736 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
742 if (PL_op->op_private & HINT_STRICT_REFS)
743 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
744 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
751 if (PL_op->op_private & OPpLVAL_INTRO)
753 if (PL_op->op_flags & OPf_REF) {
758 if (GIMME == G_SCALAR)
759 Perl_croak(aTHX_ "Can't return array to lvalue"
767 if (GIMME == G_ARRAY) {
768 I32 maxarg = AvFILL(av) + 1;
769 (void)POPs; /* XXXX May be optimized away? */
771 if (SvRMAGICAL(av)) {
773 for (i=0; i < (U32)maxarg; i++) {
774 SV **svp = av_fetch(av, i, FALSE);
775 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
779 Copy(AvARRAY(av), SP+1, maxarg, SV*);
783 else if (GIMME_V == G_SCALAR) {
785 I32 maxarg = AvFILL(av) + 1;
798 tryAMAGICunDEREF(to_hv);
801 if (SvTYPE(hv) != SVt_PVHV)
802 DIE(aTHX_ "Not a HASH reference");
803 if (PL_op->op_flags & OPf_REF) {
808 if (GIMME == G_SCALAR)
809 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
815 if (SvTYPE(sv) == SVt_PVHV) {
817 if (PL_op->op_flags & OPf_REF) {
822 if (GIMME == G_SCALAR)
823 Perl_croak(aTHX_ "Can't return hash to lvalue"
832 if (SvTYPE(sv) != SVt_PVGV) {
836 if (SvGMAGICAL(sv)) {
842 if (PL_op->op_flags & OPf_REF ||
843 PL_op->op_private & HINT_STRICT_REFS)
844 DIE(aTHX_ PL_no_usym, "a HASH");
845 if (ckWARN(WARN_UNINITIALIZED))
847 if (GIMME == G_ARRAY) {
854 if ((PL_op->op_flags & OPf_SPECIAL) &&
855 !(PL_op->op_flags & OPf_MOD))
857 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
859 && (!is_gv_magical(sym,len,0)
860 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
866 if (PL_op->op_private & HINT_STRICT_REFS)
867 DIE(aTHX_ PL_no_symref, sym, "a HASH");
868 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
875 if (PL_op->op_private & OPpLVAL_INTRO)
877 if (PL_op->op_flags & OPf_REF) {
882 if (GIMME == G_SCALAR)
883 Perl_croak(aTHX_ "Can't return hash to lvalue"
891 if (GIMME == G_ARRAY) { /* array wanted */
892 *PL_stack_sp = (SV*)hv;
898 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
899 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
909 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
915 if (ckWARN(WARN_MISC)) {
916 if (relem == firstrelem &&
918 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
919 SvTYPE(SvRV(*relem)) == SVt_PVHV))
921 Perl_warner(aTHX_ packWARN(WARN_MISC),
922 "Reference found where even-sized list expected");
925 Perl_warner(aTHX_ packWARN(WARN_MISC),
926 "Odd number of elements in hash assignment");
929 tmpstr = NEWSV(29,0);
930 didstore = hv_store_ent(hash,*relem,tmpstr,0);
931 if (SvMAGICAL(hash)) {
932 if (SvSMAGICAL(tmpstr))
944 SV **lastlelem = PL_stack_sp;
945 SV **lastrelem = PL_stack_base + POPMARK;
946 SV **firstrelem = PL_stack_base + POPMARK + 1;
947 SV **firstlelem = lastrelem + 1;
960 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
962 /* If there's a common identifier on both sides we have to take
963 * special care that assigning the identifier on the left doesn't
964 * clobber a value on the right that's used later in the list.
966 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
967 EXTEND_MORTAL(lastrelem - firstrelem + 1);
968 for (relem = firstrelem; relem <= lastrelem; relem++) {
971 TAINT_NOT; /* Each item is independent */
972 *relem = sv_mortalcopy(sv);
982 while (lelem <= lastlelem) {
983 TAINT_NOT; /* Each item stands on its own, taintwise. */
985 switch (SvTYPE(sv)) {
988 magic = SvMAGICAL(ary) != 0;
990 av_extend(ary, lastrelem - relem);
992 while (relem <= lastrelem) { /* gobble up all the rest */
998 didstore = av_store(ary,i++,sv);
1008 case SVt_PVHV: { /* normal hash */
1012 magic = SvMAGICAL(hash) != 0;
1015 while (relem < lastrelem) { /* gobble up all the rest */
1020 sv = &PL_sv_no, relem++;
1021 tmpstr = NEWSV(29,0);
1023 sv_setsv(tmpstr,*relem); /* value */
1024 *(relem++) = tmpstr;
1025 didstore = hv_store_ent(hash,sv,tmpstr,0);
1027 if (SvSMAGICAL(tmpstr))
1034 if (relem == lastrelem) {
1035 do_oddball(hash, relem, firstrelem);
1041 if (SvIMMORTAL(sv)) {
1042 if (relem <= lastrelem)
1046 if (relem <= lastrelem) {
1047 sv_setsv(sv, *relem);
1051 sv_setsv(sv, &PL_sv_undef);
1056 if (PL_delaymagic & ~DM_DELAY) {
1057 if (PL_delaymagic & DM_UID) {
1058 #ifdef HAS_SETRESUID
1059 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1061 # ifdef HAS_SETREUID
1062 (void)setreuid(PL_uid,PL_euid);
1065 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1066 (void)setruid(PL_uid);
1067 PL_delaymagic &= ~DM_RUID;
1069 # endif /* HAS_SETRUID */
1071 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1072 (void)seteuid(PL_uid);
1073 PL_delaymagic &= ~DM_EUID;
1075 # endif /* HAS_SETEUID */
1076 if (PL_delaymagic & DM_UID) {
1077 if (PL_uid != PL_euid)
1078 DIE(aTHX_ "No setreuid available");
1079 (void)PerlProc_setuid(PL_uid);
1081 # endif /* HAS_SETREUID */
1082 #endif /* HAS_SETRESUID */
1083 PL_uid = PerlProc_getuid();
1084 PL_euid = PerlProc_geteuid();
1086 if (PL_delaymagic & DM_GID) {
1087 #ifdef HAS_SETRESGID
1088 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1090 # ifdef HAS_SETREGID
1091 (void)setregid(PL_gid,PL_egid);
1094 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1095 (void)setrgid(PL_gid);
1096 PL_delaymagic &= ~DM_RGID;
1098 # endif /* HAS_SETRGID */
1100 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1101 (void)setegid(PL_gid);
1102 PL_delaymagic &= ~DM_EGID;
1104 # endif /* HAS_SETEGID */
1105 if (PL_delaymagic & DM_GID) {
1106 if (PL_gid != PL_egid)
1107 DIE(aTHX_ "No setregid available");
1108 (void)PerlProc_setgid(PL_gid);
1110 # endif /* HAS_SETREGID */
1111 #endif /* HAS_SETRESGID */
1112 PL_gid = PerlProc_getgid();
1113 PL_egid = PerlProc_getegid();
1115 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1120 if (gimme == G_VOID)
1121 SP = firstrelem - 1;
1122 else if (gimme == G_SCALAR) {
1125 SETi(lastrelem - firstrelem + 1);
1131 SP = firstrelem + (lastlelem - firstlelem);
1132 lelem = firstlelem + (relem - firstrelem);
1134 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1142 register PMOP *pm = cPMOP;
1143 SV *rv = sv_newmortal();
1144 SV *sv = newSVrv(rv, "Regexp");
1145 if (pm->op_pmdynflags & PMdf_TAINTED)
1147 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1154 register PMOP *pm = cPMOP;
1160 I32 r_flags = REXEC_CHECKED;
1161 char *truebase; /* Start of string */
1162 register REGEXP *rx = PM_GETRE(pm);
1167 I32 oldsave = PL_savestack_ix;
1168 I32 update_minmatch = 1;
1169 I32 had_zerolen = 0;
1171 if (PL_op->op_flags & OPf_STACKED)
1178 PUTBACK; /* EVAL blocks need stack_sp. */
1179 s = SvPV(TARG, len);
1182 DIE(aTHX_ "panic: pp_match");
1183 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1184 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1187 PL_reg_match_utf8 = DO_UTF8(TARG);
1189 /* PMdf_USED is set after a ?? matches once */
1190 if (pm->op_pmdynflags & PMdf_USED) {
1192 if (gimme == G_ARRAY)
1197 /* empty pattern special-cased to use last successful pattern if possible */
1198 if (!rx->prelen && PL_curpm) {
1203 if (rx->minlen > (I32)len)
1208 /* XXXX What part of this is needed with true \G-support? */
1209 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1211 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1212 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1213 if (mg && mg->mg_len >= 0) {
1214 if (!(rx->reganch & ROPT_GPOS_SEEN))
1215 rx->endp[0] = rx->startp[0] = mg->mg_len;
1216 else if (rx->reganch & ROPT_ANCH_GPOS) {
1217 r_flags |= REXEC_IGNOREPOS;
1218 rx->endp[0] = rx->startp[0] = mg->mg_len;
1220 minmatch = (mg->mg_flags & MGf_MINMATCH);
1221 update_minmatch = 0;
1225 if ((!global && rx->nparens)
1226 || SvTEMP(TARG) || PL_sawampersand)
1227 r_flags |= REXEC_COPY_STR;
1229 r_flags |= REXEC_SCREAM;
1231 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1232 SAVEINT(PL_multiline);
1233 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1237 if (global && rx->startp[0] != -1) {
1238 t = s = rx->endp[0] + truebase;
1239 if ((s + rx->minlen) > strend)
1241 if (update_minmatch++)
1242 minmatch = had_zerolen;
1244 if (rx->reganch & RE_USE_INTUIT &&
1245 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1246 PL_bostr = truebase;
1247 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1251 if ( (rx->reganch & ROPT_CHECK_ALL)
1253 && ((rx->reganch & ROPT_NOSCAN)
1254 || !((rx->reganch & RE_INTUIT_TAIL)
1255 && (r_flags & REXEC_SCREAM)))
1256 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1259 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1262 if (dynpm->op_pmflags & PMf_ONCE)
1263 dynpm->op_pmdynflags |= PMdf_USED;
1272 RX_MATCH_TAINTED_on(rx);
1273 TAINT_IF(RX_MATCH_TAINTED(rx));
1274 if (gimme == G_ARRAY) {
1275 I32 nparens, i, len;
1277 nparens = rx->nparens;
1278 if (global && !nparens)
1282 SPAGAIN; /* EVAL blocks could move the stack. */
1283 EXTEND(SP, nparens + i);
1284 EXTEND_MORTAL(nparens + i);
1285 for (i = !i; i <= nparens; i++) {
1286 PUSHs(sv_newmortal());
1288 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1289 len = rx->endp[i] - rx->startp[i];
1290 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1291 len < 0 || len > strend - s)
1292 DIE(aTHX_ "panic: pp_match start/end pointers");
1293 s = rx->startp[i] + truebase;
1294 sv_setpvn(*SP, s, len);
1295 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1300 if (dynpm->op_pmflags & PMf_CONTINUE) {
1302 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1303 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1305 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1306 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1308 if (rx->startp[0] != -1) {
1309 mg->mg_len = rx->endp[0];
1310 if (rx->startp[0] == rx->endp[0])
1311 mg->mg_flags |= MGf_MINMATCH;
1313 mg->mg_flags &= ~MGf_MINMATCH;
1316 had_zerolen = (rx->startp[0] != -1
1317 && rx->startp[0] == rx->endp[0]);
1318 PUTBACK; /* EVAL blocks may use stack */
1319 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1324 LEAVE_SCOPE(oldsave);
1330 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1331 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1333 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1334 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1336 if (rx->startp[0] != -1) {
1337 mg->mg_len = rx->endp[0];
1338 if (rx->startp[0] == rx->endp[0])
1339 mg->mg_flags |= MGf_MINMATCH;
1341 mg->mg_flags &= ~MGf_MINMATCH;
1344 LEAVE_SCOPE(oldsave);
1348 yup: /* Confirmed by INTUIT */
1350 RX_MATCH_TAINTED_on(rx);
1351 TAINT_IF(RX_MATCH_TAINTED(rx));
1353 if (dynpm->op_pmflags & PMf_ONCE)
1354 dynpm->op_pmdynflags |= PMdf_USED;
1355 if (RX_MATCH_COPIED(rx))
1356 Safefree(rx->subbeg);
1357 RX_MATCH_COPIED_off(rx);
1358 rx->subbeg = Nullch;
1360 rx->subbeg = truebase;
1361 rx->startp[0] = s - truebase;
1362 if (PL_reg_match_utf8) {
1363 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1364 rx->endp[0] = t - truebase;
1367 rx->endp[0] = s - truebase + rx->minlen;
1369 rx->sublen = strend - truebase;
1372 if (PL_sawampersand) {
1375 rx->subbeg = savepvn(t, strend - t);
1376 rx->sublen = strend - t;
1377 RX_MATCH_COPIED_on(rx);
1378 off = rx->startp[0] = s - t;
1379 rx->endp[0] = off + rx->minlen;
1381 else { /* startp/endp are used by @- @+. */
1382 rx->startp[0] = s - truebase;
1383 rx->endp[0] = s - truebase + rx->minlen;
1385 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1386 LEAVE_SCOPE(oldsave);
1391 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1392 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1393 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1398 LEAVE_SCOPE(oldsave);
1399 if (gimme == G_ARRAY)
1405 Perl_do_readline(pTHX)
1407 dSP; dTARGETSTACKED;
1412 register IO *io = GvIO(PL_last_in_gv);
1413 register I32 type = PL_op->op_type;
1414 I32 gimme = GIMME_V;
1417 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1419 XPUSHs(SvTIED_obj((SV*)io, mg));
1422 call_method("READLINE", gimme);
1425 if (gimme == G_SCALAR) {
1427 SvSetSV_nosteal(TARG, result);
1436 if (IoFLAGS(io) & IOf_ARGV) {
1437 if (IoFLAGS(io) & IOf_START) {
1439 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1440 IoFLAGS(io) &= ~IOf_START;
1441 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1442 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1443 SvSETMAGIC(GvSV(PL_last_in_gv));
1448 fp = nextargv(PL_last_in_gv);
1449 if (!fp) { /* Note: fp != IoIFP(io) */
1450 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1453 else if (type == OP_GLOB)
1454 fp = Perl_start_glob(aTHX_ POPs, io);
1456 else if (type == OP_GLOB)
1458 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1459 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1463 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1464 && (!io || !(IoFLAGS(io) & IOf_START))) {
1465 if (type == OP_GLOB)
1466 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1467 "glob failed (can't start child: %s)",
1470 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1472 if (gimme == G_SCALAR) {
1473 (void)SvOK_off(TARG);
1479 if (gimme == G_SCALAR) {
1483 (void)SvUPGRADE(sv, SVt_PV);
1484 tmplen = SvLEN(sv); /* remember if already alloced */
1486 Sv_Grow(sv, 80); /* try short-buffering it */
1488 if (type == OP_RCATLINE && SvOK(sv)) {
1491 (void)SvPV_force(sv, n_a);
1497 sv = sv_2mortal(NEWSV(57, 80));
1501 /* This should not be marked tainted if the fp is marked clean */
1502 #define MAYBE_TAINT_LINE(io, sv) \
1503 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1508 /* delay EOF state for a snarfed empty file */
1509 #define SNARF_EOF(gimme,rs,io,sv) \
1510 (gimme != G_SCALAR || SvCUR(sv) \
1511 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1515 if (!sv_gets(sv, fp, offset)
1516 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1518 PerlIO_clearerr(fp);
1519 if (IoFLAGS(io) & IOf_ARGV) {
1520 fp = nextargv(PL_last_in_gv);
1523 (void)do_close(PL_last_in_gv, FALSE);
1525 else if (type == OP_GLOB) {
1526 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1527 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1528 "glob failed (child exited with status %d%s)",
1529 (int)(STATUS_CURRENT >> 8),
1530 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1533 if (gimme == G_SCALAR) {
1534 (void)SvOK_off(TARG);
1538 MAYBE_TAINT_LINE(io, sv);
1541 MAYBE_TAINT_LINE(io, sv);
1543 IoFLAGS(io) |= IOf_NOLINE;
1547 if (type == OP_GLOB) {
1550 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1551 tmps = SvEND(sv) - 1;
1552 if (*tmps == *SvPVX(PL_rs)) {
1557 for (tmps = SvPVX(sv); *tmps; tmps++)
1558 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1559 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1561 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1562 (void)POPs; /* Unmatched wildcard? Chuck it... */
1566 if (gimme == G_ARRAY) {
1567 if (SvLEN(sv) - SvCUR(sv) > 20) {
1568 SvLEN_set(sv, SvCUR(sv)+1);
1569 Renew(SvPVX(sv), SvLEN(sv), char);
1571 sv = sv_2mortal(NEWSV(58, 80));
1574 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1575 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1579 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1580 Renew(SvPVX(sv), SvLEN(sv), char);
1589 register PERL_CONTEXT *cx;
1590 I32 gimme = OP_GIMME(PL_op, -1);
1593 if (cxstack_ix >= 0)
1594 gimme = cxstack[cxstack_ix].blk_gimme;
1602 PUSHBLOCK(cx, CXt_BLOCK, SP);
1614 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1615 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1617 #ifdef PERL_COPY_ON_WRITE
1618 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1620 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1624 if (SvTYPE(hv) == SVt_PVHV) {
1625 if (PL_op->op_private & OPpLVAL_INTRO) {
1628 /* does the element we're localizing already exist? */
1630 /* can we determine whether it exists? */
1632 || mg_find((SV*)hv, PERL_MAGIC_env)
1633 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1634 /* Try to preserve the existenceness of a tied hash
1635 * element by using EXISTS and DELETE if possible.
1636 * Fallback to FETCH and STORE otherwise */
1637 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1638 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1639 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1641 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1644 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1645 svp = he ? &HeVAL(he) : 0;
1651 if (!svp || *svp == &PL_sv_undef) {
1656 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1658 lv = sv_newmortal();
1659 sv_upgrade(lv, SVt_PVLV);
1661 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1662 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1663 LvTARG(lv) = SvREFCNT_inc(hv);
1668 if (PL_op->op_private & OPpLVAL_INTRO) {
1669 if (HvNAME(hv) && isGV(*svp))
1670 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1674 char *key = SvPV(keysv, keylen);
1675 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1677 save_helem(hv, keysv, svp);
1680 else if (PL_op->op_private & OPpDEREF)
1681 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1683 sv = (svp ? *svp : &PL_sv_undef);
1684 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1685 * Pushing the magical RHS on to the stack is useless, since
1686 * that magic is soon destined to be misled by the local(),
1687 * and thus the later pp_sassign() will fail to mg_get() the
1688 * old value. This should also cure problems with delayed
1689 * mg_get()s. GSAR 98-07-03 */
1690 if (!lval && SvGMAGICAL(sv))
1691 sv = sv_mortalcopy(sv);
1699 register PERL_CONTEXT *cx;
1705 if (PL_op->op_flags & OPf_SPECIAL) {
1706 cx = &cxstack[cxstack_ix];
1707 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1712 gimme = OP_GIMME(PL_op, -1);
1714 if (cxstack_ix >= 0)
1715 gimme = cxstack[cxstack_ix].blk_gimme;
1721 if (gimme == G_VOID)
1723 else if (gimme == G_SCALAR) {
1726 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1729 *MARK = sv_mortalcopy(TOPs);
1732 *MARK = &PL_sv_undef;
1736 else if (gimme == G_ARRAY) {
1737 /* in case LEAVE wipes old return values */
1738 for (mark = newsp + 1; mark <= SP; mark++) {
1739 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1740 *mark = sv_mortalcopy(*mark);
1741 TAINT_NOT; /* Each item is independent */
1745 PL_curpm = newpm; /* Don't pop $1 et al till now */
1755 register PERL_CONTEXT *cx;
1761 cx = &cxstack[cxstack_ix];
1762 if (CxTYPE(cx) != CXt_LOOP)
1763 DIE(aTHX_ "panic: pp_iter");
1765 itersvp = CxITERVAR(cx);
1766 av = cx->blk_loop.iterary;
1767 if (SvTYPE(av) != SVt_PVAV) {
1768 /* iterate ($min .. $max) */
1769 if (cx->blk_loop.iterlval) {
1770 /* string increment */
1771 register SV* cur = cx->blk_loop.iterlval;
1773 char *max = SvPV((SV*)av, maxlen);
1774 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1775 #ifndef USE_5005THREADS /* don't risk potential race */
1776 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1777 /* safe to reuse old SV */
1778 sv_setsv(*itersvp, cur);
1783 /* we need a fresh SV every time so that loop body sees a
1784 * completely new SV for closures/references to work as
1786 SvREFCNT_dec(*itersvp);
1787 *itersvp = newSVsv(cur);
1789 if (strEQ(SvPVX(cur), max))
1790 sv_setiv(cur, 0); /* terminate next time */
1797 /* integer increment */
1798 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1801 #ifndef USE_5005THREADS /* don't risk potential race */
1802 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1803 /* safe to reuse old SV */
1804 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1809 /* we need a fresh SV every time so that loop body sees a
1810 * completely new SV for closures/references to work as they
1812 SvREFCNT_dec(*itersvp);
1813 *itersvp = newSViv(cx->blk_loop.iterix++);
1819 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1822 SvREFCNT_dec(*itersvp);
1824 if (SvMAGICAL(av) || AvREIFY(av)) {
1825 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1832 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1838 if (av != PL_curstack && sv == &PL_sv_undef) {
1839 SV *lv = cx->blk_loop.iterlval;
1840 if (lv && SvREFCNT(lv) > 1) {
1845 SvREFCNT_dec(LvTARG(lv));
1847 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1848 sv_upgrade(lv, SVt_PVLV);
1850 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1852 LvTARG(lv) = SvREFCNT_inc(av);
1853 LvTARGOFF(lv) = cx->blk_loop.iterix;
1854 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1858 *itersvp = SvREFCNT_inc(sv);
1865 register PMOP *pm = cPMOP;
1881 register REGEXP *rx = PM_GETRE(pm);
1883 int force_on_match = 0;
1884 I32 oldsave = PL_savestack_ix;
1886 bool doutf8 = FALSE;
1888 /* known replacement string? */
1889 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1890 if (PL_op->op_flags & OPf_STACKED)
1898 sv_force_normal_flags(TARG,0);
1899 if (SvREADONLY(TARG)
1900 || (SvTYPE(TARG) > SVt_PVLV
1901 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1902 DIE(aTHX_ PL_no_modify);
1905 s = SvPV(TARG, len);
1906 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1908 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1909 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1914 PL_reg_match_utf8 = DO_UTF8(TARG);
1918 DIE(aTHX_ "panic: pp_subst");
1921 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1922 maxiters = 2 * slen + 10; /* We can match twice at each
1923 position, once with zero-length,
1924 second time with non-zero. */
1926 if (!rx->prelen && PL_curpm) {
1930 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1931 ? REXEC_COPY_STR : 0;
1933 r_flags |= REXEC_SCREAM;
1934 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1935 SAVEINT(PL_multiline);
1936 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1939 if (rx->reganch & RE_USE_INTUIT) {
1941 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1945 /* How to do it in subst? */
1946 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1948 && ((rx->reganch & ROPT_NOSCAN)
1949 || !((rx->reganch & RE_INTUIT_TAIL)
1950 && (r_flags & REXEC_SCREAM))))
1955 /* only replace once? */
1956 once = !(rpm->op_pmflags & PMf_GLOBAL);
1958 /* known replacement string? */
1960 /* replacement needing upgrading? */
1961 if (DO_UTF8(TARG) && !doutf8) {
1962 SV *nsv = sv_newmortal();
1965 sv_recode_to_utf8(nsv, PL_encoding);
1967 sv_utf8_upgrade(nsv);
1968 c = SvPV(nsv, clen);
1972 c = SvPV(dstr, clen);
1973 doutf8 = DO_UTF8(dstr);
1981 /* can do inplace substitution? */
1982 if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1983 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1984 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1985 r_flags | REXEC_CHECKED))
1989 LEAVE_SCOPE(oldsave);
1992 if (force_on_match) {
1994 s = SvPV_force(TARG, len);
1999 SvSCREAM_off(TARG); /* disable possible screamer */
2001 rxtainted |= RX_MATCH_TAINTED(rx);
2002 m = orig + rx->startp[0];
2003 d = orig + rx->endp[0];
2005 if (m - s > strend - d) { /* faster to shorten from end */
2007 Copy(c, m, clen, char);
2012 Move(d, m, i, char);
2016 SvCUR_set(TARG, m - s);
2019 else if ((i = m - s)) { /* faster from front */
2027 Copy(c, m, clen, char);
2032 Copy(c, d, clen, char);
2037 TAINT_IF(rxtainted & 1);
2043 if (iters++ > maxiters)
2044 DIE(aTHX_ "Substitution loop");
2045 rxtainted |= RX_MATCH_TAINTED(rx);
2046 m = rx->startp[0] + orig;
2050 Move(s, d, i, char);
2054 Copy(c, d, clen, char);
2057 s = rx->endp[0] + orig;
2058 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2060 /* don't match same null twice */
2061 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2064 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2065 Move(s, d, i+1, char); /* include the NUL */
2067 TAINT_IF(rxtainted & 1);
2069 PUSHs(sv_2mortal(newSViv((I32)iters)));
2071 (void)SvPOK_only_UTF8(TARG);
2072 TAINT_IF(rxtainted);
2073 if (SvSMAGICAL(TARG)) {
2081 LEAVE_SCOPE(oldsave);
2085 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2086 r_flags | REXEC_CHECKED))
2088 if (force_on_match) {
2090 s = SvPV_force(TARG, len);
2093 rxtainted |= RX_MATCH_TAINTED(rx);
2094 dstr = NEWSV(25, len);
2095 sv_setpvn(dstr, m, s-m);
2100 register PERL_CONTEXT *cx;
2103 RETURNOP(cPMOP->op_pmreplroot);
2105 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2107 if (iters++ > maxiters)
2108 DIE(aTHX_ "Substitution loop");
2109 rxtainted |= RX_MATCH_TAINTED(rx);
2110 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2115 strend = s + (strend - m);
2117 m = rx->startp[0] + orig;
2118 sv_catpvn(dstr, s, m-s);
2119 s = rx->endp[0] + orig;
2121 sv_catpvn(dstr, c, clen);
2124 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2125 TARG, NULL, r_flags));
2126 if (doutf8 && !DO_UTF8(dstr)) {
2127 SV* nsv = sv_2mortal(newSVpvn(s, strend - s));
2129 sv_utf8_upgrade(nsv);
2130 sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv));
2133 sv_catpvn(dstr, s, strend - s);
2135 (void)SvOOK_off(TARG);
2136 Safefree(SvPVX(TARG));
2137 SvPVX(TARG) = SvPVX(dstr);
2138 SvCUR_set(TARG, SvCUR(dstr));
2139 SvLEN_set(TARG, SvLEN(dstr));
2140 doutf8 |= DO_UTF8(dstr);
2144 TAINT_IF(rxtainted & 1);
2146 PUSHs(sv_2mortal(newSViv((I32)iters)));
2148 (void)SvPOK_only(TARG);
2151 TAINT_IF(rxtainted);
2154 LEAVE_SCOPE(oldsave);
2163 LEAVE_SCOPE(oldsave);
2172 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2173 ++*PL_markstack_ptr;
2174 LEAVE; /* exit inner scope */
2177 if (PL_stack_base + *PL_markstack_ptr > SP) {
2179 I32 gimme = GIMME_V;
2181 LEAVE; /* exit outer scope */
2182 (void)POPMARK; /* pop src */
2183 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2184 (void)POPMARK; /* pop dst */
2185 SP = PL_stack_base + POPMARK; /* pop original mark */
2186 if (gimme == G_SCALAR) {
2190 else if (gimme == G_ARRAY)
2197 ENTER; /* enter inner scope */
2200 src = PL_stack_base[*PL_markstack_ptr];
2204 RETURNOP(cLOGOP->op_other);
2215 register PERL_CONTEXT *cx;
2221 if (gimme == G_SCALAR) {
2224 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2226 *MARK = SvREFCNT_inc(TOPs);
2231 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2233 *MARK = sv_mortalcopy(sv);
2238 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2242 *MARK = &PL_sv_undef;
2246 else if (gimme == G_ARRAY) {
2247 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2248 if (!SvTEMP(*MARK)) {
2249 *MARK = sv_mortalcopy(*MARK);
2250 TAINT_NOT; /* Each item is independent */
2256 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2257 PL_curpm = newpm; /* ... and pop $1 et al */
2261 return pop_return();
2264 /* This duplicates the above code because the above code must not
2265 * get any slower by more conditions */
2273 register PERL_CONTEXT *cx;
2280 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2281 /* We are an argument to a function or grep().
2282 * This kind of lvalueness was legal before lvalue
2283 * subroutines too, so be backward compatible:
2284 * cannot report errors. */
2286 /* Scalar context *is* possible, on the LHS of -> only,
2287 * as in f()->meth(). But this is not an lvalue. */
2288 if (gimme == G_SCALAR)
2290 if (gimme == G_ARRAY) {
2291 if (!CvLVALUE(cx->blk_sub.cv))
2292 goto temporise_array;
2293 EXTEND_MORTAL(SP - newsp);
2294 for (mark = newsp + 1; mark <= SP; mark++) {
2297 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2298 *mark = sv_mortalcopy(*mark);
2300 /* Can be a localized value subject to deletion. */
2301 PL_tmps_stack[++PL_tmps_ix] = *mark;
2302 (void)SvREFCNT_inc(*mark);
2307 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2308 /* Here we go for robustness, not for speed, so we change all
2309 * the refcounts so the caller gets a live guy. Cannot set
2310 * TEMP, so sv_2mortal is out of question. */
2311 if (!CvLVALUE(cx->blk_sub.cv)) {
2316 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2318 if (gimme == G_SCALAR) {
2322 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2327 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2328 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2330 else { /* Can be a localized value
2331 * subject to deletion. */
2332 PL_tmps_stack[++PL_tmps_ix] = *mark;
2333 (void)SvREFCNT_inc(*mark);
2336 else { /* Should not happen? */
2341 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2342 (MARK > SP ? "Empty array" : "Array"));
2346 else if (gimme == G_ARRAY) {
2347 EXTEND_MORTAL(SP - newsp);
2348 for (mark = newsp + 1; mark <= SP; mark++) {
2349 if (*mark != &PL_sv_undef
2350 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2351 /* Might be flattened array after $#array = */
2357 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2358 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2361 /* Can be a localized value subject to deletion. */
2362 PL_tmps_stack[++PL_tmps_ix] = *mark;
2363 (void)SvREFCNT_inc(*mark);
2369 if (gimme == G_SCALAR) {
2373 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2375 *MARK = SvREFCNT_inc(TOPs);
2380 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2382 *MARK = sv_mortalcopy(sv);
2387 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2391 *MARK = &PL_sv_undef;
2395 else if (gimme == G_ARRAY) {
2397 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2398 if (!SvTEMP(*MARK)) {
2399 *MARK = sv_mortalcopy(*MARK);
2400 TAINT_NOT; /* Each item is independent */
2407 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2408 PL_curpm = newpm; /* ... and pop $1 et al */
2412 return pop_return();
2417 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2419 SV *dbsv = GvSV(PL_DBsub);
2421 if (!PERLDB_SUB_NN) {
2425 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2426 || strEQ(GvNAME(gv), "END")
2427 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2428 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2429 && (gv = (GV*)*svp) ))) {
2430 /* Use GV from the stack as a fallback. */
2431 /* GV is potentially non-unique, or contain different CV. */
2432 SV *tmp = newRV((SV*)cv);
2433 sv_setsv(dbsv, tmp);
2437 gv_efullname3(dbsv, gv, Nullch);
2441 (void)SvUPGRADE(dbsv, SVt_PVIV);
2442 (void)SvIOK_on(dbsv);
2443 SAVEIV(SvIVX(dbsv));
2444 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2448 PL_curcopdb = PL_curcop;
2449 cv = GvCV(PL_DBsub);
2459 register PERL_CONTEXT *cx;
2461 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2464 DIE(aTHX_ "Not a CODE reference");
2465 switch (SvTYPE(sv)) {
2471 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2473 SP = PL_stack_base + POPMARK;
2476 if (SvGMAGICAL(sv)) {
2480 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2483 sym = SvPV(sv, n_a);
2485 DIE(aTHX_ PL_no_usym, "a subroutine");
2486 if (PL_op->op_private & HINT_STRICT_REFS)
2487 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2488 cv = get_cv(sym, TRUE);
2493 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2494 tryAMAGICunDEREF(to_cv);
2497 if (SvTYPE(cv) == SVt_PVCV)
2502 DIE(aTHX_ "Not a CODE reference");
2507 if (!(cv = GvCVu((GV*)sv)))
2508 cv = sv_2cv(sv, &stash, &gv, FALSE);
2521 if (!CvROOT(cv) && !CvXSUB(cv)) {
2525 /* anonymous or undef'd function leaves us no recourse */
2526 if (CvANON(cv) || !(gv = CvGV(cv)))
2527 DIE(aTHX_ "Undefined subroutine called");
2529 /* autoloaded stub? */
2530 if (cv != GvCV(gv)) {
2533 /* should call AUTOLOAD now? */
2536 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2543 sub_name = sv_newmortal();
2544 gv_efullname3(sub_name, gv, Nullch);
2545 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2549 DIE(aTHX_ "Not a CODE reference");
2554 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2555 cv = get_db_sub(&sv, cv);
2557 DIE(aTHX_ "No DBsub routine");
2560 #ifdef USE_5005THREADS
2562 * First we need to check if the sub or method requires locking.
2563 * If so, we gain a lock on the CV, the first argument or the
2564 * stash (for static methods), as appropriate. This has to be
2565 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2566 * reschedule by returning a new op.
2568 MUTEX_LOCK(CvMUTEXP(cv));
2569 if (CvFLAGS(cv) & CVf_LOCKED) {
2571 if (CvFLAGS(cv) & CVf_METHOD) {
2572 if (SP > PL_stack_base + TOPMARK)
2573 sv = *(PL_stack_base + TOPMARK + 1);
2575 AV *av = (AV*)PAD_SVl(0);
2576 if (hasargs || !av || AvFILLp(av) < 0
2577 || !(sv = AvARRAY(av)[0]))
2579 MUTEX_UNLOCK(CvMUTEXP(cv));
2580 DIE(aTHX_ "no argument for locked method call");
2587 char *stashname = SvPV(sv, len);
2588 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2594 MUTEX_UNLOCK(CvMUTEXP(cv));
2595 mg = condpair_magic(sv);
2596 MUTEX_LOCK(MgMUTEXP(mg));
2597 if (MgOWNER(mg) == thr)
2598 MUTEX_UNLOCK(MgMUTEXP(mg));
2601 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2603 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2605 MUTEX_UNLOCK(MgMUTEXP(mg));
2606 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2608 MUTEX_LOCK(CvMUTEXP(cv));
2611 * Now we have permission to enter the sub, we must distinguish
2612 * four cases. (0) It's an XSUB (in which case we don't care
2613 * about ownership); (1) it's ours already (and we're recursing);
2614 * (2) it's free (but we may already be using a cached clone);
2615 * (3) another thread owns it. Case (1) is easy: we just use it.
2616 * Case (2) means we look for a clone--if we have one, use it
2617 * otherwise grab ownership of cv. Case (3) means we look for a
2618 * clone (for non-XSUBs) and have to create one if we don't
2620 * Why look for a clone in case (2) when we could just grab
2621 * ownership of cv straight away? Well, we could be recursing,
2622 * i.e. we originally tried to enter cv while another thread
2623 * owned it (hence we used a clone) but it has been freed up
2624 * and we're now recursing into it. It may or may not be "better"
2625 * to use the clone but at least CvDEPTH can be trusted.
2627 if (CvOWNER(cv) == thr || CvXSUB(cv))
2628 MUTEX_UNLOCK(CvMUTEXP(cv));
2630 /* Case (2) or (3) */
2634 * XXX Might it be better to release CvMUTEXP(cv) while we
2635 * do the hv_fetch? We might find someone has pinched it
2636 * when we look again, in which case we would be in case
2637 * (3) instead of (2) so we'd have to clone. Would the fact
2638 * that we released the mutex more quickly make up for this?
2640 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2642 /* We already have a clone to use */
2643 MUTEX_UNLOCK(CvMUTEXP(cv));
2645 DEBUG_S(PerlIO_printf(Perl_debug_log,
2646 "entersub: %p already has clone %p:%s\n",
2647 thr, cv, SvPEEK((SV*)cv)));
2650 if (CvDEPTH(cv) == 0)
2651 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2654 /* (2) => grab ownership of cv. (3) => make clone */
2658 MUTEX_UNLOCK(CvMUTEXP(cv));
2659 DEBUG_S(PerlIO_printf(Perl_debug_log,
2660 "entersub: %p grabbing %p:%s in stash %s\n",
2661 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2662 HvNAME(CvSTASH(cv)) : "(none)"));
2665 /* Make a new clone. */
2667 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2668 MUTEX_UNLOCK(CvMUTEXP(cv));
2669 DEBUG_S((PerlIO_printf(Perl_debug_log,
2670 "entersub: %p cloning %p:%s\n",
2671 thr, cv, SvPEEK((SV*)cv))));
2673 * We're creating a new clone so there's no race
2674 * between the original MUTEX_UNLOCK and the
2675 * SvREFCNT_inc since no one will be trying to undef
2676 * it out from underneath us. At least, I don't think
2679 clonecv = cv_clone(cv);
2680 SvREFCNT_dec(cv); /* finished with this */
2681 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2682 CvOWNER(clonecv) = thr;
2686 DEBUG_S(if (CvDEPTH(cv) != 0)
2687 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2689 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2692 #endif /* USE_5005THREADS */
2695 #ifdef PERL_XSUB_OLDSTYLE
2696 if (CvOLDSTYLE(cv)) {
2697 I32 (*fp3)(int,int,int);
2699 register I32 items = SP - MARK;
2700 /* We dont worry to copy from @_. */
2705 PL_stack_sp = mark + 1;
2706 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2707 items = (*fp3)(CvXSUBANY(cv).any_i32,
2708 MARK - PL_stack_base + 1,
2710 PL_stack_sp = PL_stack_base + items;
2713 #endif /* PERL_XSUB_OLDSTYLE */
2715 I32 markix = TOPMARK;
2720 /* Need to copy @_ to stack. Alternative may be to
2721 * switch stack to @_, and copy return values
2722 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2725 #ifdef USE_5005THREADS
2726 av = (AV*)PAD_SVl(0);
2728 av = GvAV(PL_defgv);
2729 #endif /* USE_5005THREADS */
2730 items = AvFILLp(av) + 1; /* @_ is not tieable */
2733 /* Mark is at the end of the stack. */
2735 Copy(AvARRAY(av), SP + 1, items, SV*);
2740 /* We assume first XSUB in &DB::sub is the called one. */
2742 SAVEVPTR(PL_curcop);
2743 PL_curcop = PL_curcopdb;
2746 /* Do we need to open block here? XXXX */
2747 (void)(*CvXSUB(cv))(aTHX_ cv);
2749 /* Enforce some sanity in scalar context. */
2750 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2751 if (markix > PL_stack_sp - PL_stack_base)
2752 *(PL_stack_base + markix) = &PL_sv_undef;
2754 *(PL_stack_base + markix) = *PL_stack_sp;
2755 PL_stack_sp = PL_stack_base + markix;
2763 register I32 items = SP - MARK;
2764 AV* padlist = CvPADLIST(cv);
2765 push_return(PL_op->op_next);
2766 PUSHBLOCK(cx, CXt_SUB, MARK);
2769 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2770 * that eval'' ops within this sub know the correct lexical space.
2771 * Owing the speed considerations, we choose to search for the cv
2772 * in doeval() instead.
2774 if (CvDEPTH(cv) < 2)
2775 (void)SvREFCNT_inc(cv);
2777 PERL_STACK_OVERFLOW_CHECK();
2778 pad_push(padlist, CvDEPTH(cv), 1);
2780 #ifdef USE_5005THREADS
2782 AV* av = (AV*)PAD_SVl(0);
2784 items = AvFILLp(av) + 1;
2786 /* Mark is at the end of the stack. */
2788 Copy(AvARRAY(av), SP + 1, items, SV*);
2793 #endif /* USE_5005THREADS */
2794 PAD_SET_CUR(padlist, CvDEPTH(cv));
2795 #ifndef USE_5005THREADS
2797 #endif /* USE_5005THREADS */
2803 DEBUG_S(PerlIO_printf(Perl_debug_log,
2804 "%p entersub preparing @_\n", thr));
2806 av = (AV*)PAD_SVl(0);
2808 /* @_ is normally not REAL--this should only ever
2809 * happen when DB::sub() calls things that modify @_ */
2814 #ifndef USE_5005THREADS
2815 cx->blk_sub.savearray = GvAV(PL_defgv);
2816 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2817 #endif /* USE_5005THREADS */
2818 CX_CURPAD_SAVE(cx->blk_sub);
2819 cx->blk_sub.argarray = av;
2822 if (items > AvMAX(av) + 1) {
2824 if (AvARRAY(av) != ary) {
2825 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2826 SvPVX(av) = (char*)ary;
2828 if (items > AvMAX(av) + 1) {
2829 AvMAX(av) = items - 1;
2830 Renew(ary,items,SV*);
2832 SvPVX(av) = (char*)ary;
2835 Copy(MARK,AvARRAY(av),items,SV*);
2836 AvFILLp(av) = items - 1;
2844 /* warning must come *after* we fully set up the context
2845 * stuff so that __WARN__ handlers can safely dounwind()
2848 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2849 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2850 sub_crush_depth(cv);
2852 DEBUG_S(PerlIO_printf(Perl_debug_log,
2853 "%p entersub returning %p\n", thr, CvSTART(cv)));
2855 RETURNOP(CvSTART(cv));
2860 Perl_sub_crush_depth(pTHX_ CV *cv)
2863 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2865 SV* tmpstr = sv_newmortal();
2866 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2867 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
2877 IV elem = SvIV(elemsv);
2879 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2880 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2883 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2884 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2886 elem -= PL_curcop->cop_arybase;
2887 if (SvTYPE(av) != SVt_PVAV)
2889 svp = av_fetch(av, elem, lval && !defer);
2891 if (!svp || *svp == &PL_sv_undef) {
2894 DIE(aTHX_ PL_no_aelem, elem);
2895 lv = sv_newmortal();
2896 sv_upgrade(lv, SVt_PVLV);
2898 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2899 LvTARG(lv) = SvREFCNT_inc(av);
2900 LvTARGOFF(lv) = elem;
2905 if (PL_op->op_private & OPpLVAL_INTRO)
2906 save_aelem(av, elem, svp);
2907 else if (PL_op->op_private & OPpDEREF)
2908 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2910 sv = (svp ? *svp : &PL_sv_undef);
2911 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2912 sv = sv_mortalcopy(sv);
2918 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2924 Perl_croak(aTHX_ PL_no_modify);
2925 if (SvTYPE(sv) < SVt_RV)
2926 sv_upgrade(sv, SVt_RV);
2927 else if (SvTYPE(sv) >= SVt_PV) {
2928 (void)SvOOK_off(sv);
2929 Safefree(SvPVX(sv));
2930 SvLEN(sv) = SvCUR(sv) = 0;
2934 SvRV(sv) = NEWSV(355,0);
2937 SvRV(sv) = (SV*)newAV();
2940 SvRV(sv) = (SV*)newHV();
2955 if (SvTYPE(rsv) == SVt_PVCV) {
2961 SETs(method_common(sv, Null(U32*)));
2968 SV* sv = cSVOP->op_sv;
2969 U32 hash = SvUVX(sv);
2971 XPUSHs(method_common(sv, &hash));
2976 S_method_common(pTHX_ SV* meth, U32* hashp)
2987 name = SvPV(meth, namelen);
2988 sv = *(PL_stack_base + TOPMARK + 1);
2991 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3000 /* this isn't a reference */
3003 !(packname = SvPV(sv, packlen)) ||
3004 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3005 !(ob=(SV*)GvIO(iogv)))
3007 /* this isn't the name of a filehandle either */
3009 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3010 ? !isIDFIRST_utf8((U8*)packname)
3011 : !isIDFIRST(*packname)
3014 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3015 SvOK(sv) ? "without a package or object reference"
3016 : "on an undefined value");
3018 /* assume it's a package name */
3019 stash = gv_stashpvn(packname, packlen, FALSE);
3022 /* it _is_ a filehandle name -- replace with a reference */
3023 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3026 /* if we got here, ob should be a reference or a glob */
3027 if (!ob || !(SvOBJECT(ob)
3028 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3031 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3035 stash = SvSTASH(ob);
3038 /* NOTE: stash may be null, hope hv_fetch_ent and
3039 gv_fetchmethod can cope (it seems they can) */
3041 /* shortcut for simple names */
3043 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3045 gv = (GV*)HeVAL(he);
3046 if (isGV(gv) && GvCV(gv) &&
3047 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3048 return (SV*)GvCV(gv);
3052 gv = gv_fetchmethod(stash, name);
3055 /* This code tries to figure out just what went wrong with
3056 gv_fetchmethod. It therefore needs to duplicate a lot of
3057 the internals of that function. We can't move it inside
3058 Perl_gv_fetchmethod_autoload(), however, since that would
3059 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3066 for (p = name; *p; p++) {
3068 sep = p, leaf = p + 1;
3069 else if (*p == ':' && *(p + 1) == ':')
3070 sep = p, leaf = p + 2;
3072 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3073 /* the method name is unqualified or starts with SUPER:: */
3074 packname = sep ? CopSTASHPV(PL_curcop) :
3075 stash ? HvNAME(stash) : packname;
3076 packlen = strlen(packname);
3079 /* the method name is qualified */
3081 packlen = sep - name;
3084 /* we're relying on gv_fetchmethod not autovivifying the stash */
3085 if (gv_stashpvn(packname, packlen, FALSE)) {
3087 "Can't locate object method \"%s\" via package \"%.*s\"",
3088 leaf, (int)packlen, packname);
3092 "Can't locate object method \"%s\" via package \"%.*s\""
3093 " (perhaps you forgot to load \"%.*s\"?)",
3094 leaf, (int)packlen, packname, (int)packlen, packname);
3097 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3100 #ifdef USE_5005THREADS
3102 unset_cvowner(pTHX_ void *cvarg)
3104 register CV* cv = (CV *) cvarg;
3106 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3107 thr, cv, SvPEEK((SV*)cv))));
3108 MUTEX_LOCK(CvMUTEXP(cv));
3109 DEBUG_S(if (CvDEPTH(cv) != 0)
3110 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3112 assert(thr == CvOWNER(cv));
3114 MUTEX_UNLOCK(CvMUTEXP(cv));
3117 #endif /* USE_5005THREADS */