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;
972 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
975 /* If there's a common identifier on both sides we have to take
976 * special care that assigning the identifier on the left doesn't
977 * clobber a value on the right that's used later in the list.
979 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
980 EXTEND_MORTAL(lastrelem - firstrelem + 1);
981 for (relem = firstrelem; relem <= lastrelem; relem++) {
984 TAINT_NOT; /* Each item is independent */
985 *relem = sv_mortalcopy(sv);
995 while (lelem <= lastlelem) {
996 TAINT_NOT; /* Each item stands on its own, taintwise. */
998 switch (SvTYPE(sv)) {
1001 magic = SvMAGICAL(ary) != 0;
1003 av_extend(ary, lastrelem - relem);
1005 while (relem <= lastrelem) { /* gobble up all the rest */
1009 sv_setsv(sv,*relem);
1011 didstore = av_store(ary,i++,sv);
1021 case SVt_PVHV: { /* normal hash */
1025 magic = SvMAGICAL(hash) != 0;
1027 firsthashrelem = relem;
1029 while (relem < lastrelem) { /* gobble up all the rest */
1034 sv = &PL_sv_no, relem++;
1035 tmpstr = NEWSV(29,0);
1037 sv_setsv(tmpstr,*relem); /* value */
1038 *(relem++) = tmpstr;
1039 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1040 /* key overwrites an existing entry */
1042 didstore = hv_store_ent(hash,sv,tmpstr,0);
1044 if (SvSMAGICAL(tmpstr))
1051 if (relem == lastrelem) {
1052 do_oddball(hash, relem, firstrelem);
1058 if (SvIMMORTAL(sv)) {
1059 if (relem <= lastrelem)
1063 if (relem <= lastrelem) {
1064 sv_setsv(sv, *relem);
1068 sv_setsv(sv, &PL_sv_undef);
1073 if (PL_delaymagic & ~DM_DELAY) {
1074 if (PL_delaymagic & DM_UID) {
1075 #ifdef HAS_SETRESUID
1076 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1077 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1080 # ifdef HAS_SETREUID
1081 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1082 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1085 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1086 (void)setruid(PL_uid);
1087 PL_delaymagic &= ~DM_RUID;
1089 # endif /* HAS_SETRUID */
1091 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1092 (void)seteuid(PL_euid);
1093 PL_delaymagic &= ~DM_EUID;
1095 # endif /* HAS_SETEUID */
1096 if (PL_delaymagic & DM_UID) {
1097 if (PL_uid != PL_euid)
1098 DIE(aTHX_ "No setreuid available");
1099 (void)PerlProc_setuid(PL_uid);
1101 # endif /* HAS_SETREUID */
1102 #endif /* HAS_SETRESUID */
1103 PL_uid = PerlProc_getuid();
1104 PL_euid = PerlProc_geteuid();
1106 if (PL_delaymagic & DM_GID) {
1107 #ifdef HAS_SETRESGID
1108 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1109 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1112 # ifdef HAS_SETREGID
1113 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1114 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1117 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1118 (void)setrgid(PL_gid);
1119 PL_delaymagic &= ~DM_RGID;
1121 # endif /* HAS_SETRGID */
1123 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1124 (void)setegid(PL_egid);
1125 PL_delaymagic &= ~DM_EGID;
1127 # endif /* HAS_SETEGID */
1128 if (PL_delaymagic & DM_GID) {
1129 if (PL_gid != PL_egid)
1130 DIE(aTHX_ "No setregid available");
1131 (void)PerlProc_setgid(PL_gid);
1133 # endif /* HAS_SETREGID */
1134 #endif /* HAS_SETRESGID */
1135 PL_gid = PerlProc_getgid();
1136 PL_egid = PerlProc_getegid();
1138 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1142 if (gimme == G_VOID)
1143 SP = firstrelem - 1;
1144 else if (gimme == G_SCALAR) {
1147 SETi(lastrelem - firstrelem + 1 - duplicates);
1154 /* Removes from the stack the entries which ended up as
1155 * duplicated keys in the hash (fix for [perl #24380]) */
1156 Move(firsthashrelem + duplicates,
1157 firsthashrelem, duplicates, SV**);
1158 lastrelem -= duplicates;
1163 SP = firstrelem + (lastlelem - firstlelem);
1164 lelem = firstlelem + (relem - firstrelem);
1166 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1174 register PMOP *pm = cPMOP;
1175 SV *rv = sv_newmortal();
1176 SV *sv = newSVrv(rv, "Regexp");
1177 if (pm->op_pmdynflags & PMdf_TAINTED)
1179 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1186 register PMOP *pm = cPMOP;
1192 I32 r_flags = REXEC_CHECKED;
1193 char *truebase; /* Start of string */
1194 register REGEXP *rx = PM_GETRE(pm);
1199 I32 oldsave = PL_savestack_ix;
1200 I32 update_minmatch = 1;
1201 I32 had_zerolen = 0;
1203 if (PL_op->op_flags & OPf_STACKED)
1210 PUTBACK; /* EVAL blocks need stack_sp. */
1211 s = SvPV(TARG, len);
1214 DIE(aTHX_ "panic: pp_match");
1215 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1216 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1219 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1221 /* PMdf_USED is set after a ?? matches once */
1222 if (pm->op_pmdynflags & PMdf_USED) {
1224 if (gimme == G_ARRAY)
1229 /* empty pattern special-cased to use last successful pattern if possible */
1230 if (!rx->prelen && PL_curpm) {
1235 if (rx->minlen > (I32)len)
1240 /* XXXX What part of this is needed with true \G-support? */
1241 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1243 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1244 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1245 if (mg && mg->mg_len >= 0) {
1246 if (!(rx->reganch & ROPT_GPOS_SEEN))
1247 rx->endp[0] = rx->startp[0] = mg->mg_len;
1248 else if (rx->reganch & ROPT_ANCH_GPOS) {
1249 r_flags |= REXEC_IGNOREPOS;
1250 rx->endp[0] = rx->startp[0] = mg->mg_len;
1252 minmatch = (mg->mg_flags & MGf_MINMATCH);
1253 update_minmatch = 0;
1257 if ((!global && rx->nparens)
1258 || SvTEMP(TARG) || PL_sawampersand)
1259 r_flags |= REXEC_COPY_STR;
1261 r_flags |= REXEC_SCREAM;
1263 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1264 SAVEINT(PL_multiline);
1265 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1269 if (global && rx->startp[0] != -1) {
1270 t = s = rx->endp[0] + truebase;
1271 if ((s + rx->minlen) > strend)
1273 if (update_minmatch++)
1274 minmatch = had_zerolen;
1276 if (rx->reganch & RE_USE_INTUIT &&
1277 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1278 PL_bostr = truebase;
1279 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1283 if ( (rx->reganch & ROPT_CHECK_ALL)
1285 && ((rx->reganch & ROPT_NOSCAN)
1286 || !((rx->reganch & RE_INTUIT_TAIL)
1287 && (r_flags & REXEC_SCREAM)))
1288 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1291 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1294 if (dynpm->op_pmflags & PMf_ONCE)
1295 dynpm->op_pmdynflags |= PMdf_USED;
1304 RX_MATCH_TAINTED_on(rx);
1305 TAINT_IF(RX_MATCH_TAINTED(rx));
1306 if (gimme == G_ARRAY) {
1307 I32 nparens, i, len;
1309 nparens = rx->nparens;
1310 if (global && !nparens)
1314 SPAGAIN; /* EVAL blocks could move the stack. */
1315 EXTEND(SP, nparens + i);
1316 EXTEND_MORTAL(nparens + i);
1317 for (i = !i; i <= nparens; i++) {
1318 PUSHs(sv_newmortal());
1320 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1321 len = rx->endp[i] - rx->startp[i];
1322 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1323 len < 0 || len > strend - s)
1324 DIE(aTHX_ "panic: pp_match start/end pointers");
1325 s = rx->startp[i] + truebase;
1326 sv_setpvn(*SP, s, len);
1327 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1332 if (dynpm->op_pmflags & PMf_CONTINUE) {
1334 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1335 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1337 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1338 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1340 if (rx->startp[0] != -1) {
1341 mg->mg_len = rx->endp[0];
1342 if (rx->startp[0] == rx->endp[0])
1343 mg->mg_flags |= MGf_MINMATCH;
1345 mg->mg_flags &= ~MGf_MINMATCH;
1348 had_zerolen = (rx->startp[0] != -1
1349 && rx->startp[0] == rx->endp[0]);
1350 PUTBACK; /* EVAL blocks may use stack */
1351 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1356 LEAVE_SCOPE(oldsave);
1362 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1363 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1365 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1366 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1368 if (rx->startp[0] != -1) {
1369 mg->mg_len = rx->endp[0];
1370 if (rx->startp[0] == rx->endp[0])
1371 mg->mg_flags |= MGf_MINMATCH;
1373 mg->mg_flags &= ~MGf_MINMATCH;
1376 LEAVE_SCOPE(oldsave);
1380 yup: /* Confirmed by INTUIT */
1382 RX_MATCH_TAINTED_on(rx);
1383 TAINT_IF(RX_MATCH_TAINTED(rx));
1385 if (dynpm->op_pmflags & PMf_ONCE)
1386 dynpm->op_pmdynflags |= PMdf_USED;
1387 if (RX_MATCH_COPIED(rx))
1388 Safefree(rx->subbeg);
1389 RX_MATCH_COPIED_off(rx);
1390 rx->subbeg = Nullch;
1392 rx->subbeg = truebase;
1393 rx->startp[0] = s - truebase;
1394 if (RX_MATCH_UTF8(rx)) {
1395 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1396 rx->endp[0] = t - truebase;
1399 rx->endp[0] = s - truebase + rx->minlen;
1401 rx->sublen = strend - truebase;
1404 if (PL_sawampersand) {
1406 #ifdef PERL_COPY_ON_WRITE
1407 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1409 PerlIO_printf(Perl_debug_log,
1410 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1411 (int) SvTYPE(TARG), truebase, t,
1414 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1415 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1416 assert (SvPOKp(rx->saved_copy));
1421 rx->subbeg = savepvn(t, strend - t);
1422 #ifdef PERL_COPY_ON_WRITE
1423 rx->saved_copy = Nullsv;
1426 rx->sublen = strend - t;
1427 RX_MATCH_COPIED_on(rx);
1428 off = rx->startp[0] = s - t;
1429 rx->endp[0] = off + rx->minlen;
1431 else { /* startp/endp are used by @- @+. */
1432 rx->startp[0] = s - truebase;
1433 rx->endp[0] = s - truebase + rx->minlen;
1435 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1436 LEAVE_SCOPE(oldsave);
1441 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1442 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1443 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1448 LEAVE_SCOPE(oldsave);
1449 if (gimme == G_ARRAY)
1455 Perl_do_readline(pTHX)
1457 dSP; dTARGETSTACKED;
1462 register IO *io = GvIO(PL_last_in_gv);
1463 register I32 type = PL_op->op_type;
1464 I32 gimme = GIMME_V;
1467 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1469 XPUSHs(SvTIED_obj((SV*)io, mg));
1472 call_method("READLINE", gimme);
1475 if (gimme == G_SCALAR) {
1477 SvSetSV_nosteal(TARG, result);
1486 if (IoFLAGS(io) & IOf_ARGV) {
1487 if (IoFLAGS(io) & IOf_START) {
1489 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1490 IoFLAGS(io) &= ~IOf_START;
1491 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1492 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1493 SvSETMAGIC(GvSV(PL_last_in_gv));
1498 fp = nextargv(PL_last_in_gv);
1499 if (!fp) { /* Note: fp != IoIFP(io) */
1500 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1503 else if (type == OP_GLOB)
1504 fp = Perl_start_glob(aTHX_ POPs, io);
1506 else if (type == OP_GLOB)
1508 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1509 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1513 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1514 && (!io || !(IoFLAGS(io) & IOf_START))) {
1515 if (type == OP_GLOB)
1516 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1517 "glob failed (can't start child: %s)",
1520 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1522 if (gimme == G_SCALAR) {
1523 /* undef TARG, and push that undefined value */
1524 if (type != OP_RCATLINE) {
1525 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1526 (void)SvOK_off(TARG);
1533 if (gimme == G_SCALAR) {
1537 (void)SvUPGRADE(sv, SVt_PV);
1538 tmplen = SvLEN(sv); /* remember if already alloced */
1539 if (!tmplen && !SvREADONLY(sv))
1540 Sv_Grow(sv, 80); /* try short-buffering it */
1542 if (type == OP_RCATLINE && SvOK(sv)) {
1545 (void)SvPV_force(sv, n_a);
1551 sv = sv_2mortal(NEWSV(57, 80));
1555 /* This should not be marked tainted if the fp is marked clean */
1556 #define MAYBE_TAINT_LINE(io, sv) \
1557 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1562 /* delay EOF state for a snarfed empty file */
1563 #define SNARF_EOF(gimme,rs,io,sv) \
1564 (gimme != G_SCALAR || SvCUR(sv) \
1565 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1569 if (!sv_gets(sv, fp, offset)
1570 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1572 PerlIO_clearerr(fp);
1573 if (IoFLAGS(io) & IOf_ARGV) {
1574 fp = nextargv(PL_last_in_gv);
1577 (void)do_close(PL_last_in_gv, FALSE);
1579 else if (type == OP_GLOB) {
1580 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1581 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1582 "glob failed (child exited with status %d%s)",
1583 (int)(STATUS_CURRENT >> 8),
1584 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1587 if (gimme == G_SCALAR) {
1588 if (type != OP_RCATLINE) {
1589 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1590 (void)SvOK_off(TARG);
1595 MAYBE_TAINT_LINE(io, sv);
1598 MAYBE_TAINT_LINE(io, sv);
1600 IoFLAGS(io) |= IOf_NOLINE;
1604 if (type == OP_GLOB) {
1607 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1608 tmps = SvEND(sv) - 1;
1609 if (*tmps == *SvPVX(PL_rs)) {
1614 for (tmps = SvPVX(sv); *tmps; tmps++)
1615 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1616 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1618 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1619 (void)POPs; /* Unmatched wildcard? Chuck it... */
1622 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1623 U8 *s = (U8*)SvPVX(sv) + offset;
1624 STRLEN len = SvCUR(sv) - offset;
1627 if (ckWARN(WARN_UTF8) &&
1628 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1629 /* Emulate :encoding(utf8) warning in the same case. */
1630 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1631 "utf8 \"\\x%02X\" does not map to Unicode",
1632 f < (U8*)SvEND(sv) ? *f : 0);
1634 if (gimme == G_ARRAY) {
1635 if (SvLEN(sv) - SvCUR(sv) > 20) {
1636 SvLEN_set(sv, SvCUR(sv)+1);
1637 Renew(SvPVX(sv), SvLEN(sv), char);
1639 sv = sv_2mortal(NEWSV(58, 80));
1642 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1643 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1647 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1648 Renew(SvPVX(sv), SvLEN(sv), char);
1657 register PERL_CONTEXT *cx;
1658 I32 gimme = OP_GIMME(PL_op, -1);
1661 if (cxstack_ix >= 0)
1662 gimme = cxstack[cxstack_ix].blk_gimme;
1670 PUSHBLOCK(cx, CXt_BLOCK, SP);
1682 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1683 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1685 #ifdef PERL_COPY_ON_WRITE
1686 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1688 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1692 if (SvTYPE(hv) == SVt_PVHV) {
1693 if (PL_op->op_private & OPpLVAL_INTRO) {
1696 /* does the element we're localizing already exist? */
1698 /* can we determine whether it exists? */
1700 || mg_find((SV*)hv, PERL_MAGIC_env)
1701 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1702 /* Try to preserve the existenceness of a tied hash
1703 * element by using EXISTS and DELETE if possible.
1704 * Fallback to FETCH and STORE otherwise */
1705 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1706 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1707 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1709 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1712 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1713 svp = he ? &HeVAL(he) : 0;
1719 if (!svp || *svp == &PL_sv_undef) {
1724 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1726 lv = sv_newmortal();
1727 sv_upgrade(lv, SVt_PVLV);
1729 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1730 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1731 LvTARG(lv) = SvREFCNT_inc(hv);
1736 if (PL_op->op_private & OPpLVAL_INTRO) {
1737 if (HvNAME(hv) && isGV(*svp))
1738 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1742 char *key = SvPV(keysv, keylen);
1743 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1745 save_helem(hv, keysv, svp);
1748 else if (PL_op->op_private & OPpDEREF)
1749 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1751 sv = (svp ? *svp : &PL_sv_undef);
1752 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1753 * Pushing the magical RHS on to the stack is useless, since
1754 * that magic is soon destined to be misled by the local(),
1755 * and thus the later pp_sassign() will fail to mg_get() the
1756 * old value. This should also cure problems with delayed
1757 * mg_get()s. GSAR 98-07-03 */
1758 if (!lval && SvGMAGICAL(sv))
1759 sv = sv_mortalcopy(sv);
1767 register PERL_CONTEXT *cx;
1773 if (PL_op->op_flags & OPf_SPECIAL) {
1774 cx = &cxstack[cxstack_ix];
1775 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1780 gimme = OP_GIMME(PL_op, -1);
1782 if (cxstack_ix >= 0)
1783 gimme = cxstack[cxstack_ix].blk_gimme;
1789 if (gimme == G_VOID)
1791 else if (gimme == G_SCALAR) {
1794 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1797 *MARK = sv_mortalcopy(TOPs);
1800 *MARK = &PL_sv_undef;
1804 else if (gimme == G_ARRAY) {
1805 /* in case LEAVE wipes old return values */
1806 for (mark = newsp + 1; mark <= SP; mark++) {
1807 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1808 *mark = sv_mortalcopy(*mark);
1809 TAINT_NOT; /* Each item is independent */
1813 PL_curpm = newpm; /* Don't pop $1 et al till now */
1823 register PERL_CONTEXT *cx;
1829 cx = &cxstack[cxstack_ix];
1830 if (CxTYPE(cx) != CXt_LOOP)
1831 DIE(aTHX_ "panic: pp_iter");
1833 itersvp = CxITERVAR(cx);
1834 av = cx->blk_loop.iterary;
1835 if (SvTYPE(av) != SVt_PVAV) {
1836 /* iterate ($min .. $max) */
1837 if (cx->blk_loop.iterlval) {
1838 /* string increment */
1839 register SV* cur = cx->blk_loop.iterlval;
1841 char *max = SvPV((SV*)av, maxlen);
1842 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1843 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1844 /* safe to reuse old SV */
1845 sv_setsv(*itersvp, cur);
1849 /* we need a fresh SV every time so that loop body sees a
1850 * completely new SV for closures/references to work as
1852 SvREFCNT_dec(*itersvp);
1853 *itersvp = newSVsv(cur);
1855 if (strEQ(SvPVX(cur), max))
1856 sv_setiv(cur, 0); /* terminate next time */
1863 /* integer increment */
1864 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1867 /* don't risk potential race */
1868 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1869 /* safe to reuse old SV */
1870 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1874 /* we need a fresh SV every time so that loop body sees a
1875 * completely new SV for closures/references to work as they
1877 SvREFCNT_dec(*itersvp);
1878 *itersvp = newSViv(cx->blk_loop.iterix++);
1884 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1887 SvREFCNT_dec(*itersvp);
1889 if (SvMAGICAL(av) || AvREIFY(av)) {
1890 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1897 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1899 if (sv && SvREFCNT(sv) == 0) {
1901 Perl_croak(aTHX_ "Use of freed value in iteration");
1908 if (av != PL_curstack && sv == &PL_sv_undef) {
1909 SV *lv = cx->blk_loop.iterlval;
1910 if (lv && SvREFCNT(lv) > 1) {
1915 SvREFCNT_dec(LvTARG(lv));
1917 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1918 sv_upgrade(lv, SVt_PVLV);
1920 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1922 LvTARG(lv) = SvREFCNT_inc(av);
1923 LvTARGOFF(lv) = cx->blk_loop.iterix;
1924 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1928 *itersvp = SvREFCNT_inc(sv);
1935 register PMOP *pm = cPMOP;
1951 register REGEXP *rx = PM_GETRE(pm);
1953 int force_on_match = 0;
1954 I32 oldsave = PL_savestack_ix;
1956 bool doutf8 = FALSE;
1957 #ifdef PERL_COPY_ON_WRITE
1962 /* known replacement string? */
1963 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1964 if (PL_op->op_flags & OPf_STACKED)
1971 #ifdef PERL_COPY_ON_WRITE
1972 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1973 because they make integers such as 256 "false". */
1974 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1977 sv_force_normal_flags(TARG,0);
1980 #ifdef PERL_COPY_ON_WRITE
1984 || (SvTYPE(TARG) > SVt_PVLV
1985 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1986 DIE(aTHX_ PL_no_modify);
1989 s = SvPV(TARG, len);
1990 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1992 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1993 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1998 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2002 DIE(aTHX_ "panic: pp_subst");
2005 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2006 maxiters = 2 * slen + 10; /* We can match twice at each
2007 position, once with zero-length,
2008 second time with non-zero. */
2010 if (!rx->prelen && PL_curpm) {
2014 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2015 ? REXEC_COPY_STR : 0;
2017 r_flags |= REXEC_SCREAM;
2018 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
2019 SAVEINT(PL_multiline);
2020 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2023 if (rx->reganch & RE_USE_INTUIT) {
2025 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2029 /* How to do it in subst? */
2030 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2032 && ((rx->reganch & ROPT_NOSCAN)
2033 || !((rx->reganch & RE_INTUIT_TAIL)
2034 && (r_flags & REXEC_SCREAM))))
2039 /* only replace once? */
2040 once = !(rpm->op_pmflags & PMf_GLOBAL);
2042 /* known replacement string? */
2044 /* replacement needing upgrading? */
2045 if (DO_UTF8(TARG) && !doutf8) {
2046 nsv = sv_newmortal();
2049 sv_recode_to_utf8(nsv, PL_encoding);
2051 sv_utf8_upgrade(nsv);
2052 c = SvPV(nsv, clen);
2056 c = SvPV(dstr, clen);
2057 doutf8 = DO_UTF8(dstr);
2065 /* can do inplace substitution? */
2067 #ifdef PERL_COPY_ON_WRITE
2070 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2071 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2072 && (!doutf8 || SvUTF8(TARG))) {
2073 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2074 r_flags | REXEC_CHECKED))
2078 LEAVE_SCOPE(oldsave);
2081 #ifdef PERL_COPY_ON_WRITE
2082 if (SvIsCOW(TARG)) {
2083 assert (!force_on_match);
2087 if (force_on_match) {
2089 s = SvPV_force(TARG, len);
2094 SvSCREAM_off(TARG); /* disable possible screamer */
2096 rxtainted |= RX_MATCH_TAINTED(rx);
2097 m = orig + rx->startp[0];
2098 d = orig + rx->endp[0];
2100 if (m - s > strend - d) { /* faster to shorten from end */
2102 Copy(c, m, clen, char);
2107 Move(d, m, i, char);
2111 SvCUR_set(TARG, m - s);
2114 else if ((i = m - s)) { /* faster from front */
2122 Copy(c, m, clen, char);
2127 Copy(c, d, clen, char);
2132 TAINT_IF(rxtainted & 1);
2138 if (iters++ > maxiters)
2139 DIE(aTHX_ "Substitution loop");
2140 rxtainted |= RX_MATCH_TAINTED(rx);
2141 m = rx->startp[0] + orig;
2145 Move(s, d, i, char);
2149 Copy(c, d, clen, char);
2152 s = rx->endp[0] + orig;
2153 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2155 /* don't match same null twice */
2156 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2159 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2160 Move(s, d, i+1, char); /* include the NUL */
2162 TAINT_IF(rxtainted & 1);
2164 PUSHs(sv_2mortal(newSViv((I32)iters)));
2166 (void)SvPOK_only_UTF8(TARG);
2167 TAINT_IF(rxtainted);
2168 if (SvSMAGICAL(TARG)) {
2176 LEAVE_SCOPE(oldsave);
2180 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2181 r_flags | REXEC_CHECKED))
2183 if (force_on_match) {
2185 s = SvPV_force(TARG, len);
2188 #ifdef PERL_COPY_ON_WRITE
2191 rxtainted |= RX_MATCH_TAINTED(rx);
2192 dstr = NEWSV(25, len);
2193 sv_setpvn(dstr, m, s-m);
2198 register PERL_CONTEXT *cx;
2202 RETURNOP(cPMOP->op_pmreplroot);
2204 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2206 if (iters++ > maxiters)
2207 DIE(aTHX_ "Substitution loop");
2208 rxtainted |= RX_MATCH_TAINTED(rx);
2209 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2214 strend = s + (strend - m);
2216 m = rx->startp[0] + orig;
2217 if (doutf8 && !SvUTF8(dstr))
2218 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2220 sv_catpvn(dstr, s, m-s);
2221 s = rx->endp[0] + orig;
2223 sv_catpvn(dstr, c, clen);
2226 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2227 TARG, NULL, r_flags));
2228 if (doutf8 && !DO_UTF8(TARG))
2229 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2231 sv_catpvn(dstr, s, strend - s);
2233 #ifdef PERL_COPY_ON_WRITE
2234 /* The match may make the string COW. If so, brilliant, because that's
2235 just saved us one malloc, copy and free - the regexp has donated
2236 the old buffer, and we malloc an entirely new one, rather than the
2237 regexp malloc()ing a buffer and copying our original, only for
2238 us to throw it away here during the substitution. */
2239 if (SvIsCOW(TARG)) {
2240 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2244 (void)SvOOK_off(TARG);
2246 Safefree(SvPVX(TARG));
2248 SvPVX(TARG) = SvPVX(dstr);
2249 SvCUR_set(TARG, SvCUR(dstr));
2250 SvLEN_set(TARG, SvLEN(dstr));
2251 doutf8 |= DO_UTF8(dstr);
2255 TAINT_IF(rxtainted & 1);
2257 PUSHs(sv_2mortal(newSViv((I32)iters)));
2259 (void)SvPOK_only(TARG);
2262 TAINT_IF(rxtainted);
2265 LEAVE_SCOPE(oldsave);
2274 LEAVE_SCOPE(oldsave);
2283 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2284 ++*PL_markstack_ptr;
2285 LEAVE; /* exit inner scope */
2288 if (PL_stack_base + *PL_markstack_ptr > SP) {
2290 I32 gimme = GIMME_V;
2292 LEAVE; /* exit outer scope */
2293 (void)POPMARK; /* pop src */
2294 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2295 (void)POPMARK; /* pop dst */
2296 SP = PL_stack_base + POPMARK; /* pop original mark */
2297 if (gimme == G_SCALAR) {
2301 else if (gimme == G_ARRAY)
2308 ENTER; /* enter inner scope */
2311 src = PL_stack_base[*PL_markstack_ptr];
2315 RETURNOP(cLOGOP->op_other);
2326 register PERL_CONTEXT *cx;
2330 cxstack_ix++; /* temporarily protect top context */
2333 if (gimme == G_SCALAR) {
2336 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2338 *MARK = SvREFCNT_inc(TOPs);
2343 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2345 *MARK = sv_mortalcopy(sv);
2350 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2354 *MARK = &PL_sv_undef;
2358 else if (gimme == G_ARRAY) {
2359 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2360 if (!SvTEMP(*MARK)) {
2361 *MARK = sv_mortalcopy(*MARK);
2362 TAINT_NOT; /* Each item is independent */
2370 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2371 PL_curpm = newpm; /* ... and pop $1 et al */
2374 return pop_return();
2377 /* This duplicates the above code because the above code must not
2378 * get any slower by more conditions */
2386 register PERL_CONTEXT *cx;
2390 cxstack_ix++; /* temporarily protect top context */
2394 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2395 /* We are an argument to a function or grep().
2396 * This kind of lvalueness was legal before lvalue
2397 * subroutines too, so be backward compatible:
2398 * cannot report errors. */
2400 /* Scalar context *is* possible, on the LHS of -> only,
2401 * as in f()->meth(). But this is not an lvalue. */
2402 if (gimme == G_SCALAR)
2404 if (gimme == G_ARRAY) {
2405 if (!CvLVALUE(cx->blk_sub.cv))
2406 goto temporise_array;
2407 EXTEND_MORTAL(SP - newsp);
2408 for (mark = newsp + 1; mark <= SP; mark++) {
2411 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2412 *mark = sv_mortalcopy(*mark);
2414 /* Can be a localized value subject to deletion. */
2415 PL_tmps_stack[++PL_tmps_ix] = *mark;
2416 (void)SvREFCNT_inc(*mark);
2421 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2422 /* Here we go for robustness, not for speed, so we change all
2423 * the refcounts so the caller gets a live guy. Cannot set
2424 * TEMP, so sv_2mortal is out of question. */
2425 if (!CvLVALUE(cx->blk_sub.cv)) {
2431 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2433 if (gimme == G_SCALAR) {
2437 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2443 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2444 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2445 : "a readonly value" : "a temporary");
2447 else { /* Can be a localized value
2448 * subject to deletion. */
2449 PL_tmps_stack[++PL_tmps_ix] = *mark;
2450 (void)SvREFCNT_inc(*mark);
2453 else { /* Should not happen? */
2459 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2460 (MARK > SP ? "Empty array" : "Array"));
2464 else if (gimme == G_ARRAY) {
2465 EXTEND_MORTAL(SP - newsp);
2466 for (mark = newsp + 1; mark <= SP; mark++) {
2467 if (*mark != &PL_sv_undef
2468 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2469 /* Might be flattened array after $#array = */
2476 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2477 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2480 /* Can be a localized value subject to deletion. */
2481 PL_tmps_stack[++PL_tmps_ix] = *mark;
2482 (void)SvREFCNT_inc(*mark);
2488 if (gimme == G_SCALAR) {
2492 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2494 *MARK = SvREFCNT_inc(TOPs);
2499 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2501 *MARK = sv_mortalcopy(sv);
2506 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2510 *MARK = &PL_sv_undef;
2514 else if (gimme == G_ARRAY) {
2516 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2517 if (!SvTEMP(*MARK)) {
2518 *MARK = sv_mortalcopy(*MARK);
2519 TAINT_NOT; /* Each item is independent */
2528 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2529 PL_curpm = newpm; /* ... and pop $1 et al */
2532 return pop_return();
2537 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2539 SV *dbsv = GvSV(PL_DBsub);
2541 if (!PERLDB_SUB_NN) {
2545 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2546 || strEQ(GvNAME(gv), "END")
2547 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2548 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2549 && (gv = (GV*)*svp) ))) {
2550 /* Use GV from the stack as a fallback. */
2551 /* GV is potentially non-unique, or contain different CV. */
2552 SV *tmp = newRV((SV*)cv);
2553 sv_setsv(dbsv, tmp);
2557 gv_efullname3(dbsv, gv, Nullch);
2561 (void)SvUPGRADE(dbsv, SVt_PVIV);
2562 (void)SvIOK_on(dbsv);
2563 SAVEIV(SvIVX(dbsv));
2564 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2568 PL_curcopdb = PL_curcop;
2569 cv = GvCV(PL_DBsub);
2579 register PERL_CONTEXT *cx;
2581 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2584 DIE(aTHX_ "Not a CODE reference");
2585 switch (SvTYPE(sv)) {
2586 /* This is overwhelming the most common case: */
2588 if (!(cv = GvCVu((GV*)sv)))
2589 cv = sv_2cv(sv, &stash, &gv, FALSE);
2601 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2603 SP = PL_stack_base + POPMARK;
2606 if (SvGMAGICAL(sv)) {
2610 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2613 sym = SvPV(sv, n_a);
2615 DIE(aTHX_ PL_no_usym, "a subroutine");
2616 if (PL_op->op_private & HINT_STRICT_REFS)
2617 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2618 cv = get_cv(sym, TRUE);
2623 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2624 tryAMAGICunDEREF(to_cv);
2627 if (SvTYPE(cv) == SVt_PVCV)
2632 DIE(aTHX_ "Not a CODE reference");
2633 /* This is the second most common case: */
2643 if (!CvROOT(cv) && !CvXSUB(cv)) {
2648 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2649 if (CvASSERTION(cv) && PL_DBassertion)
2650 sv_setiv(PL_DBassertion, 1);
2652 cv = get_db_sub(&sv, cv);
2654 DIE(aTHX_ "No DBsub routine");
2657 if (!(CvXSUB(cv))) {
2658 /* This path taken at least 75% of the time */
2660 register I32 items = SP - MARK;
2661 AV* padlist = CvPADLIST(cv);
2662 push_return(PL_op->op_next);
2663 PUSHBLOCK(cx, CXt_SUB, MARK);
2666 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2667 * that eval'' ops within this sub know the correct lexical space.
2668 * Owing the speed considerations, we choose instead to search for
2669 * the cv using find_runcv() when calling doeval().
2671 if (CvDEPTH(cv) < 2)
2672 (void)SvREFCNT_inc(cv);
2674 PERL_STACK_OVERFLOW_CHECK();
2675 pad_push(padlist, CvDEPTH(cv), 1);
2677 PAD_SET_CUR(padlist, CvDEPTH(cv));
2684 DEBUG_S(PerlIO_printf(Perl_debug_log,
2685 "%p entersub preparing @_\n", thr));
2687 av = (AV*)PAD_SVl(0);
2689 /* @_ is normally not REAL--this should only ever
2690 * happen when DB::sub() calls things that modify @_ */
2695 cx->blk_sub.savearray = GvAV(PL_defgv);
2696 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2697 CX_CURPAD_SAVE(cx->blk_sub);
2698 cx->blk_sub.argarray = av;
2701 if (items > AvMAX(av) + 1) {
2703 if (AvARRAY(av) != ary) {
2704 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2705 SvPVX(av) = (char*)ary;
2707 if (items > AvMAX(av) + 1) {
2708 AvMAX(av) = items - 1;
2709 Renew(ary,items,SV*);
2711 SvPVX(av) = (char*)ary;
2714 Copy(MARK,AvARRAY(av),items,SV*);
2715 AvFILLp(av) = items - 1;
2723 /* warning must come *after* we fully set up the context
2724 * stuff so that __WARN__ handlers can safely dounwind()
2727 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2728 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2729 sub_crush_depth(cv);
2731 DEBUG_S(PerlIO_printf(Perl_debug_log,
2732 "%p entersub returning %p\n", thr, CvSTART(cv)));
2734 RETURNOP(CvSTART(cv));
2737 #ifdef PERL_XSUB_OLDSTYLE
2738 if (CvOLDSTYLE(cv)) {
2739 I32 (*fp3)(int,int,int);
2741 register I32 items = SP - MARK;
2742 /* We dont worry to copy from @_. */
2747 PL_stack_sp = mark + 1;
2748 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2749 items = (*fp3)(CvXSUBANY(cv).any_i32,
2750 MARK - PL_stack_base + 1,
2752 PL_stack_sp = PL_stack_base + items;
2755 #endif /* PERL_XSUB_OLDSTYLE */
2757 I32 markix = TOPMARK;
2762 /* Need to copy @_ to stack. Alternative may be to
2763 * switch stack to @_, and copy return values
2764 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2767 av = GvAV(PL_defgv);
2768 items = AvFILLp(av) + 1; /* @_ is not tieable */
2771 /* Mark is at the end of the stack. */
2773 Copy(AvARRAY(av), SP + 1, items, SV*);
2778 /* We assume first XSUB in &DB::sub is the called one. */
2780 SAVEVPTR(PL_curcop);
2781 PL_curcop = PL_curcopdb;
2784 /* Do we need to open block here? XXXX */
2785 (void)(*CvXSUB(cv))(aTHX_ cv);
2787 /* Enforce some sanity in scalar context. */
2788 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2789 if (markix > PL_stack_sp - PL_stack_base)
2790 *(PL_stack_base + markix) = &PL_sv_undef;
2792 *(PL_stack_base + markix) = *PL_stack_sp;
2793 PL_stack_sp = PL_stack_base + markix;
2800 assert (0); /* Cannot get here. */
2801 /* This is deliberately moved here as spaghetti code to keep it out of the
2808 /* anonymous or undef'd function leaves us no recourse */
2809 if (CvANON(cv) || !(gv = CvGV(cv)))
2810 DIE(aTHX_ "Undefined subroutine called");
2812 /* autoloaded stub? */
2813 if (cv != GvCV(gv)) {
2816 /* should call AUTOLOAD now? */
2819 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2826 sub_name = sv_newmortal();
2827 gv_efullname3(sub_name, gv, Nullch);
2828 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2832 DIE(aTHX_ "Not a CODE reference");
2838 Perl_sub_crush_depth(pTHX_ CV *cv)
2841 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2843 SV* tmpstr = sv_newmortal();
2844 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2845 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2855 IV elem = SvIV(elemsv);
2857 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2858 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2861 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2862 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2864 elem -= PL_curcop->cop_arybase;
2865 if (SvTYPE(av) != SVt_PVAV)
2867 svp = av_fetch(av, elem, lval && !defer);
2869 if (!svp || *svp == &PL_sv_undef) {
2872 DIE(aTHX_ PL_no_aelem, elem);
2873 lv = sv_newmortal();
2874 sv_upgrade(lv, SVt_PVLV);
2876 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2877 LvTARG(lv) = SvREFCNT_inc(av);
2878 LvTARGOFF(lv) = elem;
2883 if (PL_op->op_private & OPpLVAL_INTRO)
2884 save_aelem(av, elem, svp);
2885 else if (PL_op->op_private & OPpDEREF)
2886 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2888 sv = (svp ? *svp : &PL_sv_undef);
2889 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2890 sv = sv_mortalcopy(sv);
2896 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2902 Perl_croak(aTHX_ PL_no_modify);
2903 if (SvTYPE(sv) < SVt_RV)
2904 sv_upgrade(sv, SVt_RV);
2905 else if (SvTYPE(sv) >= SVt_PV) {
2906 (void)SvOOK_off(sv);
2907 Safefree(SvPVX(sv));
2908 SvLEN(sv) = SvCUR(sv) = 0;
2912 SvRV(sv) = NEWSV(355,0);
2915 SvRV(sv) = (SV*)newAV();
2918 SvRV(sv) = (SV*)newHV();
2933 if (SvTYPE(rsv) == SVt_PVCV) {
2939 SETs(method_common(sv, Null(U32*)));
2947 U32 hash = SvUVX(sv);
2949 XPUSHs(method_common(sv, &hash));
2954 S_method_common(pTHX_ SV* meth, U32* hashp)
2963 SV *packsv = Nullsv;
2966 name = SvPV(meth, namelen);
2967 sv = *(PL_stack_base + TOPMARK + 1);
2970 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2979 /* this isn't a reference */
2982 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2984 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2986 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2993 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2994 !(ob=(SV*)GvIO(iogv)))
2996 /* this isn't the name of a filehandle either */
2998 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2999 ? !isIDFIRST_utf8((U8*)packname)
3000 : !isIDFIRST(*packname)
3003 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3004 SvOK(sv) ? "without a package or object reference"
3005 : "on an undefined value");
3007 /* assume it's a package name */
3008 stash = gv_stashpvn(packname, packlen, FALSE);
3012 SV* ref = newSViv(PTR2IV(stash));
3013 hv_store(PL_stashcache, packname, packlen, ref, 0);
3017 /* it _is_ a filehandle name -- replace with a reference */
3018 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3021 /* if we got here, ob should be a reference or a glob */
3022 if (!ob || !(SvOBJECT(ob)
3023 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3026 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3030 stash = SvSTASH(ob);
3033 /* NOTE: stash may be null, hope hv_fetch_ent and
3034 gv_fetchmethod can cope (it seems they can) */
3036 /* shortcut for simple names */
3038 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3040 gv = (GV*)HeVAL(he);
3041 if (isGV(gv) && GvCV(gv) &&
3042 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3043 return (SV*)GvCV(gv);
3047 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3050 /* This code tries to figure out just what went wrong with
3051 gv_fetchmethod. It therefore needs to duplicate a lot of
3052 the internals of that function. We can't move it inside
3053 Perl_gv_fetchmethod_autoload(), however, since that would
3054 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3061 for (p = name; *p; p++) {
3063 sep = p, leaf = p + 1;
3064 else if (*p == ':' && *(p + 1) == ':')
3065 sep = p, leaf = p + 2;
3067 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3068 /* the method name is unqualified or starts with SUPER:: */
3069 packname = sep ? CopSTASHPV(PL_curcop) :
3070 stash ? HvNAME(stash) : packname;
3073 "Can't use anonymous symbol table for method lookup");
3075 packlen = strlen(packname);
3078 /* the method name is qualified */
3080 packlen = sep - name;
3083 /* we're relying on gv_fetchmethod not autovivifying the stash */
3084 if (gv_stashpvn(packname, packlen, FALSE)) {
3086 "Can't locate object method \"%s\" via package \"%.*s\"",
3087 leaf, (int)packlen, packname);
3091 "Can't locate object method \"%s\" via package \"%.*s\""
3092 " (perhaps you forgot to load \"%.*s\"?)",
3093 leaf, (int)packlen, packname, (int)packlen, packname);
3096 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;