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 TARG = Perl_hv_scalar(aTHX_ hv);
911 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
917 if (ckWARN(WARN_MISC)) {
918 if (relem == firstrelem &&
920 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
921 SvTYPE(SvRV(*relem)) == SVt_PVHV))
923 Perl_warner(aTHX_ packWARN(WARN_MISC),
924 "Reference found where even-sized list expected");
927 Perl_warner(aTHX_ packWARN(WARN_MISC),
928 "Odd number of elements in hash assignment");
931 tmpstr = NEWSV(29,0);
932 didstore = hv_store_ent(hash,*relem,tmpstr,0);
933 if (SvMAGICAL(hash)) {
934 if (SvSMAGICAL(tmpstr))
946 SV **lastlelem = PL_stack_sp;
947 SV **lastrelem = PL_stack_base + POPMARK;
948 SV **firstrelem = PL_stack_base + POPMARK + 1;
949 SV **firstlelem = lastrelem + 1;
962 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
965 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
968 /* If there's a common identifier on both sides we have to take
969 * special care that assigning the identifier on the left doesn't
970 * clobber a value on the right that's used later in the list.
972 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
973 EXTEND_MORTAL(lastrelem - firstrelem + 1);
974 for (relem = firstrelem; relem <= lastrelem; relem++) {
977 TAINT_NOT; /* Each item is independent */
978 *relem = sv_mortalcopy(sv);
988 while (lelem <= lastlelem) {
989 TAINT_NOT; /* Each item stands on its own, taintwise. */
991 switch (SvTYPE(sv)) {
994 magic = SvMAGICAL(ary) != 0;
996 av_extend(ary, lastrelem - relem);
998 while (relem <= lastrelem) { /* gobble up all the rest */
1002 sv_setsv(sv,*relem);
1004 didstore = av_store(ary,i++,sv);
1014 case SVt_PVHV: { /* normal hash */
1018 magic = SvMAGICAL(hash) != 0;
1020 firsthashrelem = relem;
1022 while (relem < lastrelem) { /* gobble up all the rest */
1027 sv = &PL_sv_no, relem++;
1028 tmpstr = NEWSV(29,0);
1030 sv_setsv(tmpstr,*relem); /* value */
1031 *(relem++) = tmpstr;
1032 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1033 /* key overwrites an existing entry */
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));
1135 if (gimme == G_VOID)
1136 SP = firstrelem - 1;
1137 else if (gimme == G_SCALAR) {
1140 SETi(lastrelem - firstrelem + 1 - duplicates);
1147 /* Removes from the stack the entries which ended up as
1148 * duplicated keys in the hash (fix for [perl #24380]) */
1149 Move(firsthashrelem + duplicates,
1150 firsthashrelem, duplicates, SV**);
1151 lastrelem -= duplicates;
1156 SP = firstrelem + (lastlelem - firstlelem);
1157 lelem = firstlelem + (relem - firstrelem);
1159 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1167 register PMOP *pm = cPMOP;
1168 SV *rv = sv_newmortal();
1169 SV *sv = newSVrv(rv, "Regexp");
1170 if (pm->op_pmdynflags & PMdf_TAINTED)
1172 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1179 register PMOP *pm = cPMOP;
1185 I32 r_flags = REXEC_CHECKED;
1186 char *truebase; /* Start of string */
1187 register REGEXP *rx = PM_GETRE(pm);
1192 I32 oldsave = PL_savestack_ix;
1193 I32 update_minmatch = 1;
1194 I32 had_zerolen = 0;
1196 if (PL_op->op_flags & OPf_STACKED)
1203 PUTBACK; /* EVAL blocks need stack_sp. */
1204 s = SvPV(TARG, len);
1207 DIE(aTHX_ "panic: pp_match");
1208 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1209 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1212 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1214 /* PMdf_USED is set after a ?? matches once */
1215 if (pm->op_pmdynflags & PMdf_USED) {
1217 if (gimme == G_ARRAY)
1222 /* empty pattern special-cased to use last successful pattern if possible */
1223 if (!rx->prelen && PL_curpm) {
1228 if (rx->minlen > (I32)len)
1233 /* XXXX What part of this is needed with true \G-support? */
1234 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1236 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1237 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1238 if (mg && mg->mg_len >= 0) {
1239 if (!(rx->reganch & ROPT_GPOS_SEEN))
1240 rx->endp[0] = rx->startp[0] = mg->mg_len;
1241 else if (rx->reganch & ROPT_ANCH_GPOS) {
1242 r_flags |= REXEC_IGNOREPOS;
1243 rx->endp[0] = rx->startp[0] = mg->mg_len;
1245 minmatch = (mg->mg_flags & MGf_MINMATCH);
1246 update_minmatch = 0;
1250 if ((!global && rx->nparens)
1251 || SvTEMP(TARG) || PL_sawampersand)
1252 r_flags |= REXEC_COPY_STR;
1254 r_flags |= REXEC_SCREAM;
1256 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1257 SAVEINT(PL_multiline);
1258 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1262 if (global && rx->startp[0] != -1) {
1263 t = s = rx->endp[0] + truebase;
1264 if ((s + rx->minlen) > strend)
1266 if (update_minmatch++)
1267 minmatch = had_zerolen;
1269 if (rx->reganch & RE_USE_INTUIT &&
1270 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1271 PL_bostr = truebase;
1272 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1276 if ( (rx->reganch & ROPT_CHECK_ALL)
1278 && ((rx->reganch & ROPT_NOSCAN)
1279 || !((rx->reganch & RE_INTUIT_TAIL)
1280 && (r_flags & REXEC_SCREAM)))
1281 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1284 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1287 if (dynpm->op_pmflags & PMf_ONCE)
1288 dynpm->op_pmdynflags |= PMdf_USED;
1297 RX_MATCH_TAINTED_on(rx);
1298 TAINT_IF(RX_MATCH_TAINTED(rx));
1299 if (gimme == G_ARRAY) {
1300 I32 nparens, i, len;
1302 nparens = rx->nparens;
1303 if (global && !nparens)
1307 SPAGAIN; /* EVAL blocks could move the stack. */
1308 EXTEND(SP, nparens + i);
1309 EXTEND_MORTAL(nparens + i);
1310 for (i = !i; i <= nparens; i++) {
1311 PUSHs(sv_newmortal());
1313 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1314 len = rx->endp[i] - rx->startp[i];
1315 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1316 len < 0 || len > strend - s)
1317 DIE(aTHX_ "panic: pp_match start/end pointers");
1318 s = rx->startp[i] + truebase;
1319 sv_setpvn(*SP, s, len);
1320 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1325 if (dynpm->op_pmflags & PMf_CONTINUE) {
1327 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1328 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1330 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1331 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1333 if (rx->startp[0] != -1) {
1334 mg->mg_len = rx->endp[0];
1335 if (rx->startp[0] == rx->endp[0])
1336 mg->mg_flags |= MGf_MINMATCH;
1338 mg->mg_flags &= ~MGf_MINMATCH;
1341 had_zerolen = (rx->startp[0] != -1
1342 && rx->startp[0] == rx->endp[0]);
1343 PUTBACK; /* EVAL blocks may use stack */
1344 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1349 LEAVE_SCOPE(oldsave);
1355 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1356 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1358 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1359 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1361 if (rx->startp[0] != -1) {
1362 mg->mg_len = rx->endp[0];
1363 if (rx->startp[0] == rx->endp[0])
1364 mg->mg_flags |= MGf_MINMATCH;
1366 mg->mg_flags &= ~MGf_MINMATCH;
1369 LEAVE_SCOPE(oldsave);
1373 yup: /* Confirmed by INTUIT */
1375 RX_MATCH_TAINTED_on(rx);
1376 TAINT_IF(RX_MATCH_TAINTED(rx));
1378 if (dynpm->op_pmflags & PMf_ONCE)
1379 dynpm->op_pmdynflags |= PMdf_USED;
1380 if (RX_MATCH_COPIED(rx))
1381 Safefree(rx->subbeg);
1382 RX_MATCH_COPIED_off(rx);
1383 rx->subbeg = Nullch;
1385 rx->subbeg = truebase;
1386 rx->startp[0] = s - truebase;
1387 if (RX_MATCH_UTF8(rx)) {
1388 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1389 rx->endp[0] = t - truebase;
1392 rx->endp[0] = s - truebase + rx->minlen;
1394 rx->sublen = strend - truebase;
1397 if (PL_sawampersand) {
1399 #ifdef PERL_COPY_ON_WRITE
1400 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1402 PerlIO_printf(Perl_debug_log,
1403 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1404 (int) SvTYPE(TARG), truebase, t,
1407 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1408 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1409 assert (SvPOKp(rx->saved_copy));
1414 rx->subbeg = savepvn(t, strend - t);
1415 #ifdef PERL_COPY_ON_WRITE
1416 rx->saved_copy = Nullsv;
1419 rx->sublen = strend - t;
1420 RX_MATCH_COPIED_on(rx);
1421 off = rx->startp[0] = s - t;
1422 rx->endp[0] = off + rx->minlen;
1424 else { /* startp/endp are used by @- @+. */
1425 rx->startp[0] = s - truebase;
1426 rx->endp[0] = s - truebase + rx->minlen;
1428 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1429 LEAVE_SCOPE(oldsave);
1434 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1435 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1436 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1441 LEAVE_SCOPE(oldsave);
1442 if (gimme == G_ARRAY)
1448 Perl_do_readline(pTHX)
1450 dSP; dTARGETSTACKED;
1455 register IO *io = GvIO(PL_last_in_gv);
1456 register I32 type = PL_op->op_type;
1457 I32 gimme = GIMME_V;
1460 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1462 XPUSHs(SvTIED_obj((SV*)io, mg));
1465 call_method("READLINE", gimme);
1468 if (gimme == G_SCALAR) {
1470 SvSetSV_nosteal(TARG, result);
1479 if (IoFLAGS(io) & IOf_ARGV) {
1480 if (IoFLAGS(io) & IOf_START) {
1482 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1483 IoFLAGS(io) &= ~IOf_START;
1484 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1485 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1486 SvSETMAGIC(GvSV(PL_last_in_gv));
1491 fp = nextargv(PL_last_in_gv);
1492 if (!fp) { /* Note: fp != IoIFP(io) */
1493 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1496 else if (type == OP_GLOB)
1497 fp = Perl_start_glob(aTHX_ POPs, io);
1499 else if (type == OP_GLOB)
1501 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1502 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1506 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1507 && (!io || !(IoFLAGS(io) & IOf_START))) {
1508 if (type == OP_GLOB)
1509 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1510 "glob failed (can't start child: %s)",
1513 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1515 if (gimme == G_SCALAR) {
1516 /* undef TARG, and push that undefined value */
1517 if (type != OP_RCATLINE) {
1518 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1519 (void)SvOK_off(TARG);
1526 if (gimme == G_SCALAR) {
1530 (void)SvUPGRADE(sv, SVt_PV);
1531 tmplen = SvLEN(sv); /* remember if already alloced */
1532 if (!tmplen && !SvREADONLY(sv))
1533 Sv_Grow(sv, 80); /* try short-buffering it */
1535 if (type == OP_RCATLINE && SvOK(sv)) {
1538 (void)SvPV_force(sv, n_a);
1544 sv = sv_2mortal(NEWSV(57, 80));
1548 /* This should not be marked tainted if the fp is marked clean */
1549 #define MAYBE_TAINT_LINE(io, sv) \
1550 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1555 /* delay EOF state for a snarfed empty file */
1556 #define SNARF_EOF(gimme,rs,io,sv) \
1557 (gimme != G_SCALAR || SvCUR(sv) \
1558 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1562 if (!sv_gets(sv, fp, offset)
1564 || SNARF_EOF(gimme, PL_rs, io, sv)
1565 || PerlIO_error(fp)))
1567 PerlIO_clearerr(fp);
1568 if (IoFLAGS(io) & IOf_ARGV) {
1569 fp = nextargv(PL_last_in_gv);
1572 (void)do_close(PL_last_in_gv, FALSE);
1574 else if (type == OP_GLOB) {
1575 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1576 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1577 "glob failed (child exited with status %d%s)",
1578 (int)(STATUS_CURRENT >> 8),
1579 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1582 if (gimme == G_SCALAR) {
1583 if (type != OP_RCATLINE) {
1584 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1585 (void)SvOK_off(TARG);
1590 MAYBE_TAINT_LINE(io, sv);
1593 MAYBE_TAINT_LINE(io, sv);
1595 IoFLAGS(io) |= IOf_NOLINE;
1599 if (type == OP_GLOB) {
1602 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1603 tmps = SvEND(sv) - 1;
1604 if (*tmps == *SvPVX(PL_rs)) {
1609 for (tmps = SvPVX(sv); *tmps; tmps++)
1610 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1611 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1613 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1614 (void)POPs; /* Unmatched wildcard? Chuck it... */
1617 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1618 U8 *s = (U8*)SvPVX(sv) + offset;
1619 STRLEN len = SvCUR(sv) - offset;
1622 if (ckWARN(WARN_UTF8) &&
1623 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1624 /* Emulate :encoding(utf8) warning in the same case. */
1625 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1626 "utf8 \"\\x%02X\" does not map to Unicode",
1627 f < (U8*)SvEND(sv) ? *f : 0);
1629 if (gimme == G_ARRAY) {
1630 if (SvLEN(sv) - SvCUR(sv) > 20) {
1631 SvLEN_set(sv, SvCUR(sv)+1);
1632 Renew(SvPVX(sv), SvLEN(sv), char);
1634 sv = sv_2mortal(NEWSV(58, 80));
1637 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1638 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1642 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1643 Renew(SvPVX(sv), SvLEN(sv), char);
1652 register PERL_CONTEXT *cx;
1653 I32 gimme = OP_GIMME(PL_op, -1);
1656 if (cxstack_ix >= 0)
1657 gimme = cxstack[cxstack_ix].blk_gimme;
1665 PUSHBLOCK(cx, CXt_BLOCK, SP);
1677 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1678 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1680 #ifdef PERL_COPY_ON_WRITE
1681 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1683 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1687 if (SvTYPE(hv) == SVt_PVHV) {
1688 if (PL_op->op_private & OPpLVAL_INTRO) {
1691 /* does the element we're localizing already exist? */
1693 /* can we determine whether it exists? */
1695 || mg_find((SV*)hv, PERL_MAGIC_env)
1696 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1697 /* Try to preserve the existenceness of a tied hash
1698 * element by using EXISTS and DELETE if possible.
1699 * Fallback to FETCH and STORE otherwise */
1700 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1701 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1702 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1704 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1707 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1708 svp = he ? &HeVAL(he) : 0;
1714 if (!svp || *svp == &PL_sv_undef) {
1719 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1721 lv = sv_newmortal();
1722 sv_upgrade(lv, SVt_PVLV);
1724 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1725 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1726 LvTARG(lv) = SvREFCNT_inc(hv);
1731 if (PL_op->op_private & OPpLVAL_INTRO) {
1732 if (HvNAME(hv) && isGV(*svp))
1733 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1737 char *key = SvPV(keysv, keylen);
1738 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1740 save_helem(hv, keysv, svp);
1743 else if (PL_op->op_private & OPpDEREF)
1744 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1746 sv = (svp ? *svp : &PL_sv_undef);
1747 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1748 * Pushing the magical RHS on to the stack is useless, since
1749 * that magic is soon destined to be misled by the local(),
1750 * and thus the later pp_sassign() will fail to mg_get() the
1751 * old value. This should also cure problems with delayed
1752 * mg_get()s. GSAR 98-07-03 */
1753 if (!lval && SvGMAGICAL(sv))
1754 sv = sv_mortalcopy(sv);
1762 register PERL_CONTEXT *cx;
1768 if (PL_op->op_flags & OPf_SPECIAL) {
1769 cx = &cxstack[cxstack_ix];
1770 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1775 gimme = OP_GIMME(PL_op, -1);
1777 if (cxstack_ix >= 0)
1778 gimme = cxstack[cxstack_ix].blk_gimme;
1784 if (gimme == G_VOID)
1786 else if (gimme == G_SCALAR) {
1789 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1792 *MARK = sv_mortalcopy(TOPs);
1795 *MARK = &PL_sv_undef;
1799 else if (gimme == G_ARRAY) {
1800 /* in case LEAVE wipes old return values */
1801 for (mark = newsp + 1; mark <= SP; mark++) {
1802 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1803 *mark = sv_mortalcopy(*mark);
1804 TAINT_NOT; /* Each item is independent */
1808 PL_curpm = newpm; /* Don't pop $1 et al till now */
1818 register PERL_CONTEXT *cx;
1824 cx = &cxstack[cxstack_ix];
1825 if (CxTYPE(cx) != CXt_LOOP)
1826 DIE(aTHX_ "panic: pp_iter");
1828 itersvp = CxITERVAR(cx);
1829 av = cx->blk_loop.iterary;
1830 if (SvTYPE(av) != SVt_PVAV) {
1831 /* iterate ($min .. $max) */
1832 if (cx->blk_loop.iterlval) {
1833 /* string increment */
1834 register SV* cur = cx->blk_loop.iterlval;
1836 char *max = SvPV((SV*)av, maxlen);
1837 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1838 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1839 /* safe to reuse old SV */
1840 sv_setsv(*itersvp, cur);
1844 /* we need a fresh SV every time so that loop body sees a
1845 * completely new SV for closures/references to work as
1847 SvREFCNT_dec(*itersvp);
1848 *itersvp = newSVsv(cur);
1850 if (strEQ(SvPVX(cur), max))
1851 sv_setiv(cur, 0); /* terminate next time */
1858 /* integer increment */
1859 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1862 /* don't risk potential race */
1863 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1864 /* safe to reuse old SV */
1865 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1869 /* we need a fresh SV every time so that loop body sees a
1870 * completely new SV for closures/references to work as they
1872 SvREFCNT_dec(*itersvp);
1873 *itersvp = newSViv(cx->blk_loop.iterix++);
1879 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1882 SvREFCNT_dec(*itersvp);
1884 if (SvMAGICAL(av) || AvREIFY(av)) {
1885 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1892 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1894 if (sv && SvREFCNT(sv) == 0) {
1896 Perl_croak(aTHX_ "Use of freed value in iteration");
1903 if (av != PL_curstack && sv == &PL_sv_undef) {
1904 SV *lv = cx->blk_loop.iterlval;
1905 if (lv && SvREFCNT(lv) > 1) {
1910 SvREFCNT_dec(LvTARG(lv));
1912 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1913 sv_upgrade(lv, SVt_PVLV);
1915 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1917 LvTARG(lv) = SvREFCNT_inc(av);
1918 LvTARGOFF(lv) = cx->blk_loop.iterix;
1919 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1923 *itersvp = SvREFCNT_inc(sv);
1930 register PMOP *pm = cPMOP;
1946 register REGEXP *rx = PM_GETRE(pm);
1948 int force_on_match = 0;
1949 I32 oldsave = PL_savestack_ix;
1951 bool doutf8 = FALSE;
1952 #ifdef PERL_COPY_ON_WRITE
1957 /* known replacement string? */
1958 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1959 if (PL_op->op_flags & OPf_STACKED)
1966 #ifdef PERL_COPY_ON_WRITE
1967 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1968 because they make integers such as 256 "false". */
1969 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1972 sv_force_normal_flags(TARG,0);
1975 #ifdef PERL_COPY_ON_WRITE
1979 || (SvTYPE(TARG) > SVt_PVLV
1980 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1981 DIE(aTHX_ PL_no_modify);
1984 s = SvPV(TARG, len);
1985 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1987 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1988 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1993 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1997 DIE(aTHX_ "panic: pp_subst");
2000 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2001 maxiters = 2 * slen + 10; /* We can match twice at each
2002 position, once with zero-length,
2003 second time with non-zero. */
2005 if (!rx->prelen && PL_curpm) {
2009 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2010 ? REXEC_COPY_STR : 0;
2012 r_flags |= REXEC_SCREAM;
2013 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
2014 SAVEINT(PL_multiline);
2015 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2018 if (rx->reganch & RE_USE_INTUIT) {
2020 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2024 /* How to do it in subst? */
2025 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2027 && ((rx->reganch & ROPT_NOSCAN)
2028 || !((rx->reganch & RE_INTUIT_TAIL)
2029 && (r_flags & REXEC_SCREAM))))
2034 /* only replace once? */
2035 once = !(rpm->op_pmflags & PMf_GLOBAL);
2037 /* known replacement string? */
2039 /* replacement needing upgrading? */
2040 if (DO_UTF8(TARG) && !doutf8) {
2041 nsv = sv_newmortal();
2044 sv_recode_to_utf8(nsv, PL_encoding);
2046 sv_utf8_upgrade(nsv);
2047 c = SvPV(nsv, clen);
2051 c = SvPV(dstr, clen);
2052 doutf8 = DO_UTF8(dstr);
2060 /* can do inplace substitution? */
2062 #ifdef PERL_COPY_ON_WRITE
2065 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2066 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2067 && (!doutf8 || SvUTF8(TARG))) {
2068 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2069 r_flags | REXEC_CHECKED))
2073 LEAVE_SCOPE(oldsave);
2076 #ifdef PERL_COPY_ON_WRITE
2077 if (SvIsCOW(TARG)) {
2078 assert (!force_on_match);
2082 if (force_on_match) {
2084 s = SvPV_force(TARG, len);
2089 SvSCREAM_off(TARG); /* disable possible screamer */
2091 rxtainted |= RX_MATCH_TAINTED(rx);
2092 m = orig + rx->startp[0];
2093 d = orig + rx->endp[0];
2095 if (m - s > strend - d) { /* faster to shorten from end */
2097 Copy(c, m, clen, char);
2102 Move(d, m, i, char);
2106 SvCUR_set(TARG, m - s);
2109 else if ((i = m - s)) { /* faster from front */
2117 Copy(c, m, clen, char);
2122 Copy(c, d, clen, char);
2127 TAINT_IF(rxtainted & 1);
2133 if (iters++ > maxiters)
2134 DIE(aTHX_ "Substitution loop");
2135 rxtainted |= RX_MATCH_TAINTED(rx);
2136 m = rx->startp[0] + orig;
2140 Move(s, d, i, char);
2144 Copy(c, d, clen, char);
2147 s = rx->endp[0] + orig;
2148 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2150 /* don't match same null twice */
2151 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2154 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2155 Move(s, d, i+1, char); /* include the NUL */
2157 TAINT_IF(rxtainted & 1);
2159 PUSHs(sv_2mortal(newSViv((I32)iters)));
2161 (void)SvPOK_only_UTF8(TARG);
2162 TAINT_IF(rxtainted);
2163 if (SvSMAGICAL(TARG)) {
2171 LEAVE_SCOPE(oldsave);
2175 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2176 r_flags | REXEC_CHECKED))
2178 if (force_on_match) {
2180 s = SvPV_force(TARG, len);
2183 #ifdef PERL_COPY_ON_WRITE
2186 rxtainted |= RX_MATCH_TAINTED(rx);
2187 dstr = NEWSV(25, len);
2188 sv_setpvn(dstr, m, s-m);
2193 register PERL_CONTEXT *cx;
2197 RETURNOP(cPMOP->op_pmreplroot);
2199 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2201 if (iters++ > maxiters)
2202 DIE(aTHX_ "Substitution loop");
2203 rxtainted |= RX_MATCH_TAINTED(rx);
2204 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2209 strend = s + (strend - m);
2211 m = rx->startp[0] + orig;
2212 if (doutf8 && !SvUTF8(dstr))
2213 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2215 sv_catpvn(dstr, s, m-s);
2216 s = rx->endp[0] + orig;
2218 sv_catpvn(dstr, c, clen);
2221 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2222 TARG, NULL, r_flags));
2223 if (doutf8 && !DO_UTF8(TARG))
2224 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2226 sv_catpvn(dstr, s, strend - s);
2228 #ifdef PERL_COPY_ON_WRITE
2229 /* The match may make the string COW. If so, brilliant, because that's
2230 just saved us one malloc, copy and free - the regexp has donated
2231 the old buffer, and we malloc an entirely new one, rather than the
2232 regexp malloc()ing a buffer and copying our original, only for
2233 us to throw it away here during the substitution. */
2234 if (SvIsCOW(TARG)) {
2235 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2239 (void)SvOOK_off(TARG);
2241 Safefree(SvPVX(TARG));
2243 SvPVX(TARG) = SvPVX(dstr);
2244 SvCUR_set(TARG, SvCUR(dstr));
2245 SvLEN_set(TARG, SvLEN(dstr));
2246 doutf8 |= DO_UTF8(dstr);
2250 TAINT_IF(rxtainted & 1);
2252 PUSHs(sv_2mortal(newSViv((I32)iters)));
2254 (void)SvPOK_only(TARG);
2257 TAINT_IF(rxtainted);
2260 LEAVE_SCOPE(oldsave);
2269 LEAVE_SCOPE(oldsave);
2278 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2279 ++*PL_markstack_ptr;
2280 LEAVE; /* exit inner scope */
2283 if (PL_stack_base + *PL_markstack_ptr > SP) {
2285 I32 gimme = GIMME_V;
2287 LEAVE; /* exit outer scope */
2288 (void)POPMARK; /* pop src */
2289 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2290 (void)POPMARK; /* pop dst */
2291 SP = PL_stack_base + POPMARK; /* pop original mark */
2292 if (gimme == G_SCALAR) {
2296 else if (gimme == G_ARRAY)
2303 ENTER; /* enter inner scope */
2306 src = PL_stack_base[*PL_markstack_ptr];
2310 RETURNOP(cLOGOP->op_other);
2321 register PERL_CONTEXT *cx;
2325 cxstack_ix++; /* temporarily protect top context */
2328 if (gimme == G_SCALAR) {
2331 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2333 *MARK = SvREFCNT_inc(TOPs);
2338 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2340 *MARK = sv_mortalcopy(sv);
2345 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2349 *MARK = &PL_sv_undef;
2353 else if (gimme == G_ARRAY) {
2354 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2355 if (!SvTEMP(*MARK)) {
2356 *MARK = sv_mortalcopy(*MARK);
2357 TAINT_NOT; /* Each item is independent */
2365 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2366 PL_curpm = newpm; /* ... and pop $1 et al */
2369 return pop_return();
2372 /* This duplicates the above code because the above code must not
2373 * get any slower by more conditions */
2381 register PERL_CONTEXT *cx;
2385 cxstack_ix++; /* temporarily protect top context */
2389 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2390 /* We are an argument to a function or grep().
2391 * This kind of lvalueness was legal before lvalue
2392 * subroutines too, so be backward compatible:
2393 * cannot report errors. */
2395 /* Scalar context *is* possible, on the LHS of -> only,
2396 * as in f()->meth(). But this is not an lvalue. */
2397 if (gimme == G_SCALAR)
2399 if (gimme == G_ARRAY) {
2400 if (!CvLVALUE(cx->blk_sub.cv))
2401 goto temporise_array;
2402 EXTEND_MORTAL(SP - newsp);
2403 for (mark = newsp + 1; mark <= SP; mark++) {
2406 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2407 *mark = sv_mortalcopy(*mark);
2409 /* Can be a localized value subject to deletion. */
2410 PL_tmps_stack[++PL_tmps_ix] = *mark;
2411 (void)SvREFCNT_inc(*mark);
2416 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2417 /* Here we go for robustness, not for speed, so we change all
2418 * the refcounts so the caller gets a live guy. Cannot set
2419 * TEMP, so sv_2mortal is out of question. */
2420 if (!CvLVALUE(cx->blk_sub.cv)) {
2426 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2428 if (gimme == G_SCALAR) {
2432 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2438 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2439 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2440 : "a readonly value" : "a temporary");
2442 else { /* Can be a localized value
2443 * subject to deletion. */
2444 PL_tmps_stack[++PL_tmps_ix] = *mark;
2445 (void)SvREFCNT_inc(*mark);
2448 else { /* Should not happen? */
2454 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2455 (MARK > SP ? "Empty array" : "Array"));
2459 else if (gimme == G_ARRAY) {
2460 EXTEND_MORTAL(SP - newsp);
2461 for (mark = newsp + 1; mark <= SP; mark++) {
2462 if (*mark != &PL_sv_undef
2463 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2464 /* Might be flattened array after $#array = */
2471 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2472 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2475 /* Can be a localized value subject to deletion. */
2476 PL_tmps_stack[++PL_tmps_ix] = *mark;
2477 (void)SvREFCNT_inc(*mark);
2483 if (gimme == G_SCALAR) {
2487 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2489 *MARK = SvREFCNT_inc(TOPs);
2494 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2496 *MARK = sv_mortalcopy(sv);
2501 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2505 *MARK = &PL_sv_undef;
2509 else if (gimme == G_ARRAY) {
2511 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2512 if (!SvTEMP(*MARK)) {
2513 *MARK = sv_mortalcopy(*MARK);
2514 TAINT_NOT; /* Each item is independent */
2523 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2524 PL_curpm = newpm; /* ... and pop $1 et al */
2527 return pop_return();
2532 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2534 SV *dbsv = GvSV(PL_DBsub);
2536 if (!PERLDB_SUB_NN) {
2540 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2541 || strEQ(GvNAME(gv), "END")
2542 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2543 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2544 && (gv = (GV*)*svp) ))) {
2545 /* Use GV from the stack as a fallback. */
2546 /* GV is potentially non-unique, or contain different CV. */
2547 SV *tmp = newRV((SV*)cv);
2548 sv_setsv(dbsv, tmp);
2552 gv_efullname3(dbsv, gv, Nullch);
2556 (void)SvUPGRADE(dbsv, SVt_PVIV);
2557 (void)SvIOK_on(dbsv);
2558 SAVEIV(SvIVX(dbsv));
2559 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2563 PL_curcopdb = PL_curcop;
2564 cv = GvCV(PL_DBsub);
2574 register PERL_CONTEXT *cx;
2576 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2579 DIE(aTHX_ "Not a CODE reference");
2580 switch (SvTYPE(sv)) {
2581 /* This is overwhelming the most common case: */
2583 if (!(cv = GvCVu((GV*)sv)))
2584 cv = sv_2cv(sv, &stash, &gv, FALSE);
2596 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2598 SP = PL_stack_base + POPMARK;
2601 if (SvGMAGICAL(sv)) {
2605 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2608 sym = SvPV(sv, n_a);
2610 DIE(aTHX_ PL_no_usym, "a subroutine");
2611 if (PL_op->op_private & HINT_STRICT_REFS)
2612 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2613 cv = get_cv(sym, TRUE);
2618 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2619 tryAMAGICunDEREF(to_cv);
2622 if (SvTYPE(cv) == SVt_PVCV)
2627 DIE(aTHX_ "Not a CODE reference");
2628 /* This is the second most common case: */
2638 if (!CvROOT(cv) && !CvXSUB(cv)) {
2643 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2644 if (CvASSERTION(cv) && PL_DBassertion)
2645 sv_setiv(PL_DBassertion, 1);
2647 cv = get_db_sub(&sv, cv);
2649 DIE(aTHX_ "No DBsub routine");
2652 if (!(CvXSUB(cv))) {
2653 /* This path taken at least 75% of the time */
2655 register I32 items = SP - MARK;
2656 AV* padlist = CvPADLIST(cv);
2657 push_return(PL_op->op_next);
2658 PUSHBLOCK(cx, CXt_SUB, MARK);
2661 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2662 * that eval'' ops within this sub know the correct lexical space.
2663 * Owing the speed considerations, we choose instead to search for
2664 * the cv using find_runcv() when calling doeval().
2666 if (CvDEPTH(cv) < 2)
2667 (void)SvREFCNT_inc(cv);
2669 PERL_STACK_OVERFLOW_CHECK();
2670 pad_push(padlist, CvDEPTH(cv), 1);
2672 PAD_SET_CUR(padlist, CvDEPTH(cv));
2679 DEBUG_S(PerlIO_printf(Perl_debug_log,
2680 "%p entersub preparing @_\n", thr));
2682 av = (AV*)PAD_SVl(0);
2684 /* @_ is normally not REAL--this should only ever
2685 * happen when DB::sub() calls things that modify @_ */
2690 cx->blk_sub.savearray = GvAV(PL_defgv);
2691 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2692 CX_CURPAD_SAVE(cx->blk_sub);
2693 cx->blk_sub.argarray = av;
2696 if (items > AvMAX(av) + 1) {
2698 if (AvARRAY(av) != ary) {
2699 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2700 SvPVX(av) = (char*)ary;
2702 if (items > AvMAX(av) + 1) {
2703 AvMAX(av) = items - 1;
2704 Renew(ary,items,SV*);
2706 SvPVX(av) = (char*)ary;
2709 Copy(MARK,AvARRAY(av),items,SV*);
2710 AvFILLp(av) = items - 1;
2718 /* warning must come *after* we fully set up the context
2719 * stuff so that __WARN__ handlers can safely dounwind()
2722 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2723 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2724 sub_crush_depth(cv);
2726 DEBUG_S(PerlIO_printf(Perl_debug_log,
2727 "%p entersub returning %p\n", thr, CvSTART(cv)));
2729 RETURNOP(CvSTART(cv));
2732 #ifdef PERL_XSUB_OLDSTYLE
2733 if (CvOLDSTYLE(cv)) {
2734 I32 (*fp3)(int,int,int);
2736 register I32 items = SP - MARK;
2737 /* We dont worry to copy from @_. */
2742 PL_stack_sp = mark + 1;
2743 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2744 items = (*fp3)(CvXSUBANY(cv).any_i32,
2745 MARK - PL_stack_base + 1,
2747 PL_stack_sp = PL_stack_base + items;
2750 #endif /* PERL_XSUB_OLDSTYLE */
2752 I32 markix = TOPMARK;
2757 /* Need to copy @_ to stack. Alternative may be to
2758 * switch stack to @_, and copy return values
2759 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2762 av = GvAV(PL_defgv);
2763 items = AvFILLp(av) + 1; /* @_ is not tieable */
2766 /* Mark is at the end of the stack. */
2768 Copy(AvARRAY(av), SP + 1, items, SV*);
2773 /* We assume first XSUB in &DB::sub is the called one. */
2775 SAVEVPTR(PL_curcop);
2776 PL_curcop = PL_curcopdb;
2779 /* Do we need to open block here? XXXX */
2780 (void)(*CvXSUB(cv))(aTHX_ cv);
2782 /* Enforce some sanity in scalar context. */
2783 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2784 if (markix > PL_stack_sp - PL_stack_base)
2785 *(PL_stack_base + markix) = &PL_sv_undef;
2787 *(PL_stack_base + markix) = *PL_stack_sp;
2788 PL_stack_sp = PL_stack_base + markix;
2795 assert (0); /* Cannot get here. */
2796 /* This is deliberately moved here as spaghetti code to keep it out of the
2803 /* anonymous or undef'd function leaves us no recourse */
2804 if (CvANON(cv) || !(gv = CvGV(cv)))
2805 DIE(aTHX_ "Undefined subroutine called");
2807 /* autoloaded stub? */
2808 if (cv != GvCV(gv)) {
2811 /* should call AUTOLOAD now? */
2814 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2821 sub_name = sv_newmortal();
2822 gv_efullname3(sub_name, gv, Nullch);
2823 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2827 DIE(aTHX_ "Not a CODE reference");
2833 Perl_sub_crush_depth(pTHX_ CV *cv)
2836 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2838 SV* tmpstr = sv_newmortal();
2839 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2840 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2850 IV elem = SvIV(elemsv);
2852 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2853 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2856 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2857 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2859 elem -= PL_curcop->cop_arybase;
2860 if (SvTYPE(av) != SVt_PVAV)
2862 svp = av_fetch(av, elem, lval && !defer);
2864 if (!svp || *svp == &PL_sv_undef) {
2867 DIE(aTHX_ PL_no_aelem, elem);
2868 lv = sv_newmortal();
2869 sv_upgrade(lv, SVt_PVLV);
2871 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2872 LvTARG(lv) = SvREFCNT_inc(av);
2873 LvTARGOFF(lv) = elem;
2878 if (PL_op->op_private & OPpLVAL_INTRO)
2879 save_aelem(av, elem, svp);
2880 else if (PL_op->op_private & OPpDEREF)
2881 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2883 sv = (svp ? *svp : &PL_sv_undef);
2884 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2885 sv = sv_mortalcopy(sv);
2891 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2897 Perl_croak(aTHX_ PL_no_modify);
2898 if (SvTYPE(sv) < SVt_RV)
2899 sv_upgrade(sv, SVt_RV);
2900 else if (SvTYPE(sv) >= SVt_PV) {
2901 (void)SvOOK_off(sv);
2902 Safefree(SvPVX(sv));
2903 SvLEN(sv) = SvCUR(sv) = 0;
2907 SvRV(sv) = NEWSV(355,0);
2910 SvRV(sv) = (SV*)newAV();
2913 SvRV(sv) = (SV*)newHV();
2928 if (SvTYPE(rsv) == SVt_PVCV) {
2934 SETs(method_common(sv, Null(U32*)));
2942 U32 hash = SvUVX(sv);
2944 XPUSHs(method_common(sv, &hash));
2949 S_method_common(pTHX_ SV* meth, U32* hashp)
2958 SV *packsv = Nullsv;
2961 name = SvPV(meth, namelen);
2962 sv = *(PL_stack_base + TOPMARK + 1);
2965 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2974 /* this isn't a reference */
2977 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2979 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2981 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2988 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2989 !(ob=(SV*)GvIO(iogv)))
2991 /* this isn't the name of a filehandle either */
2993 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2994 ? !isIDFIRST_utf8((U8*)packname)
2995 : !isIDFIRST(*packname)
2998 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2999 SvOK(sv) ? "without a package or object reference"
3000 : "on an undefined value");
3002 /* assume it's a package name */
3003 stash = gv_stashpvn(packname, packlen, FALSE);
3007 SV* ref = newSViv(PTR2IV(stash));
3008 hv_store(PL_stashcache, packname, packlen, ref, 0);
3012 /* it _is_ a filehandle name -- replace with a reference */
3013 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3016 /* if we got here, ob should be a reference or a glob */
3017 if (!ob || !(SvOBJECT(ob)
3018 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3021 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3025 stash = SvSTASH(ob);
3028 /* NOTE: stash may be null, hope hv_fetch_ent and
3029 gv_fetchmethod can cope (it seems they can) */
3031 /* shortcut for simple names */
3033 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3035 gv = (GV*)HeVAL(he);
3036 if (isGV(gv) && GvCV(gv) &&
3037 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3038 return (SV*)GvCV(gv);
3042 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3045 /* This code tries to figure out just what went wrong with
3046 gv_fetchmethod. It therefore needs to duplicate a lot of
3047 the internals of that function. We can't move it inside
3048 Perl_gv_fetchmethod_autoload(), however, since that would
3049 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3056 for (p = name; *p; p++) {
3058 sep = p, leaf = p + 1;
3059 else if (*p == ':' && *(p + 1) == ':')
3060 sep = p, leaf = p + 2;
3062 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3063 /* the method name is unqualified or starts with SUPER:: */
3064 packname = sep ? CopSTASHPV(PL_curcop) :
3065 stash ? HvNAME(stash) : packname;
3068 "Can't use anonymous symbol table for method lookup");
3070 packlen = strlen(packname);
3073 /* the method name is qualified */
3075 packlen = sep - name;
3078 /* we're relying on gv_fetchmethod not autovivifying the stash */
3079 if (gv_stashpvn(packname, packlen, FALSE)) {
3081 "Can't locate object method \"%s\" via package \"%.*s\"",
3082 leaf, (int)packlen, packname);
3086 "Can't locate object method \"%s\" via package \"%.*s\""
3087 " (perhaps you forgot to load \"%.*s\"?)",
3088 leaf, (int)packlen, packname, (int)packlen, packname);
3091 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;