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)
1198 else if (PL_op->op_private & OPpTARGET_MY)
1205 PUTBACK; /* EVAL blocks need stack_sp. */
1206 s = SvPV(TARG, len);
1209 DIE(aTHX_ "panic: pp_match");
1210 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1211 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1214 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1216 /* PMdf_USED is set after a ?? matches once */
1217 if (pm->op_pmdynflags & PMdf_USED) {
1219 if (gimme == G_ARRAY)
1224 /* empty pattern special-cased to use last successful pattern if possible */
1225 if (!rx->prelen && PL_curpm) {
1230 if (rx->minlen > (I32)len)
1235 /* XXXX What part of this is needed with true \G-support? */
1236 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1238 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1239 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1240 if (mg && mg->mg_len >= 0) {
1241 if (!(rx->reganch & ROPT_GPOS_SEEN))
1242 rx->endp[0] = rx->startp[0] = mg->mg_len;
1243 else if (rx->reganch & ROPT_ANCH_GPOS) {
1244 r_flags |= REXEC_IGNOREPOS;
1245 rx->endp[0] = rx->startp[0] = mg->mg_len;
1247 minmatch = (mg->mg_flags & MGf_MINMATCH);
1248 update_minmatch = 0;
1252 if ((!global && rx->nparens)
1253 || SvTEMP(TARG) || PL_sawampersand)
1254 r_flags |= REXEC_COPY_STR;
1256 r_flags |= REXEC_SCREAM;
1258 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1259 SAVEINT(PL_multiline);
1260 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1264 if (global && rx->startp[0] != -1) {
1265 t = s = rx->endp[0] + truebase;
1266 if ((s + rx->minlen) > strend)
1268 if (update_minmatch++)
1269 minmatch = had_zerolen;
1271 if (rx->reganch & RE_USE_INTUIT &&
1272 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1273 PL_bostr = truebase;
1274 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1278 if ( (rx->reganch & ROPT_CHECK_ALL)
1280 && ((rx->reganch & ROPT_NOSCAN)
1281 || !((rx->reganch & RE_INTUIT_TAIL)
1282 && (r_flags & REXEC_SCREAM)))
1283 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1286 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1289 if (dynpm->op_pmflags & PMf_ONCE)
1290 dynpm->op_pmdynflags |= PMdf_USED;
1299 RX_MATCH_TAINTED_on(rx);
1300 TAINT_IF(RX_MATCH_TAINTED(rx));
1301 if (gimme == G_ARRAY) {
1302 I32 nparens, i, len;
1304 nparens = rx->nparens;
1305 if (global && !nparens)
1309 SPAGAIN; /* EVAL blocks could move the stack. */
1310 EXTEND(SP, nparens + i);
1311 EXTEND_MORTAL(nparens + i);
1312 for (i = !i; i <= nparens; i++) {
1313 PUSHs(sv_newmortal());
1315 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1316 len = rx->endp[i] - rx->startp[i];
1317 s = rx->startp[i] + truebase;
1318 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1319 len < 0 || len > strend - s)
1320 DIE(aTHX_ "panic: pp_match start/end pointers");
1321 sv_setpvn(*SP, s, len);
1322 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1327 if (dynpm->op_pmflags & PMf_CONTINUE) {
1329 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1330 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1332 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1333 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1335 if (rx->startp[0] != -1) {
1336 mg->mg_len = rx->endp[0];
1337 if (rx->startp[0] == rx->endp[0])
1338 mg->mg_flags |= MGf_MINMATCH;
1340 mg->mg_flags &= ~MGf_MINMATCH;
1343 had_zerolen = (rx->startp[0] != -1
1344 && rx->startp[0] == rx->endp[0]);
1345 PUTBACK; /* EVAL blocks may use stack */
1346 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1351 LEAVE_SCOPE(oldsave);
1357 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1358 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1360 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1361 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1363 if (rx->startp[0] != -1) {
1364 mg->mg_len = rx->endp[0];
1365 if (rx->startp[0] == rx->endp[0])
1366 mg->mg_flags |= MGf_MINMATCH;
1368 mg->mg_flags &= ~MGf_MINMATCH;
1371 LEAVE_SCOPE(oldsave);
1375 yup: /* Confirmed by INTUIT */
1377 RX_MATCH_TAINTED_on(rx);
1378 TAINT_IF(RX_MATCH_TAINTED(rx));
1380 if (dynpm->op_pmflags & PMf_ONCE)
1381 dynpm->op_pmdynflags |= PMdf_USED;
1382 if (RX_MATCH_COPIED(rx))
1383 Safefree(rx->subbeg);
1384 RX_MATCH_COPIED_off(rx);
1385 rx->subbeg = Nullch;
1387 rx->subbeg = truebase;
1388 rx->startp[0] = s - truebase;
1389 if (RX_MATCH_UTF8(rx)) {
1390 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1391 rx->endp[0] = t - truebase;
1394 rx->endp[0] = s - truebase + rx->minlen;
1396 rx->sublen = strend - truebase;
1399 if (PL_sawampersand) {
1401 #ifdef PERL_COPY_ON_WRITE
1402 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1404 PerlIO_printf(Perl_debug_log,
1405 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1406 (int) SvTYPE(TARG), truebase, t,
1409 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1410 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1411 assert (SvPOKp(rx->saved_copy));
1416 rx->subbeg = savepvn(t, strend - t);
1417 #ifdef PERL_COPY_ON_WRITE
1418 rx->saved_copy = Nullsv;
1421 rx->sublen = strend - t;
1422 RX_MATCH_COPIED_on(rx);
1423 off = rx->startp[0] = s - t;
1424 rx->endp[0] = off + rx->minlen;
1426 else { /* startp/endp are used by @- @+. */
1427 rx->startp[0] = s - truebase;
1428 rx->endp[0] = s - truebase + rx->minlen;
1430 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1431 LEAVE_SCOPE(oldsave);
1436 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1437 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1438 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1443 LEAVE_SCOPE(oldsave);
1444 if (gimme == G_ARRAY)
1450 Perl_do_readline(pTHX)
1452 dSP; dTARGETSTACKED;
1457 register IO *io = GvIO(PL_last_in_gv);
1458 register I32 type = PL_op->op_type;
1459 I32 gimme = GIMME_V;
1462 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1464 XPUSHs(SvTIED_obj((SV*)io, mg));
1467 call_method("READLINE", gimme);
1470 if (gimme == G_SCALAR) {
1472 SvSetSV_nosteal(TARG, result);
1481 if (IoFLAGS(io) & IOf_ARGV) {
1482 if (IoFLAGS(io) & IOf_START) {
1484 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1485 IoFLAGS(io) &= ~IOf_START;
1486 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1487 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1488 SvSETMAGIC(GvSV(PL_last_in_gv));
1493 fp = nextargv(PL_last_in_gv);
1494 if (!fp) { /* Note: fp != IoIFP(io) */
1495 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1498 else if (type == OP_GLOB)
1499 fp = Perl_start_glob(aTHX_ POPs, io);
1501 else if (type == OP_GLOB)
1503 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1504 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1508 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1509 && (!io || !(IoFLAGS(io) & IOf_START))) {
1510 if (type == OP_GLOB)
1511 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1512 "glob failed (can't start child: %s)",
1515 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1517 if (gimme == G_SCALAR) {
1518 /* undef TARG, and push that undefined value */
1519 if (type != OP_RCATLINE) {
1520 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1521 (void)SvOK_off(TARG);
1528 if (gimme == G_SCALAR) {
1532 (void)SvUPGRADE(sv, SVt_PV);
1533 tmplen = SvLEN(sv); /* remember if already alloced */
1534 if (!tmplen && !SvREADONLY(sv))
1535 Sv_Grow(sv, 80); /* try short-buffering it */
1537 if (type == OP_RCATLINE && SvOK(sv)) {
1540 (void)SvPV_force(sv, n_a);
1546 sv = sv_2mortal(NEWSV(57, 80));
1550 /* This should not be marked tainted if the fp is marked clean */
1551 #define MAYBE_TAINT_LINE(io, sv) \
1552 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1557 /* delay EOF state for a snarfed empty file */
1558 #define SNARF_EOF(gimme,rs,io,sv) \
1559 (gimme != G_SCALAR || SvCUR(sv) \
1560 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1564 if (!sv_gets(sv, fp, offset)
1566 || SNARF_EOF(gimme, PL_rs, io, sv)
1567 || PerlIO_error(fp)))
1569 PerlIO_clearerr(fp);
1570 if (IoFLAGS(io) & IOf_ARGV) {
1571 fp = nextargv(PL_last_in_gv);
1574 (void)do_close(PL_last_in_gv, FALSE);
1576 else if (type == OP_GLOB) {
1577 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1578 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1579 "glob failed (child exited with status %d%s)",
1580 (int)(STATUS_CURRENT >> 8),
1581 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1584 if (gimme == G_SCALAR) {
1585 if (type != OP_RCATLINE) {
1586 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1587 (void)SvOK_off(TARG);
1592 MAYBE_TAINT_LINE(io, sv);
1595 MAYBE_TAINT_LINE(io, sv);
1597 IoFLAGS(io) |= IOf_NOLINE;
1601 if (type == OP_GLOB) {
1604 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1605 tmps = SvEND(sv) - 1;
1606 if (*tmps == *SvPVX(PL_rs)) {
1611 for (tmps = SvPVX(sv); *tmps; tmps++)
1612 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1613 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1615 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1616 (void)POPs; /* Unmatched wildcard? Chuck it... */
1619 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1620 U8 *s = (U8*)SvPVX(sv) + offset;
1621 STRLEN len = SvCUR(sv) - offset;
1624 if (ckWARN(WARN_UTF8) &&
1625 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1626 /* Emulate :encoding(utf8) warning in the same case. */
1627 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1628 "utf8 \"\\x%02X\" does not map to Unicode",
1629 f < (U8*)SvEND(sv) ? *f : 0);
1631 if (gimme == G_ARRAY) {
1632 if (SvLEN(sv) - SvCUR(sv) > 20) {
1633 SvLEN_set(sv, SvCUR(sv)+1);
1634 Renew(SvPVX(sv), SvLEN(sv), char);
1636 sv = sv_2mortal(NEWSV(58, 80));
1639 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1640 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1644 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1645 Renew(SvPVX(sv), SvLEN(sv), char);
1654 register PERL_CONTEXT *cx;
1655 I32 gimme = OP_GIMME(PL_op, -1);
1658 if (cxstack_ix >= 0)
1659 gimme = cxstack[cxstack_ix].blk_gimme;
1667 PUSHBLOCK(cx, CXt_BLOCK, SP);
1679 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1680 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1682 #ifdef PERL_COPY_ON_WRITE
1683 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1685 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1689 if (SvTYPE(hv) == SVt_PVHV) {
1690 if (PL_op->op_private & OPpLVAL_INTRO) {
1693 /* does the element we're localizing already exist? */
1695 /* can we determine whether it exists? */
1697 || mg_find((SV*)hv, PERL_MAGIC_env)
1698 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1699 /* Try to preserve the existenceness of a tied hash
1700 * element by using EXISTS and DELETE if possible.
1701 * Fallback to FETCH and STORE otherwise */
1702 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1703 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1704 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1706 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1709 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1710 svp = he ? &HeVAL(he) : 0;
1716 if (!svp || *svp == &PL_sv_undef) {
1721 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1723 lv = sv_newmortal();
1724 sv_upgrade(lv, SVt_PVLV);
1726 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1727 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1728 LvTARG(lv) = SvREFCNT_inc(hv);
1733 if (PL_op->op_private & OPpLVAL_INTRO) {
1734 if (HvNAME(hv) && isGV(*svp))
1735 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1739 char *key = SvPV(keysv, keylen);
1740 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1742 save_helem(hv, keysv, svp);
1745 else if (PL_op->op_private & OPpDEREF)
1746 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1748 sv = (svp ? *svp : &PL_sv_undef);
1749 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1750 * Pushing the magical RHS on to the stack is useless, since
1751 * that magic is soon destined to be misled by the local(),
1752 * and thus the later pp_sassign() will fail to mg_get() the
1753 * old value. This should also cure problems with delayed
1754 * mg_get()s. GSAR 98-07-03 */
1755 if (!lval && SvGMAGICAL(sv))
1756 sv = sv_mortalcopy(sv);
1764 register PERL_CONTEXT *cx;
1770 if (PL_op->op_flags & OPf_SPECIAL) {
1771 cx = &cxstack[cxstack_ix];
1772 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1777 gimme = OP_GIMME(PL_op, -1);
1779 if (cxstack_ix >= 0)
1780 gimme = cxstack[cxstack_ix].blk_gimme;
1786 if (gimme == G_VOID)
1788 else if (gimme == G_SCALAR) {
1791 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1794 *MARK = sv_mortalcopy(TOPs);
1797 *MARK = &PL_sv_undef;
1801 else if (gimme == G_ARRAY) {
1802 /* in case LEAVE wipes old return values */
1803 for (mark = newsp + 1; mark <= SP; mark++) {
1804 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1805 *mark = sv_mortalcopy(*mark);
1806 TAINT_NOT; /* Each item is independent */
1810 PL_curpm = newpm; /* Don't pop $1 et al till now */
1820 register PERL_CONTEXT *cx;
1826 cx = &cxstack[cxstack_ix];
1827 if (CxTYPE(cx) != CXt_LOOP)
1828 DIE(aTHX_ "panic: pp_iter");
1830 itersvp = CxITERVAR(cx);
1831 av = cx->blk_loop.iterary;
1832 if (SvTYPE(av) != SVt_PVAV) {
1833 /* iterate ($min .. $max) */
1834 if (cx->blk_loop.iterlval) {
1835 /* string increment */
1836 register SV* cur = cx->blk_loop.iterlval;
1838 char *max = SvPV((SV*)av, maxlen);
1839 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1840 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1841 /* safe to reuse old SV */
1842 sv_setsv(*itersvp, cur);
1846 /* we need a fresh SV every time so that loop body sees a
1847 * completely new SV for closures/references to work as
1849 SvREFCNT_dec(*itersvp);
1850 *itersvp = newSVsv(cur);
1852 if (strEQ(SvPVX(cur), max))
1853 sv_setiv(cur, 0); /* terminate next time */
1860 /* integer increment */
1861 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1864 /* don't risk potential race */
1865 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1866 /* safe to reuse old SV */
1867 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1871 /* we need a fresh SV every time so that loop body sees a
1872 * completely new SV for closures/references to work as they
1874 SvREFCNT_dec(*itersvp);
1875 *itersvp = newSViv(cx->blk_loop.iterix++);
1881 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1884 SvREFCNT_dec(*itersvp);
1886 if (SvMAGICAL(av) || AvREIFY(av)) {
1887 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1894 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1896 if (sv && SvREFCNT(sv) == 0) {
1898 Perl_croak(aTHX_ "Use of freed value in iteration");
1905 if (av != PL_curstack && sv == &PL_sv_undef) {
1906 SV *lv = cx->blk_loop.iterlval;
1907 if (lv && SvREFCNT(lv) > 1) {
1912 SvREFCNT_dec(LvTARG(lv));
1914 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1915 sv_upgrade(lv, SVt_PVLV);
1917 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1919 LvTARG(lv) = SvREFCNT_inc(av);
1920 LvTARGOFF(lv) = cx->blk_loop.iterix;
1921 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1925 *itersvp = SvREFCNT_inc(sv);
1932 register PMOP *pm = cPMOP;
1948 register REGEXP *rx = PM_GETRE(pm);
1950 int force_on_match = 0;
1951 I32 oldsave = PL_savestack_ix;
1953 bool doutf8 = FALSE;
1954 #ifdef PERL_COPY_ON_WRITE
1959 /* known replacement string? */
1960 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1961 if (PL_op->op_flags & OPf_STACKED)
1963 else if (PL_op->op_private & OPpTARGET_MY)
1970 #ifdef PERL_COPY_ON_WRITE
1971 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1972 because they make integers such as 256 "false". */
1973 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1976 sv_force_normal_flags(TARG,0);
1979 #ifdef PERL_COPY_ON_WRITE
1983 || (SvTYPE(TARG) > SVt_PVLV
1984 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1985 DIE(aTHX_ PL_no_modify);
1988 s = SvPV(TARG, len);
1989 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1991 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1992 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1997 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2001 DIE(aTHX_ "panic: pp_subst");
2004 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2005 maxiters = 2 * slen + 10; /* We can match twice at each
2006 position, once with zero-length,
2007 second time with non-zero. */
2009 if (!rx->prelen && PL_curpm) {
2013 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2014 ? REXEC_COPY_STR : 0;
2016 r_flags |= REXEC_SCREAM;
2017 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
2018 SAVEINT(PL_multiline);
2019 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2022 if (rx->reganch & RE_USE_INTUIT) {
2024 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2028 /* How to do it in subst? */
2029 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2031 && ((rx->reganch & ROPT_NOSCAN)
2032 || !((rx->reganch & RE_INTUIT_TAIL)
2033 && (r_flags & REXEC_SCREAM))))
2038 /* only replace once? */
2039 once = !(rpm->op_pmflags & PMf_GLOBAL);
2041 /* known replacement string? */
2043 /* replacement needing upgrading? */
2044 if (DO_UTF8(TARG) && !doutf8) {
2045 nsv = sv_newmortal();
2048 sv_recode_to_utf8(nsv, PL_encoding);
2050 sv_utf8_upgrade(nsv);
2051 c = SvPV(nsv, clen);
2055 c = SvPV(dstr, clen);
2056 doutf8 = DO_UTF8(dstr);
2064 /* can do inplace substitution? */
2066 #ifdef PERL_COPY_ON_WRITE
2069 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2070 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2071 && (!doutf8 || SvUTF8(TARG))) {
2072 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2073 r_flags | REXEC_CHECKED))
2077 LEAVE_SCOPE(oldsave);
2080 #ifdef PERL_COPY_ON_WRITE
2081 if (SvIsCOW(TARG)) {
2082 assert (!force_on_match);
2086 if (force_on_match) {
2088 s = SvPV_force(TARG, len);
2093 SvSCREAM_off(TARG); /* disable possible screamer */
2095 rxtainted |= RX_MATCH_TAINTED(rx);
2096 m = orig + rx->startp[0];
2097 d = orig + rx->endp[0];
2099 if (m - s > strend - d) { /* faster to shorten from end */
2101 Copy(c, m, clen, char);
2106 Move(d, m, i, char);
2110 SvCUR_set(TARG, m - s);
2113 else if ((i = m - s)) { /* faster from front */
2121 Copy(c, m, clen, char);
2126 Copy(c, d, clen, char);
2131 TAINT_IF(rxtainted & 1);
2137 if (iters++ > maxiters)
2138 DIE(aTHX_ "Substitution loop");
2139 rxtainted |= RX_MATCH_TAINTED(rx);
2140 m = rx->startp[0] + orig;
2144 Move(s, d, i, char);
2148 Copy(c, d, clen, char);
2151 s = rx->endp[0] + orig;
2152 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2154 /* don't match same null twice */
2155 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2158 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2159 Move(s, d, i+1, char); /* include the NUL */
2161 TAINT_IF(rxtainted & 1);
2163 PUSHs(sv_2mortal(newSViv((I32)iters)));
2165 (void)SvPOK_only_UTF8(TARG);
2166 TAINT_IF(rxtainted);
2167 if (SvSMAGICAL(TARG)) {
2175 LEAVE_SCOPE(oldsave);
2179 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2180 r_flags | REXEC_CHECKED))
2182 if (force_on_match) {
2184 s = SvPV_force(TARG, len);
2187 #ifdef PERL_COPY_ON_WRITE
2190 rxtainted |= RX_MATCH_TAINTED(rx);
2191 dstr = NEWSV(25, len);
2192 sv_setpvn(dstr, m, s-m);
2197 register PERL_CONTEXT *cx;
2201 RETURNOP(cPMOP->op_pmreplroot);
2203 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2205 if (iters++ > maxiters)
2206 DIE(aTHX_ "Substitution loop");
2207 rxtainted |= RX_MATCH_TAINTED(rx);
2208 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2213 strend = s + (strend - m);
2215 m = rx->startp[0] + orig;
2216 if (doutf8 && !SvUTF8(dstr))
2217 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2219 sv_catpvn(dstr, s, m-s);
2220 s = rx->endp[0] + orig;
2222 sv_catpvn(dstr, c, clen);
2225 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2226 TARG, NULL, r_flags));
2227 if (doutf8 && !DO_UTF8(TARG))
2228 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2230 sv_catpvn(dstr, s, strend - s);
2232 #ifdef PERL_COPY_ON_WRITE
2233 /* The match may make the string COW. If so, brilliant, because that's
2234 just saved us one malloc, copy and free - the regexp has donated
2235 the old buffer, and we malloc an entirely new one, rather than the
2236 regexp malloc()ing a buffer and copying our original, only for
2237 us to throw it away here during the substitution. */
2238 if (SvIsCOW(TARG)) {
2239 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2243 (void)SvOOK_off(TARG);
2245 Safefree(SvPVX(TARG));
2247 SvPVX(TARG) = SvPVX(dstr);
2248 SvCUR_set(TARG, SvCUR(dstr));
2249 SvLEN_set(TARG, SvLEN(dstr));
2250 doutf8 |= DO_UTF8(dstr);
2254 TAINT_IF(rxtainted & 1);
2256 PUSHs(sv_2mortal(newSViv((I32)iters)));
2258 (void)SvPOK_only(TARG);
2261 TAINT_IF(rxtainted);
2264 LEAVE_SCOPE(oldsave);
2273 LEAVE_SCOPE(oldsave);
2282 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2283 ++*PL_markstack_ptr;
2284 LEAVE; /* exit inner scope */
2287 if (PL_stack_base + *PL_markstack_ptr > SP) {
2289 I32 gimme = GIMME_V;
2291 LEAVE; /* exit outer scope */
2292 (void)POPMARK; /* pop src */
2293 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2294 (void)POPMARK; /* pop dst */
2295 SP = PL_stack_base + POPMARK; /* pop original mark */
2296 if (gimme == G_SCALAR) {
2297 if (PL_op->op_private & OPpGREP_LEX) {
2298 SV* sv = sv_newmortal();
2299 sv_setiv(sv, items);
2307 else if (gimme == G_ARRAY)
2314 ENTER; /* enter inner scope */
2317 src = PL_stack_base[*PL_markstack_ptr];
2319 if (PL_op->op_private & OPpGREP_LEX)
2320 PAD_SVl(PL_op->op_targ) = src;
2324 RETURNOP(cLOGOP->op_other);
2335 register PERL_CONTEXT *cx;
2339 cxstack_ix++; /* temporarily protect top context */
2342 if (gimme == G_SCALAR) {
2345 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2347 *MARK = SvREFCNT_inc(TOPs);
2352 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2354 *MARK = sv_mortalcopy(sv);
2359 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2363 *MARK = &PL_sv_undef;
2367 else if (gimme == G_ARRAY) {
2368 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2369 if (!SvTEMP(*MARK)) {
2370 *MARK = sv_mortalcopy(*MARK);
2371 TAINT_NOT; /* Each item is independent */
2379 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2380 PL_curpm = newpm; /* ... and pop $1 et al */
2383 return pop_return();
2386 /* This duplicates the above code because the above code must not
2387 * get any slower by more conditions */
2395 register PERL_CONTEXT *cx;
2399 cxstack_ix++; /* temporarily protect top context */
2403 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2404 /* We are an argument to a function or grep().
2405 * This kind of lvalueness was legal before lvalue
2406 * subroutines too, so be backward compatible:
2407 * cannot report errors. */
2409 /* Scalar context *is* possible, on the LHS of -> only,
2410 * as in f()->meth(). But this is not an lvalue. */
2411 if (gimme == G_SCALAR)
2413 if (gimme == G_ARRAY) {
2414 if (!CvLVALUE(cx->blk_sub.cv))
2415 goto temporise_array;
2416 EXTEND_MORTAL(SP - newsp);
2417 for (mark = newsp + 1; mark <= SP; mark++) {
2420 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2421 *mark = sv_mortalcopy(*mark);
2423 /* Can be a localized value subject to deletion. */
2424 PL_tmps_stack[++PL_tmps_ix] = *mark;
2425 (void)SvREFCNT_inc(*mark);
2430 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2431 /* Here we go for robustness, not for speed, so we change all
2432 * the refcounts so the caller gets a live guy. Cannot set
2433 * TEMP, so sv_2mortal is out of question. */
2434 if (!CvLVALUE(cx->blk_sub.cv)) {
2440 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2442 if (gimme == G_SCALAR) {
2446 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2452 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2453 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2454 : "a readonly value" : "a temporary");
2456 else { /* Can be a localized value
2457 * subject to deletion. */
2458 PL_tmps_stack[++PL_tmps_ix] = *mark;
2459 (void)SvREFCNT_inc(*mark);
2462 else { /* Should not happen? */
2468 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2469 (MARK > SP ? "Empty array" : "Array"));
2473 else if (gimme == G_ARRAY) {
2474 EXTEND_MORTAL(SP - newsp);
2475 for (mark = newsp + 1; mark <= SP; mark++) {
2476 if (*mark != &PL_sv_undef
2477 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2478 /* Might be flattened array after $#array = */
2485 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2486 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2489 /* Can be a localized value subject to deletion. */
2490 PL_tmps_stack[++PL_tmps_ix] = *mark;
2491 (void)SvREFCNT_inc(*mark);
2497 if (gimme == G_SCALAR) {
2501 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2503 *MARK = SvREFCNT_inc(TOPs);
2508 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2510 *MARK = sv_mortalcopy(sv);
2515 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2519 *MARK = &PL_sv_undef;
2523 else if (gimme == G_ARRAY) {
2525 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2526 if (!SvTEMP(*MARK)) {
2527 *MARK = sv_mortalcopy(*MARK);
2528 TAINT_NOT; /* Each item is independent */
2537 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2538 PL_curpm = newpm; /* ... and pop $1 et al */
2541 return pop_return();
2546 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2548 SV *dbsv = GvSV(PL_DBsub);
2550 if (!PERLDB_SUB_NN) {
2554 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2555 || strEQ(GvNAME(gv), "END")
2556 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2557 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2558 && (gv = (GV*)*svp) ))) {
2559 /* Use GV from the stack as a fallback. */
2560 /* GV is potentially non-unique, or contain different CV. */
2561 SV *tmp = newRV((SV*)cv);
2562 sv_setsv(dbsv, tmp);
2566 gv_efullname3(dbsv, gv, Nullch);
2570 (void)SvUPGRADE(dbsv, SVt_PVIV);
2571 (void)SvIOK_on(dbsv);
2572 SAVEIV(SvIVX(dbsv));
2573 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2577 PL_curcopdb = PL_curcop;
2578 cv = GvCV(PL_DBsub);
2588 register PERL_CONTEXT *cx;
2590 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2593 DIE(aTHX_ "Not a CODE reference");
2594 switch (SvTYPE(sv)) {
2595 /* This is overwhelming the most common case: */
2597 if (!(cv = GvCVu((GV*)sv)))
2598 cv = sv_2cv(sv, &stash, &gv, FALSE);
2610 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2612 SP = PL_stack_base + POPMARK;
2615 if (SvGMAGICAL(sv)) {
2619 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2622 sym = SvPV(sv, n_a);
2624 DIE(aTHX_ PL_no_usym, "a subroutine");
2625 if (PL_op->op_private & HINT_STRICT_REFS)
2626 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2627 cv = get_cv(sym, TRUE);
2632 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2633 tryAMAGICunDEREF(to_cv);
2636 if (SvTYPE(cv) == SVt_PVCV)
2641 DIE(aTHX_ "Not a CODE reference");
2642 /* This is the second most common case: */
2652 if (!CvROOT(cv) && !CvXSUB(cv)) {
2657 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2658 if (CvASSERTION(cv) && PL_DBassertion)
2659 sv_setiv(PL_DBassertion, 1);
2661 cv = get_db_sub(&sv, cv);
2663 DIE(aTHX_ "No DBsub routine");
2666 if (!(CvXSUB(cv))) {
2667 /* This path taken at least 75% of the time */
2669 register I32 items = SP - MARK;
2670 AV* padlist = CvPADLIST(cv);
2671 push_return(PL_op->op_next);
2672 PUSHBLOCK(cx, CXt_SUB, MARK);
2675 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2676 * that eval'' ops within this sub know the correct lexical space.
2677 * Owing the speed considerations, we choose instead to search for
2678 * the cv using find_runcv() when calling doeval().
2680 if (CvDEPTH(cv) >= 2) {
2681 PERL_STACK_OVERFLOW_CHECK();
2682 pad_push(padlist, CvDEPTH(cv), 1);
2684 PAD_SET_CUR(padlist, CvDEPTH(cv));
2691 DEBUG_S(PerlIO_printf(Perl_debug_log,
2692 "%p entersub preparing @_\n", thr));
2694 av = (AV*)PAD_SVl(0);
2696 /* @_ is normally not REAL--this should only ever
2697 * happen when DB::sub() calls things that modify @_ */
2702 cx->blk_sub.savearray = GvAV(PL_defgv);
2703 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2704 CX_CURPAD_SAVE(cx->blk_sub);
2705 cx->blk_sub.argarray = av;
2708 if (items > AvMAX(av) + 1) {
2710 if (AvARRAY(av) != ary) {
2711 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2712 SvPVX(av) = (char*)ary;
2714 if (items > AvMAX(av) + 1) {
2715 AvMAX(av) = items - 1;
2716 Renew(ary,items,SV*);
2718 SvPVX(av) = (char*)ary;
2721 Copy(MARK,AvARRAY(av),items,SV*);
2722 AvFILLp(av) = items - 1;
2730 /* warning must come *after* we fully set up the context
2731 * stuff so that __WARN__ handlers can safely dounwind()
2734 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2735 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2736 sub_crush_depth(cv);
2738 DEBUG_S(PerlIO_printf(Perl_debug_log,
2739 "%p entersub returning %p\n", thr, CvSTART(cv)));
2741 RETURNOP(CvSTART(cv));
2744 #ifdef PERL_XSUB_OLDSTYLE
2745 if (CvOLDSTYLE(cv)) {
2746 I32 (*fp3)(int,int,int);
2748 register I32 items = SP - MARK;
2749 /* We dont worry to copy from @_. */
2754 PL_stack_sp = mark + 1;
2755 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2756 items = (*fp3)(CvXSUBANY(cv).any_i32,
2757 MARK - PL_stack_base + 1,
2759 PL_stack_sp = PL_stack_base + items;
2762 #endif /* PERL_XSUB_OLDSTYLE */
2764 I32 markix = TOPMARK;
2769 /* Need to copy @_ to stack. Alternative may be to
2770 * switch stack to @_, and copy return values
2771 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2774 av = GvAV(PL_defgv);
2775 items = AvFILLp(av) + 1; /* @_ is not tieable */
2778 /* Mark is at the end of the stack. */
2780 Copy(AvARRAY(av), SP + 1, items, SV*);
2785 /* We assume first XSUB in &DB::sub is the called one. */
2787 SAVEVPTR(PL_curcop);
2788 PL_curcop = PL_curcopdb;
2791 /* Do we need to open block here? XXXX */
2792 (void)(*CvXSUB(cv))(aTHX_ cv);
2794 /* Enforce some sanity in scalar context. */
2795 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2796 if (markix > PL_stack_sp - PL_stack_base)
2797 *(PL_stack_base + markix) = &PL_sv_undef;
2799 *(PL_stack_base + markix) = *PL_stack_sp;
2800 PL_stack_sp = PL_stack_base + markix;
2807 assert (0); /* Cannot get here. */
2808 /* This is deliberately moved here as spaghetti code to keep it out of the
2815 /* anonymous or undef'd function leaves us no recourse */
2816 if (CvANON(cv) || !(gv = CvGV(cv)))
2817 DIE(aTHX_ "Undefined subroutine called");
2819 /* autoloaded stub? */
2820 if (cv != GvCV(gv)) {
2823 /* should call AUTOLOAD now? */
2826 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2833 sub_name = sv_newmortal();
2834 gv_efullname3(sub_name, gv, Nullch);
2835 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2839 DIE(aTHX_ "Not a CODE reference");
2845 Perl_sub_crush_depth(pTHX_ CV *cv)
2848 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2850 SV* tmpstr = sv_newmortal();
2851 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2852 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2862 IV elem = SvIV(elemsv);
2864 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2865 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2868 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2869 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2871 elem -= PL_curcop->cop_arybase;
2872 if (SvTYPE(av) != SVt_PVAV)
2874 svp = av_fetch(av, elem, lval && !defer);
2876 if (!svp || *svp == &PL_sv_undef) {
2879 DIE(aTHX_ PL_no_aelem, elem);
2880 lv = sv_newmortal();
2881 sv_upgrade(lv, SVt_PVLV);
2883 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2884 LvTARG(lv) = SvREFCNT_inc(av);
2885 LvTARGOFF(lv) = elem;
2890 if (PL_op->op_private & OPpLVAL_INTRO)
2891 save_aelem(av, elem, svp);
2892 else if (PL_op->op_private & OPpDEREF)
2893 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2895 sv = (svp ? *svp : &PL_sv_undef);
2896 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2897 sv = sv_mortalcopy(sv);
2903 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2909 Perl_croak(aTHX_ PL_no_modify);
2910 if (SvTYPE(sv) < SVt_RV)
2911 sv_upgrade(sv, SVt_RV);
2912 else if (SvTYPE(sv) >= SVt_PV) {
2913 (void)SvOOK_off(sv);
2914 Safefree(SvPVX(sv));
2915 SvLEN(sv) = SvCUR(sv) = 0;
2919 SvRV(sv) = NEWSV(355,0);
2922 SvRV(sv) = (SV*)newAV();
2925 SvRV(sv) = (SV*)newHV();
2940 if (SvTYPE(rsv) == SVt_PVCV) {
2946 SETs(method_common(sv, Null(U32*)));
2954 U32 hash = SvUVX(sv);
2956 XPUSHs(method_common(sv, &hash));
2961 S_method_common(pTHX_ SV* meth, U32* hashp)
2970 SV *packsv = Nullsv;
2973 name = SvPV(meth, namelen);
2974 sv = *(PL_stack_base + TOPMARK + 1);
2977 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2986 /* this isn't a reference */
2989 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2991 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2993 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3000 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3001 !(ob=(SV*)GvIO(iogv)))
3003 /* this isn't the name of a filehandle either */
3005 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3006 ? !isIDFIRST_utf8((U8*)packname)
3007 : !isIDFIRST(*packname)
3010 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3011 SvOK(sv) ? "without a package or object reference"
3012 : "on an undefined value");
3014 /* assume it's a package name */
3015 stash = gv_stashpvn(packname, packlen, FALSE);
3019 SV* ref = newSViv(PTR2IV(stash));
3020 hv_store(PL_stashcache, packname, packlen, ref, 0);
3024 /* it _is_ a filehandle name -- replace with a reference */
3025 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3028 /* if we got here, ob should be a reference or a glob */
3029 if (!ob || !(SvOBJECT(ob)
3030 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3033 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3037 stash = SvSTASH(ob);
3040 /* NOTE: stash may be null, hope hv_fetch_ent and
3041 gv_fetchmethod can cope (it seems they can) */
3043 /* shortcut for simple names */
3045 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3047 gv = (GV*)HeVAL(he);
3048 if (isGV(gv) && GvCV(gv) &&
3049 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3050 return (SV*)GvCV(gv);
3054 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3057 /* This code tries to figure out just what went wrong with
3058 gv_fetchmethod. It therefore needs to duplicate a lot of
3059 the internals of that function. We can't move it inside
3060 Perl_gv_fetchmethod_autoload(), however, since that would
3061 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3068 for (p = name; *p; p++) {
3070 sep = p, leaf = p + 1;
3071 else if (*p == ':' && *(p + 1) == ':')
3072 sep = p, leaf = p + 2;
3074 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3075 /* the method name is unqualified or starts with SUPER:: */
3076 packname = sep ? CopSTASHPV(PL_curcop) :
3077 stash ? HvNAME(stash) : packname;
3080 "Can't use anonymous symbol table for method lookup");
3082 packlen = strlen(packname);
3085 /* the method name is qualified */
3087 packlen = sep - name;
3090 /* we're relying on gv_fetchmethod not autovivifying the stash */
3091 if (gv_stashpvn(packname, packlen, FALSE)) {
3093 "Can't locate object method \"%s\" via package \"%.*s\"",
3094 leaf, (int)packlen, packname);
3098 "Can't locate object method \"%s\" via package \"%.*s\""
3099 " (perhaps you forgot to load \"%.*s\"?)",
3100 leaf, (int)packlen, packname, (int)packlen, packname);
3103 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;