3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
20 #define PERL_IN_PP_HOT_C
34 PL_curcop = (COP*)PL_op;
35 TAINT_NOT; /* Each statement is presumed innocent */
36 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
45 if (PL_op->op_private & OPpLVAL_INTRO)
46 PUSHs(save_scalar(cGVOP_gv));
48 PUSHs(GvSV(cGVOP_gv));
59 PL_curcop = (COP*)PL_op;
65 PUSHMARK(PL_stack_sp);
80 XPUSHs((SV*)cGVOP_gv);
91 RETURNOP(cLOGOP->op_other);
99 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
101 temp = left; left = right; right = temp;
103 if (PL_tainting && PL_tainted && !SvTAINTED(left))
105 SvSetMagicSV(right, left);
114 RETURNOP(cLOGOP->op_other);
116 RETURNOP(cLOGOP->op_next);
122 TAINT_NOT; /* Each statement is presumed innocent */
123 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
125 oldsave = PL_scopestack[PL_scopestack_ix - 1];
126 LEAVE_SCOPE(oldsave);
132 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
139 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
140 bool rbyte = !SvUTF8(right), rcopied = FALSE;
142 if (TARG == right && right != left) {
143 right = sv_2mortal(newSVpvn(rpv, rlen));
144 rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
149 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
150 lbyte = !SvUTF8(left);
151 sv_setpvn(TARG, lpv, llen);
157 else { /* TARG == left */
158 if (SvGMAGICAL(left))
159 mg_get(left); /* or mg_get(left) may happen here */
162 lpv = SvPV_nomg(left, llen);
163 lbyte = !SvUTF8(left);
166 #if defined(PERL_Y2KWARN)
167 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
168 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
169 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
171 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
172 "about to append an integer to '19'");
177 if (lbyte != rbyte) {
179 sv_utf8_upgrade_nomg(TARG);
182 right = sv_2mortal(newSVpvn(rpv, rlen));
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");
689 else if (PL_op->op_flags & OPf_MOD
690 && PL_op->op_private & OPpLVAL_INTRO)
691 Perl_croak(aTHX_ PL_no_localize_ref);
694 if (SvTYPE(sv) == SVt_PVAV) {
696 if (PL_op->op_flags & OPf_REF) {
701 if (GIMME == G_SCALAR)
702 Perl_croak(aTHX_ "Can't return array to lvalue"
711 if (SvTYPE(sv) != SVt_PVGV) {
715 if (SvGMAGICAL(sv)) {
721 if (PL_op->op_flags & OPf_REF ||
722 PL_op->op_private & HINT_STRICT_REFS)
723 DIE(aTHX_ PL_no_usym, "an ARRAY");
724 if (ckWARN(WARN_UNINITIALIZED))
726 if (GIMME == G_ARRAY) {
733 if ((PL_op->op_flags & OPf_SPECIAL) &&
734 !(PL_op->op_flags & OPf_MOD))
736 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
738 && (!is_gv_magical(sym,len,0)
739 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
745 if (PL_op->op_private & HINT_STRICT_REFS)
746 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
747 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
754 if (PL_op->op_private & OPpLVAL_INTRO)
756 if (PL_op->op_flags & OPf_REF) {
761 if (GIMME == G_SCALAR)
762 Perl_croak(aTHX_ "Can't return array to lvalue"
770 if (GIMME == G_ARRAY) {
771 I32 maxarg = AvFILL(av) + 1;
772 (void)POPs; /* XXXX May be optimized away? */
774 if (SvRMAGICAL(av)) {
776 for (i=0; i < (U32)maxarg; i++) {
777 SV **svp = av_fetch(av, i, FALSE);
778 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
782 Copy(AvARRAY(av), SP+1, maxarg, SV*);
786 else if (GIMME_V == G_SCALAR) {
788 I32 maxarg = AvFILL(av) + 1;
802 tryAMAGICunDEREF(to_hv);
805 if (SvTYPE(hv) != SVt_PVHV)
806 DIE(aTHX_ "Not a HASH reference");
807 if (PL_op->op_flags & OPf_REF) {
812 if (gimme != G_ARRAY)
813 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
817 else if (PL_op->op_flags & OPf_MOD
818 && PL_op->op_private & OPpLVAL_INTRO)
819 Perl_croak(aTHX_ PL_no_localize_ref);
822 if (SvTYPE(sv) == SVt_PVHV) {
824 if (PL_op->op_flags & OPf_REF) {
829 if (gimme != G_ARRAY)
830 Perl_croak(aTHX_ "Can't return hash to lvalue"
839 if (SvTYPE(sv) != SVt_PVGV) {
843 if (SvGMAGICAL(sv)) {
849 if (PL_op->op_flags & OPf_REF ||
850 PL_op->op_private & HINT_STRICT_REFS)
851 DIE(aTHX_ PL_no_usym, "a HASH");
852 if (ckWARN(WARN_UNINITIALIZED))
854 if (gimme == G_ARRAY) {
861 if ((PL_op->op_flags & OPf_SPECIAL) &&
862 !(PL_op->op_flags & OPf_MOD))
864 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
866 && (!is_gv_magical(sym,len,0)
867 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
873 if (PL_op->op_private & HINT_STRICT_REFS)
874 DIE(aTHX_ PL_no_symref, sym, "a HASH");
875 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
882 if (PL_op->op_private & OPpLVAL_INTRO)
884 if (PL_op->op_flags & OPf_REF) {
889 if (gimme != G_ARRAY)
890 Perl_croak(aTHX_ "Can't return hash to lvalue"
898 if (gimme == G_ARRAY) { /* array wanted */
899 *PL_stack_sp = (SV*)hv;
902 else if (gimme == G_SCALAR) {
904 if (SvRMAGICAL(hv) && mg_find((SV *)hv, PERL_MAGIC_tied))
905 Perl_croak(aTHX_ "Can't provide tied hash usage; "
906 "use keys(%%hash) to test if empty");
908 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
909 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
919 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
925 if (ckWARN(WARN_MISC)) {
926 if (relem == firstrelem &&
928 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
929 SvTYPE(SvRV(*relem)) == SVt_PVHV))
931 Perl_warner(aTHX_ packWARN(WARN_MISC),
932 "Reference found where even-sized list expected");
935 Perl_warner(aTHX_ packWARN(WARN_MISC),
936 "Odd number of elements in hash assignment");
939 tmpstr = NEWSV(29,0);
940 didstore = hv_store_ent(hash,*relem,tmpstr,0);
941 if (SvMAGICAL(hash)) {
942 if (SvSMAGICAL(tmpstr))
954 SV **lastlelem = PL_stack_sp;
955 SV **lastrelem = PL_stack_base + POPMARK;
956 SV **firstrelem = PL_stack_base + POPMARK + 1;
957 SV **firstlelem = lastrelem + 1;
970 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
972 /* If there's a common identifier on both sides we have to take
973 * special care that assigning the identifier on the left doesn't
974 * clobber a value on the right that's used later in the list.
976 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
977 EXTEND_MORTAL(lastrelem - firstrelem + 1);
978 for (relem = firstrelem; relem <= lastrelem; relem++) {
981 TAINT_NOT; /* Each item is independent */
982 *relem = sv_mortalcopy(sv);
992 while (lelem <= lastlelem) {
993 TAINT_NOT; /* Each item stands on its own, taintwise. */
995 switch (SvTYPE(sv)) {
998 magic = SvMAGICAL(ary) != 0;
1000 av_extend(ary, lastrelem - relem);
1002 while (relem <= lastrelem) { /* gobble up all the rest */
1006 sv_setsv(sv,*relem);
1008 didstore = av_store(ary,i++,sv);
1018 case SVt_PVHV: { /* normal hash */
1022 magic = SvMAGICAL(hash) != 0;
1025 while (relem < lastrelem) { /* gobble up all the rest */
1030 sv = &PL_sv_no, relem++;
1031 tmpstr = NEWSV(29,0);
1033 sv_setsv(tmpstr,*relem); /* value */
1034 *(relem++) = tmpstr;
1035 didstore = hv_store_ent(hash,sv,tmpstr,0);
1037 if (SvSMAGICAL(tmpstr))
1044 if (relem == lastrelem) {
1045 do_oddball(hash, relem, firstrelem);
1051 if (SvIMMORTAL(sv)) {
1052 if (relem <= lastrelem)
1056 if (relem <= lastrelem) {
1057 sv_setsv(sv, *relem);
1061 sv_setsv(sv, &PL_sv_undef);
1066 if (PL_delaymagic & ~DM_DELAY) {
1067 if (PL_delaymagic & DM_UID) {
1068 #ifdef HAS_SETRESUID
1069 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1070 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1073 # ifdef HAS_SETREUID
1074 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1075 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1078 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1079 (void)setruid(PL_uid);
1080 PL_delaymagic &= ~DM_RUID;
1082 # endif /* HAS_SETRUID */
1084 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1085 (void)seteuid(PL_euid);
1086 PL_delaymagic &= ~DM_EUID;
1088 # endif /* HAS_SETEUID */
1089 if (PL_delaymagic & DM_UID) {
1090 if (PL_uid != PL_euid)
1091 DIE(aTHX_ "No setreuid available");
1092 (void)PerlProc_setuid(PL_uid);
1094 # endif /* HAS_SETREUID */
1095 #endif /* HAS_SETRESUID */
1096 PL_uid = PerlProc_getuid();
1097 PL_euid = PerlProc_geteuid();
1099 if (PL_delaymagic & DM_GID) {
1100 #ifdef HAS_SETRESGID
1101 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1102 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1105 # ifdef HAS_SETREGID
1106 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1107 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1110 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1111 (void)setrgid(PL_gid);
1112 PL_delaymagic &= ~DM_RGID;
1114 # endif /* HAS_SETRGID */
1116 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1117 (void)setegid(PL_egid);
1118 PL_delaymagic &= ~DM_EGID;
1120 # endif /* HAS_SETEGID */
1121 if (PL_delaymagic & DM_GID) {
1122 if (PL_gid != PL_egid)
1123 DIE(aTHX_ "No setregid available");
1124 (void)PerlProc_setgid(PL_gid);
1126 # endif /* HAS_SETREGID */
1127 #endif /* HAS_SETRESGID */
1128 PL_gid = PerlProc_getgid();
1129 PL_egid = PerlProc_getegid();
1131 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1136 if (gimme == G_VOID)
1137 SP = firstrelem - 1;
1138 else if (gimme == G_SCALAR) {
1141 SETi(lastrelem - firstrelem + 1);
1147 SP = firstrelem + (lastlelem - firstlelem);
1148 lelem = firstlelem + (relem - firstrelem);
1150 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1158 register PMOP *pm = cPMOP;
1159 SV *rv = sv_newmortal();
1160 SV *sv = newSVrv(rv, "Regexp");
1161 if (pm->op_pmdynflags & PMdf_TAINTED)
1163 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1170 register PMOP *pm = cPMOP;
1176 I32 r_flags = REXEC_CHECKED;
1177 char *truebase; /* Start of string */
1178 register REGEXP *rx = PM_GETRE(pm);
1183 I32 oldsave = PL_savestack_ix;
1184 I32 update_minmatch = 1;
1185 I32 had_zerolen = 0;
1187 if (PL_op->op_flags & OPf_STACKED)
1194 PUTBACK; /* EVAL blocks need stack_sp. */
1195 s = SvPV(TARG, len);
1198 DIE(aTHX_ "panic: pp_match");
1199 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1200 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1203 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1205 /* PMdf_USED is set after a ?? matches once */
1206 if (pm->op_pmdynflags & PMdf_USED) {
1208 if (gimme == G_ARRAY)
1213 /* empty pattern special-cased to use last successful pattern if possible */
1214 if (!rx->prelen && PL_curpm) {
1219 if (rx->minlen > (I32)len)
1224 /* XXXX What part of this is needed with true \G-support? */
1225 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1227 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1228 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1229 if (mg && mg->mg_len >= 0) {
1230 if (!(rx->reganch & ROPT_GPOS_SEEN))
1231 rx->endp[0] = rx->startp[0] = mg->mg_len;
1232 else if (rx->reganch & ROPT_ANCH_GPOS) {
1233 r_flags |= REXEC_IGNOREPOS;
1234 rx->endp[0] = rx->startp[0] = mg->mg_len;
1236 minmatch = (mg->mg_flags & MGf_MINMATCH);
1237 update_minmatch = 0;
1241 if ((!global && rx->nparens)
1242 || SvTEMP(TARG) || PL_sawampersand)
1243 r_flags |= REXEC_COPY_STR;
1245 r_flags |= REXEC_SCREAM;
1247 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1248 SAVEINT(PL_multiline);
1249 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1253 if (global && rx->startp[0] != -1) {
1254 t = s = rx->endp[0] + truebase;
1255 if ((s + rx->minlen) > strend)
1257 if (update_minmatch++)
1258 minmatch = had_zerolen;
1260 if (rx->reganch & RE_USE_INTUIT &&
1261 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1262 PL_bostr = truebase;
1263 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1267 if ( (rx->reganch & ROPT_CHECK_ALL)
1269 && ((rx->reganch & ROPT_NOSCAN)
1270 || !((rx->reganch & RE_INTUIT_TAIL)
1271 && (r_flags & REXEC_SCREAM)))
1272 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1275 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1278 if (dynpm->op_pmflags & PMf_ONCE)
1279 dynpm->op_pmdynflags |= PMdf_USED;
1288 RX_MATCH_TAINTED_on(rx);
1289 TAINT_IF(RX_MATCH_TAINTED(rx));
1290 if (gimme == G_ARRAY) {
1291 I32 nparens, i, len;
1293 nparens = rx->nparens;
1294 if (global && !nparens)
1298 SPAGAIN; /* EVAL blocks could move the stack. */
1299 EXTEND(SP, nparens + i);
1300 EXTEND_MORTAL(nparens + i);
1301 for (i = !i; i <= nparens; i++) {
1302 PUSHs(sv_newmortal());
1304 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1305 len = rx->endp[i] - rx->startp[i];
1306 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1307 len < 0 || len > strend - s)
1308 DIE(aTHX_ "panic: pp_match start/end pointers");
1309 s = rx->startp[i] + truebase;
1310 sv_setpvn(*SP, s, len);
1311 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1316 if (dynpm->op_pmflags & PMf_CONTINUE) {
1318 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1319 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1321 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1322 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1324 if (rx->startp[0] != -1) {
1325 mg->mg_len = rx->endp[0];
1326 if (rx->startp[0] == rx->endp[0])
1327 mg->mg_flags |= MGf_MINMATCH;
1329 mg->mg_flags &= ~MGf_MINMATCH;
1332 had_zerolen = (rx->startp[0] != -1
1333 && rx->startp[0] == rx->endp[0]);
1334 PUTBACK; /* EVAL blocks may use stack */
1335 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1340 LEAVE_SCOPE(oldsave);
1346 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1347 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1349 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1350 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1352 if (rx->startp[0] != -1) {
1353 mg->mg_len = rx->endp[0];
1354 if (rx->startp[0] == rx->endp[0])
1355 mg->mg_flags |= MGf_MINMATCH;
1357 mg->mg_flags &= ~MGf_MINMATCH;
1360 LEAVE_SCOPE(oldsave);
1364 yup: /* Confirmed by INTUIT */
1366 RX_MATCH_TAINTED_on(rx);
1367 TAINT_IF(RX_MATCH_TAINTED(rx));
1369 if (dynpm->op_pmflags & PMf_ONCE)
1370 dynpm->op_pmdynflags |= PMdf_USED;
1371 if (RX_MATCH_COPIED(rx))
1372 Safefree(rx->subbeg);
1373 RX_MATCH_COPIED_off(rx);
1374 rx->subbeg = Nullch;
1376 rx->subbeg = truebase;
1377 rx->startp[0] = s - truebase;
1378 if (RX_MATCH_UTF8(rx)) {
1379 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1380 rx->endp[0] = t - truebase;
1383 rx->endp[0] = s - truebase + rx->minlen;
1385 rx->sublen = strend - truebase;
1388 if (PL_sawampersand) {
1390 #ifdef PERL_COPY_ON_WRITE
1391 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1393 PerlIO_printf(Perl_debug_log,
1394 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1395 (int) SvTYPE(TARG), truebase, t,
1398 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1399 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1400 assert (SvPOKp(rx->saved_copy));
1405 rx->subbeg = savepvn(t, strend - t);
1406 #ifdef PERL_COPY_ON_WRITE
1407 rx->saved_copy = Nullsv;
1410 rx->sublen = strend - t;
1411 RX_MATCH_COPIED_on(rx);
1412 off = rx->startp[0] = s - t;
1413 rx->endp[0] = off + rx->minlen;
1415 else { /* startp/endp are used by @- @+. */
1416 rx->startp[0] = s - truebase;
1417 rx->endp[0] = s - truebase + rx->minlen;
1419 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1420 LEAVE_SCOPE(oldsave);
1425 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1426 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1427 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1432 LEAVE_SCOPE(oldsave);
1433 if (gimme == G_ARRAY)
1439 Perl_do_readline(pTHX)
1441 dSP; dTARGETSTACKED;
1446 register IO *io = GvIO(PL_last_in_gv);
1447 register I32 type = PL_op->op_type;
1448 I32 gimme = GIMME_V;
1451 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1453 XPUSHs(SvTIED_obj((SV*)io, mg));
1456 call_method("READLINE", gimme);
1459 if (gimme == G_SCALAR) {
1461 SvSetSV_nosteal(TARG, result);
1470 if (IoFLAGS(io) & IOf_ARGV) {
1471 if (IoFLAGS(io) & IOf_START) {
1473 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1474 IoFLAGS(io) &= ~IOf_START;
1475 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1476 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1477 SvSETMAGIC(GvSV(PL_last_in_gv));
1482 fp = nextargv(PL_last_in_gv);
1483 if (!fp) { /* Note: fp != IoIFP(io) */
1484 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1487 else if (type == OP_GLOB)
1488 fp = Perl_start_glob(aTHX_ POPs, io);
1490 else if (type == OP_GLOB)
1492 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1493 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1497 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1498 && (!io || !(IoFLAGS(io) & IOf_START))) {
1499 if (type == OP_GLOB)
1500 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1501 "glob failed (can't start child: %s)",
1504 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1506 if (gimme == G_SCALAR) {
1507 /* undef TARG, and push that undefined value */
1508 if (type != OP_RCATLINE) {
1509 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1510 (void)SvOK_off(TARG);
1517 if (gimme == G_SCALAR) {
1521 (void)SvUPGRADE(sv, SVt_PV);
1522 tmplen = SvLEN(sv); /* remember if already alloced */
1523 if (!tmplen && !SvREADONLY(sv))
1524 Sv_Grow(sv, 80); /* try short-buffering it */
1526 if (type == OP_RCATLINE && SvOK(sv)) {
1529 (void)SvPV_force(sv, n_a);
1535 sv = sv_2mortal(NEWSV(57, 80));
1539 /* This should not be marked tainted if the fp is marked clean */
1540 #define MAYBE_TAINT_LINE(io, sv) \
1541 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1546 /* delay EOF state for a snarfed empty file */
1547 #define SNARF_EOF(gimme,rs,io,sv) \
1548 (gimme != G_SCALAR || SvCUR(sv) \
1549 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1553 if (!sv_gets(sv, fp, offset)
1554 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1556 PerlIO_clearerr(fp);
1557 if (IoFLAGS(io) & IOf_ARGV) {
1558 fp = nextargv(PL_last_in_gv);
1561 (void)do_close(PL_last_in_gv, FALSE);
1563 else if (type == OP_GLOB) {
1564 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1565 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1566 "glob failed (child exited with status %d%s)",
1567 (int)(STATUS_CURRENT >> 8),
1568 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1571 if (gimme == G_SCALAR) {
1572 if (type != OP_RCATLINE) {
1573 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1574 (void)SvOK_off(TARG);
1579 MAYBE_TAINT_LINE(io, sv);
1582 MAYBE_TAINT_LINE(io, sv);
1584 IoFLAGS(io) |= IOf_NOLINE;
1588 if (type == OP_GLOB) {
1591 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1592 tmps = SvEND(sv) - 1;
1593 if (*tmps == *SvPVX(PL_rs)) {
1598 for (tmps = SvPVX(sv); *tmps; tmps++)
1599 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1600 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1602 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1603 (void)POPs; /* Unmatched wildcard? Chuck it... */
1606 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1607 U8 *s = (U8*)SvPVX(sv) + offset;
1608 STRLEN len = SvCUR(sv) - offset;
1611 if (ckWARN(WARN_UTF8) &&
1612 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1613 /* Emulate :encoding(utf8) warning in the same case. */
1614 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1615 "utf8 \"\\x%02X\" does not map to Unicode",
1616 f < (U8*)SvEND(sv) ? *f : 0);
1618 if (gimme == G_ARRAY) {
1619 if (SvLEN(sv) - SvCUR(sv) > 20) {
1620 SvLEN_set(sv, SvCUR(sv)+1);
1621 Renew(SvPVX(sv), SvLEN(sv), char);
1623 sv = sv_2mortal(NEWSV(58, 80));
1626 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1627 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1631 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1632 Renew(SvPVX(sv), SvLEN(sv), char);
1641 register PERL_CONTEXT *cx;
1642 I32 gimme = OP_GIMME(PL_op, -1);
1645 if (cxstack_ix >= 0)
1646 gimme = cxstack[cxstack_ix].blk_gimme;
1654 PUSHBLOCK(cx, CXt_BLOCK, SP);
1666 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1667 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1669 #ifdef PERL_COPY_ON_WRITE
1670 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1672 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1676 if (SvTYPE(hv) == SVt_PVHV) {
1677 if (PL_op->op_private & OPpLVAL_INTRO) {
1680 /* does the element we're localizing already exist? */
1682 /* can we determine whether it exists? */
1684 || mg_find((SV*)hv, PERL_MAGIC_env)
1685 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1686 /* Try to preserve the existenceness of a tied hash
1687 * element by using EXISTS and DELETE if possible.
1688 * Fallback to FETCH and STORE otherwise */
1689 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1690 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1691 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1693 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1696 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1697 svp = he ? &HeVAL(he) : 0;
1703 if (!svp || *svp == &PL_sv_undef) {
1708 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1710 lv = sv_newmortal();
1711 sv_upgrade(lv, SVt_PVLV);
1713 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1714 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1715 LvTARG(lv) = SvREFCNT_inc(hv);
1720 if (PL_op->op_private & OPpLVAL_INTRO) {
1721 if (HvNAME(hv) && isGV(*svp))
1722 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1726 char *key = SvPV(keysv, keylen);
1727 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1729 save_helem(hv, keysv, svp);
1732 else if (PL_op->op_private & OPpDEREF)
1733 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1735 sv = (svp ? *svp : &PL_sv_undef);
1736 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1737 * Pushing the magical RHS on to the stack is useless, since
1738 * that magic is soon destined to be misled by the local(),
1739 * and thus the later pp_sassign() will fail to mg_get() the
1740 * old value. This should also cure problems with delayed
1741 * mg_get()s. GSAR 98-07-03 */
1742 if (!lval && SvGMAGICAL(sv))
1743 sv = sv_mortalcopy(sv);
1751 register PERL_CONTEXT *cx;
1757 if (PL_op->op_flags & OPf_SPECIAL) {
1758 cx = &cxstack[cxstack_ix];
1759 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1764 gimme = OP_GIMME(PL_op, -1);
1766 if (cxstack_ix >= 0)
1767 gimme = cxstack[cxstack_ix].blk_gimme;
1773 if (gimme == G_VOID)
1775 else if (gimme == G_SCALAR) {
1778 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1781 *MARK = sv_mortalcopy(TOPs);
1784 *MARK = &PL_sv_undef;
1788 else if (gimme == G_ARRAY) {
1789 /* in case LEAVE wipes old return values */
1790 for (mark = newsp + 1; mark <= SP; mark++) {
1791 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1792 *mark = sv_mortalcopy(*mark);
1793 TAINT_NOT; /* Each item is independent */
1797 PL_curpm = newpm; /* Don't pop $1 et al till now */
1807 register PERL_CONTEXT *cx;
1813 cx = &cxstack[cxstack_ix];
1814 if (CxTYPE(cx) != CXt_LOOP)
1815 DIE(aTHX_ "panic: pp_iter");
1817 itersvp = CxITERVAR(cx);
1818 av = cx->blk_loop.iterary;
1819 if (SvTYPE(av) != SVt_PVAV) {
1820 /* iterate ($min .. $max) */
1821 if (cx->blk_loop.iterlval) {
1822 /* string increment */
1823 register SV* cur = cx->blk_loop.iterlval;
1825 char *max = SvPV((SV*)av, maxlen);
1826 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1827 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1828 /* safe to reuse old SV */
1829 sv_setsv(*itersvp, cur);
1833 /* we need a fresh SV every time so that loop body sees a
1834 * completely new SV for closures/references to work as
1836 SvREFCNT_dec(*itersvp);
1837 *itersvp = newSVsv(cur);
1839 if (strEQ(SvPVX(cur), max))
1840 sv_setiv(cur, 0); /* terminate next time */
1847 /* integer increment */
1848 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1851 /* don't risk potential race */
1852 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1853 /* safe to reuse old SV */
1854 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1858 /* we need a fresh SV every time so that loop body sees a
1859 * completely new SV for closures/references to work as they
1861 SvREFCNT_dec(*itersvp);
1862 *itersvp = newSViv(cx->blk_loop.iterix++);
1868 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1871 SvREFCNT_dec(*itersvp);
1873 if (SvMAGICAL(av) || AvREIFY(av)) {
1874 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1881 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1883 if (sv && SvREFCNT(sv) == 0) {
1885 Perl_croak(aTHX_ "Use of freed value in iteration");
1892 if (av != PL_curstack && sv == &PL_sv_undef) {
1893 SV *lv = cx->blk_loop.iterlval;
1894 if (lv && SvREFCNT(lv) > 1) {
1899 SvREFCNT_dec(LvTARG(lv));
1901 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1902 sv_upgrade(lv, SVt_PVLV);
1904 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1906 LvTARG(lv) = SvREFCNT_inc(av);
1907 LvTARGOFF(lv) = cx->blk_loop.iterix;
1908 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1912 *itersvp = SvREFCNT_inc(sv);
1919 register PMOP *pm = cPMOP;
1935 register REGEXP *rx = PM_GETRE(pm);
1937 int force_on_match = 0;
1938 I32 oldsave = PL_savestack_ix;
1940 bool doutf8 = FALSE;
1941 #ifdef PERL_COPY_ON_WRITE
1946 /* known replacement string? */
1947 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1948 if (PL_op->op_flags & OPf_STACKED)
1955 #ifdef PERL_COPY_ON_WRITE
1956 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1957 because they make integers such as 256 "false". */
1958 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1961 sv_force_normal_flags(TARG,0);
1964 #ifdef PERL_COPY_ON_WRITE
1968 || (SvTYPE(TARG) > SVt_PVLV
1969 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1970 DIE(aTHX_ PL_no_modify);
1973 s = SvPV(TARG, len);
1974 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1976 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1977 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1982 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1986 DIE(aTHX_ "panic: pp_subst");
1989 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
1990 maxiters = 2 * slen + 10; /* We can match twice at each
1991 position, once with zero-length,
1992 second time with non-zero. */
1994 if (!rx->prelen && PL_curpm) {
1998 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1999 ? REXEC_COPY_STR : 0;
2001 r_flags |= REXEC_SCREAM;
2002 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
2003 SAVEINT(PL_multiline);
2004 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2007 if (rx->reganch & RE_USE_INTUIT) {
2009 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2013 /* How to do it in subst? */
2014 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2016 && ((rx->reganch & ROPT_NOSCAN)
2017 || !((rx->reganch & RE_INTUIT_TAIL)
2018 && (r_flags & REXEC_SCREAM))))
2023 /* only replace once? */
2024 once = !(rpm->op_pmflags & PMf_GLOBAL);
2026 /* known replacement string? */
2028 /* replacement needing upgrading? */
2029 if (DO_UTF8(TARG) && !doutf8) {
2030 nsv = sv_newmortal();
2033 sv_recode_to_utf8(nsv, PL_encoding);
2035 sv_utf8_upgrade(nsv);
2036 c = SvPV(nsv, clen);
2040 c = SvPV(dstr, clen);
2041 doutf8 = DO_UTF8(dstr);
2049 /* can do inplace substitution? */
2051 #ifdef PERL_COPY_ON_WRITE
2054 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2055 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2056 && (!doutf8 || SvUTF8(TARG))) {
2057 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2058 r_flags | REXEC_CHECKED))
2062 LEAVE_SCOPE(oldsave);
2065 #ifdef PERL_COPY_ON_WRITE
2066 if (SvIsCOW(TARG)) {
2067 assert (!force_on_match);
2071 if (force_on_match) {
2073 s = SvPV_force(TARG, len);
2078 SvSCREAM_off(TARG); /* disable possible screamer */
2080 rxtainted |= RX_MATCH_TAINTED(rx);
2081 m = orig + rx->startp[0];
2082 d = orig + rx->endp[0];
2084 if (m - s > strend - d) { /* faster to shorten from end */
2086 Copy(c, m, clen, char);
2091 Move(d, m, i, char);
2095 SvCUR_set(TARG, m - s);
2098 else if ((i = m - s)) { /* faster from front */
2106 Copy(c, m, clen, char);
2111 Copy(c, d, clen, char);
2116 TAINT_IF(rxtainted & 1);
2122 if (iters++ > maxiters)
2123 DIE(aTHX_ "Substitution loop");
2124 rxtainted |= RX_MATCH_TAINTED(rx);
2125 m = rx->startp[0] + orig;
2129 Move(s, d, i, char);
2133 Copy(c, d, clen, char);
2136 s = rx->endp[0] + orig;
2137 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2139 /* don't match same null twice */
2140 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2143 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2144 Move(s, d, i+1, char); /* include the NUL */
2146 TAINT_IF(rxtainted & 1);
2148 PUSHs(sv_2mortal(newSViv((I32)iters)));
2150 (void)SvPOK_only_UTF8(TARG);
2151 TAINT_IF(rxtainted);
2152 if (SvSMAGICAL(TARG)) {
2160 LEAVE_SCOPE(oldsave);
2164 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2165 r_flags | REXEC_CHECKED))
2167 if (force_on_match) {
2169 s = SvPV_force(TARG, len);
2172 #ifdef PERL_COPY_ON_WRITE
2175 rxtainted |= RX_MATCH_TAINTED(rx);
2176 dstr = NEWSV(25, len);
2177 sv_setpvn(dstr, m, s-m);
2182 register PERL_CONTEXT *cx;
2186 RETURNOP(cPMOP->op_pmreplroot);
2188 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2190 if (iters++ > maxiters)
2191 DIE(aTHX_ "Substitution loop");
2192 rxtainted |= RX_MATCH_TAINTED(rx);
2193 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2198 strend = s + (strend - m);
2200 m = rx->startp[0] + orig;
2201 if (doutf8 && !SvUTF8(dstr))
2202 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2204 sv_catpvn(dstr, s, m-s);
2205 s = rx->endp[0] + orig;
2207 sv_catpvn(dstr, c, clen);
2210 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2211 TARG, NULL, r_flags));
2212 if (doutf8 && !DO_UTF8(TARG))
2213 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2215 sv_catpvn(dstr, s, strend - s);
2217 #ifdef PERL_COPY_ON_WRITE
2218 /* The match may make the string COW. If so, brilliant, because that's
2219 just saved us one malloc, copy and free - the regexp has donated
2220 the old buffer, and we malloc an entirely new one, rather than the
2221 regexp malloc()ing a buffer and copying our original, only for
2222 us to throw it away here during the substitution. */
2223 if (SvIsCOW(TARG)) {
2224 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2228 (void)SvOOK_off(TARG);
2230 Safefree(SvPVX(TARG));
2232 SvPVX(TARG) = SvPVX(dstr);
2233 SvCUR_set(TARG, SvCUR(dstr));
2234 SvLEN_set(TARG, SvLEN(dstr));
2235 doutf8 |= DO_UTF8(dstr);
2239 TAINT_IF(rxtainted & 1);
2241 PUSHs(sv_2mortal(newSViv((I32)iters)));
2243 (void)SvPOK_only(TARG);
2246 TAINT_IF(rxtainted);
2249 LEAVE_SCOPE(oldsave);
2258 LEAVE_SCOPE(oldsave);
2267 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2268 ++*PL_markstack_ptr;
2269 LEAVE; /* exit inner scope */
2272 if (PL_stack_base + *PL_markstack_ptr > SP) {
2274 I32 gimme = GIMME_V;
2276 LEAVE; /* exit outer scope */
2277 (void)POPMARK; /* pop src */
2278 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2279 (void)POPMARK; /* pop dst */
2280 SP = PL_stack_base + POPMARK; /* pop original mark */
2281 if (gimme == G_SCALAR) {
2285 else if (gimme == G_ARRAY)
2292 ENTER; /* enter inner scope */
2295 src = PL_stack_base[*PL_markstack_ptr];
2299 RETURNOP(cLOGOP->op_other);
2310 register PERL_CONTEXT *cx;
2314 cxstack_ix++; /* temporarily protect top context */
2317 if (gimme == G_SCALAR) {
2320 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2322 *MARK = SvREFCNT_inc(TOPs);
2327 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2329 *MARK = sv_mortalcopy(sv);
2334 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2338 *MARK = &PL_sv_undef;
2342 else if (gimme == G_ARRAY) {
2343 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2344 if (!SvTEMP(*MARK)) {
2345 *MARK = sv_mortalcopy(*MARK);
2346 TAINT_NOT; /* Each item is independent */
2354 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2355 PL_curpm = newpm; /* ... and pop $1 et al */
2358 return pop_return();
2361 /* This duplicates the above code because the above code must not
2362 * get any slower by more conditions */
2370 register PERL_CONTEXT *cx;
2374 cxstack_ix++; /* temporarily protect top context */
2378 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2379 /* We are an argument to a function or grep().
2380 * This kind of lvalueness was legal before lvalue
2381 * subroutines too, so be backward compatible:
2382 * cannot report errors. */
2384 /* Scalar context *is* possible, on the LHS of -> only,
2385 * as in f()->meth(). But this is not an lvalue. */
2386 if (gimme == G_SCALAR)
2388 if (gimme == G_ARRAY) {
2389 if (!CvLVALUE(cx->blk_sub.cv))
2390 goto temporise_array;
2391 EXTEND_MORTAL(SP - newsp);
2392 for (mark = newsp + 1; mark <= SP; mark++) {
2395 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2396 *mark = sv_mortalcopy(*mark);
2398 /* Can be a localized value subject to deletion. */
2399 PL_tmps_stack[++PL_tmps_ix] = *mark;
2400 (void)SvREFCNT_inc(*mark);
2405 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2406 /* Here we go for robustness, not for speed, so we change all
2407 * the refcounts so the caller gets a live guy. Cannot set
2408 * TEMP, so sv_2mortal is out of question. */
2409 if (!CvLVALUE(cx->blk_sub.cv)) {
2415 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2417 if (gimme == G_SCALAR) {
2421 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2427 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2428 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2429 : "a readonly value" : "a temporary");
2431 else { /* Can be a localized value
2432 * subject to deletion. */
2433 PL_tmps_stack[++PL_tmps_ix] = *mark;
2434 (void)SvREFCNT_inc(*mark);
2437 else { /* Should not happen? */
2443 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2444 (MARK > SP ? "Empty array" : "Array"));
2448 else if (gimme == G_ARRAY) {
2449 EXTEND_MORTAL(SP - newsp);
2450 for (mark = newsp + 1; mark <= SP; mark++) {
2451 if (*mark != &PL_sv_undef
2452 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2453 /* Might be flattened array after $#array = */
2460 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2461 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2464 /* Can be a localized value subject to deletion. */
2465 PL_tmps_stack[++PL_tmps_ix] = *mark;
2466 (void)SvREFCNT_inc(*mark);
2472 if (gimme == G_SCALAR) {
2476 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2478 *MARK = SvREFCNT_inc(TOPs);
2483 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2485 *MARK = sv_mortalcopy(sv);
2490 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2494 *MARK = &PL_sv_undef;
2498 else if (gimme == G_ARRAY) {
2500 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2501 if (!SvTEMP(*MARK)) {
2502 *MARK = sv_mortalcopy(*MARK);
2503 TAINT_NOT; /* Each item is independent */
2512 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2513 PL_curpm = newpm; /* ... and pop $1 et al */
2516 return pop_return();
2521 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2523 SV *dbsv = GvSV(PL_DBsub);
2525 if (!PERLDB_SUB_NN) {
2529 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2530 || strEQ(GvNAME(gv), "END")
2531 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2532 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2533 && (gv = (GV*)*svp) ))) {
2534 /* Use GV from the stack as a fallback. */
2535 /* GV is potentially non-unique, or contain different CV. */
2536 SV *tmp = newRV((SV*)cv);
2537 sv_setsv(dbsv, tmp);
2541 gv_efullname3(dbsv, gv, Nullch);
2545 (void)SvUPGRADE(dbsv, SVt_PVIV);
2546 (void)SvIOK_on(dbsv);
2547 SAVEIV(SvIVX(dbsv));
2548 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2552 PL_curcopdb = PL_curcop;
2553 cv = GvCV(PL_DBsub);
2563 register PERL_CONTEXT *cx;
2565 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2568 DIE(aTHX_ "Not a CODE reference");
2569 switch (SvTYPE(sv)) {
2570 /* This is overwhelming the most common case: */
2572 if (!(cv = GvCVu((GV*)sv)))
2573 cv = sv_2cv(sv, &stash, &gv, FALSE);
2585 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2587 SP = PL_stack_base + POPMARK;
2590 if (SvGMAGICAL(sv)) {
2594 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2597 sym = SvPV(sv, n_a);
2599 DIE(aTHX_ PL_no_usym, "a subroutine");
2600 if (PL_op->op_private & HINT_STRICT_REFS)
2601 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2602 cv = get_cv(sym, TRUE);
2607 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2608 tryAMAGICunDEREF(to_cv);
2611 if (SvTYPE(cv) == SVt_PVCV)
2616 DIE(aTHX_ "Not a CODE reference");
2617 /* This is the second most common case: */
2627 if (!CvROOT(cv) && !CvXSUB(cv)) {
2632 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2633 if (CvASSERTION(cv) && PL_DBassertion)
2634 sv_setiv(PL_DBassertion, 1);
2636 cv = get_db_sub(&sv, cv);
2638 DIE(aTHX_ "No DBsub routine");
2641 if (!(CvXSUB(cv))) {
2642 /* This path taken at least 75% of the time */
2644 register I32 items = SP - MARK;
2645 AV* padlist = CvPADLIST(cv);
2646 push_return(PL_op->op_next);
2647 PUSHBLOCK(cx, CXt_SUB, MARK);
2650 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2651 * that eval'' ops within this sub know the correct lexical space.
2652 * Owing the speed considerations, we choose instead to search for
2653 * the cv using find_runcv() when calling doeval().
2655 if (CvDEPTH(cv) < 2)
2656 (void)SvREFCNT_inc(cv);
2658 PERL_STACK_OVERFLOW_CHECK();
2659 pad_push(padlist, CvDEPTH(cv), 1);
2661 PAD_SET_CUR(padlist, CvDEPTH(cv));
2668 DEBUG_S(PerlIO_printf(Perl_debug_log,
2669 "%p entersub preparing @_\n", thr));
2671 av = (AV*)PAD_SVl(0);
2673 /* @_ is normally not REAL--this should only ever
2674 * happen when DB::sub() calls things that modify @_ */
2679 cx->blk_sub.savearray = GvAV(PL_defgv);
2680 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2681 CX_CURPAD_SAVE(cx->blk_sub);
2682 cx->blk_sub.argarray = av;
2685 if (items > AvMAX(av) + 1) {
2687 if (AvARRAY(av) != ary) {
2688 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2689 SvPVX(av) = (char*)ary;
2691 if (items > AvMAX(av) + 1) {
2692 AvMAX(av) = items - 1;
2693 Renew(ary,items,SV*);
2695 SvPVX(av) = (char*)ary;
2698 Copy(MARK,AvARRAY(av),items,SV*);
2699 AvFILLp(av) = items - 1;
2707 /* warning must come *after* we fully set up the context
2708 * stuff so that __WARN__ handlers can safely dounwind()
2711 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2712 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2713 sub_crush_depth(cv);
2715 DEBUG_S(PerlIO_printf(Perl_debug_log,
2716 "%p entersub returning %p\n", thr, CvSTART(cv)));
2718 RETURNOP(CvSTART(cv));
2721 #ifdef PERL_XSUB_OLDSTYLE
2722 if (CvOLDSTYLE(cv)) {
2723 I32 (*fp3)(int,int,int);
2725 register I32 items = SP - MARK;
2726 /* We dont worry to copy from @_. */
2731 PL_stack_sp = mark + 1;
2732 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2733 items = (*fp3)(CvXSUBANY(cv).any_i32,
2734 MARK - PL_stack_base + 1,
2736 PL_stack_sp = PL_stack_base + items;
2739 #endif /* PERL_XSUB_OLDSTYLE */
2741 I32 markix = TOPMARK;
2746 /* Need to copy @_ to stack. Alternative may be to
2747 * switch stack to @_, and copy return values
2748 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2751 av = GvAV(PL_defgv);
2752 items = AvFILLp(av) + 1; /* @_ is not tieable */
2755 /* Mark is at the end of the stack. */
2757 Copy(AvARRAY(av), SP + 1, items, SV*);
2762 /* We assume first XSUB in &DB::sub is the called one. */
2764 SAVEVPTR(PL_curcop);
2765 PL_curcop = PL_curcopdb;
2768 /* Do we need to open block here? XXXX */
2769 (void)(*CvXSUB(cv))(aTHX_ cv);
2771 /* Enforce some sanity in scalar context. */
2772 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2773 if (markix > PL_stack_sp - PL_stack_base)
2774 *(PL_stack_base + markix) = &PL_sv_undef;
2776 *(PL_stack_base + markix) = *PL_stack_sp;
2777 PL_stack_sp = PL_stack_base + markix;
2784 assert (0); /* Cannot get here. */
2785 /* This is deliberately moved here as spaghetti code to keep it out of the
2792 /* anonymous or undef'd function leaves us no recourse */
2793 if (CvANON(cv) || !(gv = CvGV(cv)))
2794 DIE(aTHX_ "Undefined subroutine called");
2796 /* autoloaded stub? */
2797 if (cv != GvCV(gv)) {
2800 /* should call AUTOLOAD now? */
2803 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2810 sub_name = sv_newmortal();
2811 gv_efullname3(sub_name, gv, Nullch);
2812 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2816 DIE(aTHX_ "Not a CODE reference");
2822 Perl_sub_crush_depth(pTHX_ CV *cv)
2825 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2827 SV* tmpstr = sv_newmortal();
2828 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2829 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2839 IV elem = SvIV(elemsv);
2841 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2842 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2845 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2846 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2848 elem -= PL_curcop->cop_arybase;
2849 if (SvTYPE(av) != SVt_PVAV)
2851 svp = av_fetch(av, elem, lval && !defer);
2853 if (!svp || *svp == &PL_sv_undef) {
2856 DIE(aTHX_ PL_no_aelem, elem);
2857 lv = sv_newmortal();
2858 sv_upgrade(lv, SVt_PVLV);
2860 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2861 LvTARG(lv) = SvREFCNT_inc(av);
2862 LvTARGOFF(lv) = elem;
2867 if (PL_op->op_private & OPpLVAL_INTRO)
2868 save_aelem(av, elem, svp);
2869 else if (PL_op->op_private & OPpDEREF)
2870 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2872 sv = (svp ? *svp : &PL_sv_undef);
2873 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2874 sv = sv_mortalcopy(sv);
2880 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2886 Perl_croak(aTHX_ PL_no_modify);
2887 if (SvTYPE(sv) < SVt_RV)
2888 sv_upgrade(sv, SVt_RV);
2889 else if (SvTYPE(sv) >= SVt_PV) {
2890 (void)SvOOK_off(sv);
2891 Safefree(SvPVX(sv));
2892 SvLEN(sv) = SvCUR(sv) = 0;
2896 SvRV(sv) = NEWSV(355,0);
2899 SvRV(sv) = (SV*)newAV();
2902 SvRV(sv) = (SV*)newHV();
2917 if (SvTYPE(rsv) == SVt_PVCV) {
2923 SETs(method_common(sv, Null(U32*)));
2931 U32 hash = SvUVX(sv);
2933 XPUSHs(method_common(sv, &hash));
2938 S_method_common(pTHX_ SV* meth, U32* hashp)
2947 SV *packsv = Nullsv;
2950 name = SvPV(meth, namelen);
2951 sv = *(PL_stack_base + TOPMARK + 1);
2954 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2963 /* this isn't a reference */
2966 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2968 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2970 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2977 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2978 !(ob=(SV*)GvIO(iogv)))
2980 /* this isn't the name of a filehandle either */
2982 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2983 ? !isIDFIRST_utf8((U8*)packname)
2984 : !isIDFIRST(*packname)
2987 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2988 SvOK(sv) ? "without a package or object reference"
2989 : "on an undefined value");
2991 /* assume it's a package name */
2992 stash = gv_stashpvn(packname, packlen, FALSE);
2996 SV* ref = newSViv(PTR2IV(stash));
2997 hv_store(PL_stashcache, packname, packlen, ref, 0);
3001 /* it _is_ a filehandle name -- replace with a reference */
3002 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3005 /* if we got here, ob should be a reference or a glob */
3006 if (!ob || !(SvOBJECT(ob)
3007 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3010 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3014 stash = SvSTASH(ob);
3017 /* NOTE: stash may be null, hope hv_fetch_ent and
3018 gv_fetchmethod can cope (it seems they can) */
3020 /* shortcut for simple names */
3022 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3024 gv = (GV*)HeVAL(he);
3025 if (isGV(gv) && GvCV(gv) &&
3026 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3027 return (SV*)GvCV(gv);
3031 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3034 /* This code tries to figure out just what went wrong with
3035 gv_fetchmethod. It therefore needs to duplicate a lot of
3036 the internals of that function. We can't move it inside
3037 Perl_gv_fetchmethod_autoload(), however, since that would
3038 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3045 for (p = name; *p; p++) {
3047 sep = p, leaf = p + 1;
3048 else if (*p == ':' && *(p + 1) == ':')
3049 sep = p, leaf = p + 2;
3051 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3052 /* the method name is unqualified or starts with SUPER:: */
3053 packname = sep ? CopSTASHPV(PL_curcop) :
3054 stash ? HvNAME(stash) : packname;
3057 "Can't use anonymous symbol table for method lookup");
3059 packlen = strlen(packname);
3062 /* the method name is qualified */
3064 packlen = sep - name;
3067 /* we're relying on gv_fetchmethod not autovivifying the stash */
3068 if (gv_stashpvn(packname, packlen, FALSE)) {
3070 "Can't locate object method \"%s\" via package \"%.*s\"",
3071 leaf, (int)packlen, packname);
3075 "Can't locate object method \"%s\" via package \"%.*s\""
3076 " (perhaps you forgot to load \"%.*s\"?)",
3077 leaf, (int)packlen, packname, (int)packlen, packname);
3080 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;