3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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 = !DO_UTF8(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 = !DO_UTF8(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 = !DO_UTF8(left);
168 #if defined(PERL_Y2KWARN)
169 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
170 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
171 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
173 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
174 "about to append an integer to '19'");
179 if (lbyte != rbyte) {
181 sv_utf8_upgrade_nomg(TARG);
184 right = sv_2mortal(newSVpvn(rpv, rlen));
185 sv_utf8_upgrade_nomg(right);
186 rpv = SvPV(right, rlen);
189 sv_catpvn_nomg(TARG, rpv, rlen);
200 if (PL_op->op_flags & OPf_MOD) {
201 if (PL_op->op_private & OPpLVAL_INTRO)
202 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
203 if (PL_op->op_private & OPpDEREF) {
205 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
214 tryAMAGICunTARGET(iter, 0);
215 PL_last_in_gv = (GV*)(*PL_stack_sp--);
216 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
217 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
218 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
221 XPUSHs((SV*)PL_last_in_gv);
224 PL_last_in_gv = (GV*)(*PL_stack_sp--);
227 return do_readline();
232 dSP; tryAMAGICbinSET(eq,0);
233 #ifndef NV_PRESERVES_UV
234 if (SvROK(TOPs) && SvROK(TOPm1s)) {
236 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
240 #ifdef PERL_PRESERVE_IVUV
243 /* Unless the left argument is integer in range we are going
244 to have to use NV maths. Hence only attempt to coerce the
245 right argument if we know the left is integer. */
248 bool auvok = SvUOK(TOPm1s);
249 bool buvok = SvUOK(TOPs);
251 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
252 /* Casting IV to UV before comparison isn't going to matter
253 on 2s complement. On 1s complement or sign&magnitude
254 (if we have any of them) it could to make negative zero
255 differ from normal zero. As I understand it. (Need to
256 check - is negative zero implementation defined behaviour
258 UV buv = SvUVX(POPs);
259 UV auv = SvUVX(TOPs);
261 SETs(boolSV(auv == buv));
264 { /* ## Mixed IV,UV ## */
268 /* == is commutative so doesn't matter which is left or right */
270 /* top of stack (b) is the iv */
279 /* As uv is a UV, it's >0, so it cannot be == */
283 /* we know iv is >= 0 */
284 SETs(boolSV((UV)iv == SvUVX(uvp)));
292 SETs(boolSV(TOPn == value));
300 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
301 DIE(aTHX_ PL_no_modify);
302 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
303 && SvIVX(TOPs) != IV_MAX)
306 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
308 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
321 RETURNOP(cLOGOP->op_other);
327 /* Most of this is lifted straight from pp_defined */
332 if (!sv || !SvANY(sv)) {
334 RETURNOP(cLOGOP->op_other);
337 switch (SvTYPE(sv)) {
339 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
343 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
347 if (CvROOT(sv) || CvXSUB(sv))
358 RETURNOP(cLOGOP->op_other);
363 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
364 useleft = USE_LEFT(TOPm1s);
365 #ifdef PERL_PRESERVE_IVUV
366 /* We must see if we can perform the addition with integers if possible,
367 as the integer code detects overflow while the NV code doesn't.
368 If either argument hasn't had a numeric conversion yet attempt to get
369 the IV. It's important to do this now, rather than just assuming that
370 it's not IOK as a PV of "9223372036854775806" may not take well to NV
371 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
372 integer in case the second argument is IV=9223372036854775806
373 We can (now) rely on sv_2iv to do the right thing, only setting the
374 public IOK flag if the value in the NV (or PV) slot is truly integer.
376 A side effect is that this also aggressively prefers integer maths over
377 fp maths for integer values.
379 How to detect overflow?
381 C 99 section 6.2.6.1 says
383 The range of nonnegative values of a signed integer type is a subrange
384 of the corresponding unsigned integer type, and the representation of
385 the same value in each type is the same. A computation involving
386 unsigned operands can never overflow, because a result that cannot be
387 represented by the resulting unsigned integer type is reduced modulo
388 the number that is one greater than the largest value that can be
389 represented by the resulting type.
393 which I read as "unsigned ints wrap."
395 signed integer overflow seems to be classed as "exception condition"
397 If an exceptional condition occurs during the evaluation of an
398 expression (that is, if the result is not mathematically defined or not
399 in the range of representable values for its type), the behavior is
402 (6.5, the 5th paragraph)
404 I had assumed that on 2s complement machines signed arithmetic would
405 wrap, hence coded pp_add and pp_subtract on the assumption that
406 everything perl builds on would be happy. After much wailing and
407 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
408 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
409 unsigned code below is actually shorter than the old code. :-)
414 /* Unless the left argument is integer in range we are going to have to
415 use NV maths. Hence only attempt to coerce the right argument if
416 we know the left is integer. */
424 /* left operand is undef, treat as zero. + 0 is identity,
425 Could SETi or SETu right now, but space optimise by not adding
426 lots of code to speed up what is probably a rarish case. */
428 /* Left operand is defined, so is it IV? */
431 if ((auvok = SvUOK(TOPm1s)))
434 register IV aiv = SvIVX(TOPm1s);
437 auvok = 1; /* Now acting as a sign flag. */
438 } else { /* 2s complement assumption for IV_MIN */
446 bool result_good = 0;
449 bool buvok = SvUOK(TOPs);
454 register IV biv = SvIVX(TOPs);
461 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
462 else "IV" now, independent of how it came in.
463 if a, b represents positive, A, B negative, a maps to -A etc
468 all UV maths. negate result if A negative.
469 add if signs same, subtract if signs differ. */
475 /* Must get smaller */
481 /* result really should be -(auv-buv). as its negation
482 of true value, need to swap our result flag */
499 if (result <= (UV)IV_MIN)
502 /* result valid, but out of range for IV. */
507 } /* Overflow, drop through to NVs. */
514 /* left operand is undef, treat as zero. + 0.0 is identity. */
518 SETn( value + TOPn );
526 AV *av = PL_op->op_flags & OPf_SPECIAL ?
527 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
528 U32 lval = PL_op->op_flags & OPf_MOD;
529 SV** svp = av_fetch(av, PL_op->op_private, lval);
530 SV *sv = (svp ? *svp : &PL_sv_undef);
532 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
533 sv = sv_mortalcopy(sv);
542 do_join(TARG, *MARK, MARK, SP);
553 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
554 * will be enough to hold an OP*.
556 SV* sv = sv_newmortal();
557 sv_upgrade(sv, SVt_PVLV);
559 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
567 /* Oversized hot code. */
571 dSP; dMARK; dORIGMARK;
577 if (PL_op->op_flags & OPf_STACKED)
582 if (gv && (io = GvIO(gv))
583 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
586 if (MARK == ORIGMARK) {
587 /* If using default handle then we need to make space to
588 * pass object as 1st arg, so move other args up ...
592 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
596 *MARK = SvTIED_obj((SV*)io, mg);
599 call_method("PRINT", G_SCALAR);
607 if (!(io = GvIO(gv))) {
608 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
609 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
611 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
612 report_evil_fh(gv, io, PL_op->op_type);
613 SETERRNO(EBADF,RMS_IFI);
616 else if (!(fp = IoOFP(io))) {
617 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
619 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
620 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
621 report_evil_fh(gv, io, PL_op->op_type);
623 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
628 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
630 if (!do_print(*MARK, fp))
634 if (!do_print(PL_ofs_sv, fp)) { /* $, */
643 if (!do_print(*MARK, fp))
651 if (PL_ors_sv && SvOK(PL_ors_sv))
652 if (!do_print(PL_ors_sv, fp)) /* $\ */
655 if (IoFLAGS(io) & IOf_FLUSH)
656 if (PerlIO_flush(fp) == EOF)
677 tryAMAGICunDEREF(to_av);
680 if (SvTYPE(av) != SVt_PVAV)
681 DIE(aTHX_ "Not an ARRAY reference");
682 if (PL_op->op_flags & OPf_REF) {
687 if (GIMME == G_SCALAR)
688 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
692 else if (PL_op->op_flags & OPf_MOD
693 && PL_op->op_private & OPpLVAL_INTRO)
694 Perl_croak(aTHX_ PL_no_localize_ref);
697 if (SvTYPE(sv) == SVt_PVAV) {
699 if (PL_op->op_flags & OPf_REF) {
704 if (GIMME == G_SCALAR)
705 Perl_croak(aTHX_ "Can't return array to lvalue"
714 if (SvTYPE(sv) != SVt_PVGV) {
718 if (SvGMAGICAL(sv)) {
724 if (PL_op->op_flags & OPf_REF ||
725 PL_op->op_private & HINT_STRICT_REFS)
726 DIE(aTHX_ PL_no_usym, "an ARRAY");
727 if (ckWARN(WARN_UNINITIALIZED))
729 if (GIMME == G_ARRAY) {
736 if ((PL_op->op_flags & OPf_SPECIAL) &&
737 !(PL_op->op_flags & OPf_MOD))
739 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
741 && (!is_gv_magical(sym,len,0)
742 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
748 if (PL_op->op_private & HINT_STRICT_REFS)
749 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
750 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
757 if (PL_op->op_private & OPpLVAL_INTRO)
759 if (PL_op->op_flags & OPf_REF) {
764 if (GIMME == G_SCALAR)
765 Perl_croak(aTHX_ "Can't return array to lvalue"
773 if (GIMME == G_ARRAY) {
774 I32 maxarg = AvFILL(av) + 1;
775 (void)POPs; /* XXXX May be optimized away? */
777 if (SvRMAGICAL(av)) {
779 for (i=0; i < (U32)maxarg; i++) {
780 SV **svp = av_fetch(av, i, FALSE);
781 /* See note in pp_helem, and bug id #27839 */
783 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
788 Copy(AvARRAY(av), SP+1, maxarg, SV*);
792 else if (GIMME_V == G_SCALAR) {
794 I32 maxarg = AvFILL(av) + 1;
808 tryAMAGICunDEREF(to_hv);
811 if (SvTYPE(hv) != SVt_PVHV)
812 DIE(aTHX_ "Not a HASH reference");
813 if (PL_op->op_flags & OPf_REF) {
818 if (gimme != G_ARRAY)
819 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
823 else if (PL_op->op_flags & OPf_MOD
824 && PL_op->op_private & OPpLVAL_INTRO)
825 Perl_croak(aTHX_ PL_no_localize_ref);
828 if (SvTYPE(sv) == SVt_PVHV) {
830 if (PL_op->op_flags & OPf_REF) {
835 if (gimme != G_ARRAY)
836 Perl_croak(aTHX_ "Can't return hash to lvalue"
845 if (SvTYPE(sv) != SVt_PVGV) {
849 if (SvGMAGICAL(sv)) {
855 if (PL_op->op_flags & OPf_REF ||
856 PL_op->op_private & HINT_STRICT_REFS)
857 DIE(aTHX_ PL_no_usym, "a HASH");
858 if (ckWARN(WARN_UNINITIALIZED))
860 if (gimme == G_ARRAY) {
867 if ((PL_op->op_flags & OPf_SPECIAL) &&
868 !(PL_op->op_flags & OPf_MOD))
870 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
872 && (!is_gv_magical(sym,len,0)
873 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
879 if (PL_op->op_private & HINT_STRICT_REFS)
880 DIE(aTHX_ PL_no_symref, sym, "a HASH");
881 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
888 if (PL_op->op_private & OPpLVAL_INTRO)
890 if (PL_op->op_flags & OPf_REF) {
895 if (gimme != G_ARRAY)
896 Perl_croak(aTHX_ "Can't return hash to lvalue"
904 if (gimme == G_ARRAY) { /* array wanted */
905 *PL_stack_sp = (SV*)hv;
908 else if (gimme == G_SCALAR) {
910 TARG = Perl_hv_scalar(aTHX_ hv);
917 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
923 if (ckWARN(WARN_MISC)) {
924 if (relem == firstrelem &&
926 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
927 SvTYPE(SvRV(*relem)) == SVt_PVHV))
929 Perl_warner(aTHX_ packWARN(WARN_MISC),
930 "Reference found where even-sized list expected");
933 Perl_warner(aTHX_ packWARN(WARN_MISC),
934 "Odd number of elements in hash assignment");
937 tmpstr = NEWSV(29,0);
938 didstore = hv_store_ent(hash,*relem,tmpstr,0);
939 if (SvMAGICAL(hash)) {
940 if (SvSMAGICAL(tmpstr))
952 SV **lastlelem = PL_stack_sp;
953 SV **lastrelem = PL_stack_base + POPMARK;
954 SV **firstrelem = PL_stack_base + POPMARK + 1;
955 SV **firstlelem = lastrelem + 1;
968 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
971 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
974 /* If there's a common identifier on both sides we have to take
975 * special care that assigning the identifier on the left doesn't
976 * clobber a value on the right that's used later in the list.
978 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
979 EXTEND_MORTAL(lastrelem - firstrelem + 1);
980 for (relem = firstrelem; relem <= lastrelem; relem++) {
983 TAINT_NOT; /* Each item is independent */
984 *relem = sv_mortalcopy(sv);
994 while (lelem <= lastlelem) {
995 TAINT_NOT; /* Each item stands on its own, taintwise. */
997 switch (SvTYPE(sv)) {
1000 magic = SvMAGICAL(ary) != 0;
1002 av_extend(ary, lastrelem - relem);
1004 while (relem <= lastrelem) { /* gobble up all the rest */
1008 sv_setsv(sv,*relem);
1010 didstore = av_store(ary,i++,sv);
1020 case SVt_PVHV: { /* normal hash */
1024 magic = SvMAGICAL(hash) != 0;
1026 firsthashrelem = relem;
1028 while (relem < lastrelem) { /* gobble up all the rest */
1033 sv = &PL_sv_no, relem++;
1034 tmpstr = NEWSV(29,0);
1036 sv_setsv(tmpstr,*relem); /* value */
1037 *(relem++) = tmpstr;
1038 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1039 /* key overwrites an existing entry */
1041 didstore = hv_store_ent(hash,sv,tmpstr,0);
1043 if (SvSMAGICAL(tmpstr))
1050 if (relem == lastrelem) {
1051 do_oddball(hash, relem, firstrelem);
1057 if (SvIMMORTAL(sv)) {
1058 if (relem <= lastrelem)
1062 if (relem <= lastrelem) {
1063 sv_setsv(sv, *relem);
1067 sv_setsv(sv, &PL_sv_undef);
1072 if (PL_delaymagic & ~DM_DELAY) {
1073 if (PL_delaymagic & DM_UID) {
1074 #ifdef HAS_SETRESUID
1075 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1076 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1079 # ifdef HAS_SETREUID
1080 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1081 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1084 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1085 (void)setruid(PL_uid);
1086 PL_delaymagic &= ~DM_RUID;
1088 # endif /* HAS_SETRUID */
1090 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1091 (void)seteuid(PL_euid);
1092 PL_delaymagic &= ~DM_EUID;
1094 # endif /* HAS_SETEUID */
1095 if (PL_delaymagic & DM_UID) {
1096 if (PL_uid != PL_euid)
1097 DIE(aTHX_ "No setreuid available");
1098 (void)PerlProc_setuid(PL_uid);
1100 # endif /* HAS_SETREUID */
1101 #endif /* HAS_SETRESUID */
1102 PL_uid = PerlProc_getuid();
1103 PL_euid = PerlProc_geteuid();
1105 if (PL_delaymagic & DM_GID) {
1106 #ifdef HAS_SETRESGID
1107 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1108 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1111 # ifdef HAS_SETREGID
1112 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1113 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1116 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1117 (void)setrgid(PL_gid);
1118 PL_delaymagic &= ~DM_RGID;
1120 # endif /* HAS_SETRGID */
1122 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1123 (void)setegid(PL_egid);
1124 PL_delaymagic &= ~DM_EGID;
1126 # endif /* HAS_SETEGID */
1127 if (PL_delaymagic & DM_GID) {
1128 if (PL_gid != PL_egid)
1129 DIE(aTHX_ "No setregid available");
1130 (void)PerlProc_setgid(PL_gid);
1132 # endif /* HAS_SETREGID */
1133 #endif /* HAS_SETRESGID */
1134 PL_gid = PerlProc_getgid();
1135 PL_egid = PerlProc_getegid();
1137 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1141 if (gimme == G_VOID)
1142 SP = firstrelem - 1;
1143 else if (gimme == G_SCALAR) {
1146 SETi(lastrelem - firstrelem + 1 - duplicates);
1153 /* Removes from the stack the entries which ended up as
1154 * duplicated keys in the hash (fix for [perl #24380]) */
1155 Move(firsthashrelem + duplicates,
1156 firsthashrelem, duplicates, SV**);
1157 lastrelem -= duplicates;
1162 SP = firstrelem + (lastlelem - firstlelem);
1163 lelem = firstlelem + (relem - firstrelem);
1165 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1173 register PMOP *pm = cPMOP;
1174 SV *rv = sv_newmortal();
1175 SV *sv = newSVrv(rv, "Regexp");
1176 if (pm->op_pmdynflags & PMdf_TAINTED)
1178 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1185 register PMOP *pm = cPMOP;
1191 I32 r_flags = REXEC_CHECKED;
1192 char *truebase; /* Start of string */
1193 register REGEXP *rx = PM_GETRE(pm);
1198 I32 oldsave = PL_savestack_ix;
1199 I32 update_minmatch = 1;
1200 I32 had_zerolen = 0;
1202 if (PL_op->op_flags & OPf_STACKED)
1204 else if (PL_op->op_private & OPpTARGET_MY)
1211 PUTBACK; /* EVAL blocks need stack_sp. */
1212 s = SvPV(TARG, len);
1215 DIE(aTHX_ "panic: pp_match");
1216 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1217 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1220 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1222 /* PMdf_USED is set after a ?? matches once */
1223 if (pm->op_pmdynflags & PMdf_USED) {
1225 if (gimme == G_ARRAY)
1230 /* empty pattern special-cased to use last successful pattern if possible */
1231 if (!rx->prelen && PL_curpm) {
1236 if (rx->minlen > (I32)len)
1241 /* XXXX What part of this is needed with true \G-support? */
1242 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1244 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1245 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1246 if (mg && mg->mg_len >= 0) {
1247 if (!(rx->reganch & ROPT_GPOS_SEEN))
1248 rx->endp[0] = rx->startp[0] = mg->mg_len;
1249 else if (rx->reganch & ROPT_ANCH_GPOS) {
1250 r_flags |= REXEC_IGNOREPOS;
1251 rx->endp[0] = rx->startp[0] = mg->mg_len;
1253 minmatch = (mg->mg_flags & MGf_MINMATCH);
1254 update_minmatch = 0;
1258 if ((!global && rx->nparens)
1259 || SvTEMP(TARG) || PL_sawampersand)
1260 r_flags |= REXEC_COPY_STR;
1262 r_flags |= REXEC_SCREAM;
1264 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1265 SAVEINT(PL_multiline);
1266 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1270 if (global && rx->startp[0] != -1) {
1271 t = s = rx->endp[0] + truebase;
1272 if ((s + rx->minlen) > strend)
1274 if (update_minmatch++)
1275 minmatch = had_zerolen;
1277 if (rx->reganch & RE_USE_INTUIT &&
1278 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1279 PL_bostr = truebase;
1280 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1284 if ( (rx->reganch & ROPT_CHECK_ALL)
1286 && ((rx->reganch & ROPT_NOSCAN)
1287 || !((rx->reganch & RE_INTUIT_TAIL)
1288 && (r_flags & REXEC_SCREAM)))
1289 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1292 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1295 if (dynpm->op_pmflags & PMf_ONCE)
1296 dynpm->op_pmdynflags |= PMdf_USED;
1305 RX_MATCH_TAINTED_on(rx);
1306 TAINT_IF(RX_MATCH_TAINTED(rx));
1307 if (gimme == G_ARRAY) {
1308 I32 nparens, i, len;
1310 nparens = rx->nparens;
1311 if (global && !nparens)
1315 SPAGAIN; /* EVAL blocks could move the stack. */
1316 EXTEND(SP, nparens + i);
1317 EXTEND_MORTAL(nparens + i);
1318 for (i = !i; i <= nparens; i++) {
1319 PUSHs(sv_newmortal());
1321 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1322 len = rx->endp[i] - rx->startp[i];
1323 s = rx->startp[i] + truebase;
1324 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1325 len < 0 || len > strend - s)
1326 DIE(aTHX_ "panic: pp_match start/end pointers");
1327 sv_setpvn(*SP, s, len);
1328 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1333 if (dynpm->op_pmflags & PMf_CONTINUE) {
1335 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1336 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1338 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1339 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1341 if (rx->startp[0] != -1) {
1342 mg->mg_len = rx->endp[0];
1343 if (rx->startp[0] == rx->endp[0])
1344 mg->mg_flags |= MGf_MINMATCH;
1346 mg->mg_flags &= ~MGf_MINMATCH;
1349 had_zerolen = (rx->startp[0] != -1
1350 && rx->startp[0] == rx->endp[0]);
1351 PUTBACK; /* EVAL blocks may use stack */
1352 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1357 LEAVE_SCOPE(oldsave);
1363 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1364 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1366 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1367 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1369 if (rx->startp[0] != -1) {
1370 mg->mg_len = rx->endp[0];
1371 if (rx->startp[0] == rx->endp[0])
1372 mg->mg_flags |= MGf_MINMATCH;
1374 mg->mg_flags &= ~MGf_MINMATCH;
1377 LEAVE_SCOPE(oldsave);
1381 yup: /* Confirmed by INTUIT */
1383 RX_MATCH_TAINTED_on(rx);
1384 TAINT_IF(RX_MATCH_TAINTED(rx));
1386 if (dynpm->op_pmflags & PMf_ONCE)
1387 dynpm->op_pmdynflags |= PMdf_USED;
1388 if (RX_MATCH_COPIED(rx))
1389 Safefree(rx->subbeg);
1390 RX_MATCH_COPIED_off(rx);
1391 rx->subbeg = Nullch;
1393 rx->subbeg = truebase;
1394 rx->startp[0] = s - truebase;
1395 if (RX_MATCH_UTF8(rx)) {
1396 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1397 rx->endp[0] = t - truebase;
1400 rx->endp[0] = s - truebase + rx->minlen;
1402 rx->sublen = strend - truebase;
1405 if (PL_sawampersand) {
1407 #ifdef PERL_COPY_ON_WRITE
1408 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1410 PerlIO_printf(Perl_debug_log,
1411 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1412 (int) SvTYPE(TARG), truebase, t,
1415 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1416 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1417 assert (SvPOKp(rx->saved_copy));
1422 rx->subbeg = savepvn(t, strend - t);
1423 #ifdef PERL_COPY_ON_WRITE
1424 rx->saved_copy = Nullsv;
1427 rx->sublen = strend - t;
1428 RX_MATCH_COPIED_on(rx);
1429 off = rx->startp[0] = s - t;
1430 rx->endp[0] = off + rx->minlen;
1432 else { /* startp/endp are used by @- @+. */
1433 rx->startp[0] = s - truebase;
1434 rx->endp[0] = s - truebase + rx->minlen;
1436 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1437 LEAVE_SCOPE(oldsave);
1442 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1443 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1444 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1449 LEAVE_SCOPE(oldsave);
1450 if (gimme == G_ARRAY)
1456 Perl_do_readline(pTHX)
1458 dSP; dTARGETSTACKED;
1463 register IO *io = GvIO(PL_last_in_gv);
1464 register I32 type = PL_op->op_type;
1465 I32 gimme = GIMME_V;
1468 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1470 XPUSHs(SvTIED_obj((SV*)io, mg));
1473 call_method("READLINE", gimme);
1476 if (gimme == G_SCALAR) {
1478 SvSetSV_nosteal(TARG, result);
1487 if (IoFLAGS(io) & IOf_ARGV) {
1488 if (IoFLAGS(io) & IOf_START) {
1490 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1491 IoFLAGS(io) &= ~IOf_START;
1492 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1493 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1494 SvSETMAGIC(GvSV(PL_last_in_gv));
1499 fp = nextargv(PL_last_in_gv);
1500 if (!fp) { /* Note: fp != IoIFP(io) */
1501 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1504 else if (type == OP_GLOB)
1505 fp = Perl_start_glob(aTHX_ POPs, io);
1507 else if (type == OP_GLOB)
1509 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1510 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1514 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1515 && (!io || !(IoFLAGS(io) & IOf_START))) {
1516 if (type == OP_GLOB)
1517 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1518 "glob failed (can't start child: %s)",
1521 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1523 if (gimme == G_SCALAR) {
1524 /* undef TARG, and push that undefined value */
1525 if (type != OP_RCATLINE) {
1526 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1527 (void)SvOK_off(TARG);
1534 if (gimme == G_SCALAR) {
1538 (void)SvUPGRADE(sv, SVt_PV);
1539 tmplen = SvLEN(sv); /* remember if already alloced */
1540 if (!tmplen && !SvREADONLY(sv))
1541 Sv_Grow(sv, 80); /* try short-buffering it */
1543 if (type == OP_RCATLINE && SvOK(sv)) {
1546 (void)SvPV_force(sv, n_a);
1552 sv = sv_2mortal(NEWSV(57, 80));
1556 /* This should not be marked tainted if the fp is marked clean */
1557 #define MAYBE_TAINT_LINE(io, sv) \
1558 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1563 /* delay EOF state for a snarfed empty file */
1564 #define SNARF_EOF(gimme,rs,io,sv) \
1565 (gimme != G_SCALAR || SvCUR(sv) \
1566 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1570 if (!sv_gets(sv, fp, offset)
1572 || SNARF_EOF(gimme, PL_rs, io, sv)
1573 || PerlIO_error(fp)))
1575 PerlIO_clearerr(fp);
1576 if (IoFLAGS(io) & IOf_ARGV) {
1577 fp = nextargv(PL_last_in_gv);
1580 (void)do_close(PL_last_in_gv, FALSE);
1582 else if (type == OP_GLOB) {
1583 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1584 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1585 "glob failed (child exited with status %d%s)",
1586 (int)(STATUS_CURRENT >> 8),
1587 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1590 if (gimme == G_SCALAR) {
1591 if (type != OP_RCATLINE) {
1592 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1593 (void)SvOK_off(TARG);
1598 MAYBE_TAINT_LINE(io, sv);
1601 MAYBE_TAINT_LINE(io, sv);
1603 IoFLAGS(io) |= IOf_NOLINE;
1607 if (type == OP_GLOB) {
1610 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1611 tmps = SvEND(sv) - 1;
1612 if (*tmps == *SvPVX(PL_rs)) {
1617 for (tmps = SvPVX(sv); *tmps; tmps++)
1618 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1619 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1621 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1622 (void)POPs; /* Unmatched wildcard? Chuck it... */
1625 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1626 U8 *s = (U8*)SvPVX(sv) + offset;
1627 STRLEN len = SvCUR(sv) - offset;
1630 if (ckWARN(WARN_UTF8) &&
1631 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1632 /* Emulate :encoding(utf8) warning in the same case. */
1633 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1634 "utf8 \"\\x%02X\" does not map to Unicode",
1635 f < (U8*)SvEND(sv) ? *f : 0);
1637 if (gimme == G_ARRAY) {
1638 if (SvLEN(sv) - SvCUR(sv) > 20) {
1639 SvLEN_set(sv, SvCUR(sv)+1);
1640 Renew(SvPVX(sv), SvLEN(sv), char);
1642 sv = sv_2mortal(NEWSV(58, 80));
1645 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1646 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1650 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1651 Renew(SvPVX(sv), SvLEN(sv), char);
1660 register PERL_CONTEXT *cx;
1661 I32 gimme = OP_GIMME(PL_op, -1);
1664 if (cxstack_ix >= 0)
1665 gimme = cxstack[cxstack_ix].blk_gimme;
1673 PUSHBLOCK(cx, CXt_BLOCK, SP);
1685 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1686 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1688 #ifdef PERL_COPY_ON_WRITE
1689 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1691 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1695 if (SvTYPE(hv) == SVt_PVHV) {
1696 if (PL_op->op_private & OPpLVAL_INTRO) {
1699 /* does the element we're localizing already exist? */
1701 /* can we determine whether it exists? */
1703 || mg_find((SV*)hv, PERL_MAGIC_env)
1704 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1705 /* Try to preserve the existenceness of a tied hash
1706 * element by using EXISTS and DELETE if possible.
1707 * Fallback to FETCH and STORE otherwise */
1708 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1709 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1710 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1712 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1715 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1716 svp = he ? &HeVAL(he) : 0;
1722 if (!svp || *svp == &PL_sv_undef) {
1727 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1729 lv = sv_newmortal();
1730 sv_upgrade(lv, SVt_PVLV);
1732 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1733 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1734 LvTARG(lv) = SvREFCNT_inc(hv);
1739 if (PL_op->op_private & OPpLVAL_INTRO) {
1740 if (HvNAME(hv) && isGV(*svp))
1741 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1745 char *key = SvPV(keysv, keylen);
1746 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1748 save_helem(hv, keysv, svp);
1751 else if (PL_op->op_private & OPpDEREF)
1752 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1754 sv = (svp ? *svp : &PL_sv_undef);
1755 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1756 * Pushing the magical RHS on to the stack is useless, since
1757 * that magic is soon destined to be misled by the local(),
1758 * and thus the later pp_sassign() will fail to mg_get() the
1759 * old value. This should also cure problems with delayed
1760 * mg_get()s. GSAR 98-07-03 */
1761 if (!lval && SvGMAGICAL(sv))
1762 sv = sv_mortalcopy(sv);
1770 register PERL_CONTEXT *cx;
1776 if (PL_op->op_flags & OPf_SPECIAL) {
1777 cx = &cxstack[cxstack_ix];
1778 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1783 gimme = OP_GIMME(PL_op, -1);
1785 if (cxstack_ix >= 0)
1786 gimme = cxstack[cxstack_ix].blk_gimme;
1792 if (gimme == G_VOID)
1794 else if (gimme == G_SCALAR) {
1797 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1800 *MARK = sv_mortalcopy(TOPs);
1803 *MARK = &PL_sv_undef;
1807 else if (gimme == G_ARRAY) {
1808 /* in case LEAVE wipes old return values */
1809 for (mark = newsp + 1; mark <= SP; mark++) {
1810 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1811 *mark = sv_mortalcopy(*mark);
1812 TAINT_NOT; /* Each item is independent */
1816 PL_curpm = newpm; /* Don't pop $1 et al till now */
1826 register PERL_CONTEXT *cx;
1832 cx = &cxstack[cxstack_ix];
1833 if (CxTYPE(cx) != CXt_LOOP)
1834 DIE(aTHX_ "panic: pp_iter");
1836 itersvp = CxITERVAR(cx);
1837 av = cx->blk_loop.iterary;
1838 if (SvTYPE(av) != SVt_PVAV) {
1839 /* iterate ($min .. $max) */
1840 if (cx->blk_loop.iterlval) {
1841 /* string increment */
1842 register SV* cur = cx->blk_loop.iterlval;
1844 char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1845 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1846 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1847 /* safe to reuse old SV */
1848 sv_setsv(*itersvp, cur);
1852 /* we need a fresh SV every time so that loop body sees a
1853 * completely new SV for closures/references to work as
1855 SvREFCNT_dec(*itersvp);
1856 *itersvp = newSVsv(cur);
1858 if (strEQ(SvPVX(cur), max))
1859 sv_setiv(cur, 0); /* terminate next time */
1866 /* integer increment */
1867 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1870 /* don't risk potential race */
1871 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1872 /* safe to reuse old SV */
1873 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1877 /* we need a fresh SV every time so that loop body sees a
1878 * completely new SV for closures/references to work as they
1880 SvREFCNT_dec(*itersvp);
1881 *itersvp = newSViv(cx->blk_loop.iterix++);
1887 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1890 SvREFCNT_dec(*itersvp);
1892 if (SvMAGICAL(av) || AvREIFY(av)) {
1893 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1900 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1902 if (sv && SvREFCNT(sv) == 0) {
1904 Perl_croak(aTHX_ "Use of freed value in iteration");
1911 if (av != PL_curstack && sv == &PL_sv_undef) {
1912 SV *lv = cx->blk_loop.iterlval;
1913 if (lv && SvREFCNT(lv) > 1) {
1918 SvREFCNT_dec(LvTARG(lv));
1920 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1921 sv_upgrade(lv, SVt_PVLV);
1923 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1925 LvTARG(lv) = SvREFCNT_inc(av);
1926 LvTARGOFF(lv) = cx->blk_loop.iterix;
1927 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1931 *itersvp = SvREFCNT_inc(sv);
1938 register PMOP *pm = cPMOP;
1954 register REGEXP *rx = PM_GETRE(pm);
1956 int force_on_match = 0;
1957 I32 oldsave = PL_savestack_ix;
1959 bool doutf8 = FALSE;
1960 #ifdef PERL_COPY_ON_WRITE
1965 /* known replacement string? */
1966 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1967 if (PL_op->op_flags & OPf_STACKED)
1969 else if (PL_op->op_private & OPpTARGET_MY)
1976 #ifdef PERL_COPY_ON_WRITE
1977 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1978 because they make integers such as 256 "false". */
1979 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1982 sv_force_normal_flags(TARG,0);
1985 #ifdef PERL_COPY_ON_WRITE
1989 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1990 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1991 DIE(aTHX_ PL_no_modify);
1994 s = SvPV(TARG, len);
1995 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1997 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1998 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2003 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2007 DIE(aTHX_ "panic: pp_subst");
2010 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2011 maxiters = 2 * slen + 10; /* We can match twice at each
2012 position, once with zero-length,
2013 second time with non-zero. */
2015 if (!rx->prelen && PL_curpm) {
2019 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2020 ? REXEC_COPY_STR : 0;
2022 r_flags |= REXEC_SCREAM;
2023 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
2024 SAVEINT(PL_multiline);
2025 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2028 if (rx->reganch & RE_USE_INTUIT) {
2030 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2034 /* How to do it in subst? */
2035 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2037 && ((rx->reganch & ROPT_NOSCAN)
2038 || !((rx->reganch & RE_INTUIT_TAIL)
2039 && (r_flags & REXEC_SCREAM))))
2044 /* only replace once? */
2045 once = !(rpm->op_pmflags & PMf_GLOBAL);
2047 /* known replacement string? */
2049 /* replacement needing upgrading? */
2050 if (DO_UTF8(TARG) && !doutf8) {
2051 nsv = sv_newmortal();
2054 sv_recode_to_utf8(nsv, PL_encoding);
2056 sv_utf8_upgrade(nsv);
2057 c = SvPV(nsv, clen);
2061 c = SvPV(dstr, clen);
2062 doutf8 = DO_UTF8(dstr);
2070 /* can do inplace substitution? */
2072 #ifdef PERL_COPY_ON_WRITE
2075 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2076 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2077 && (!doutf8 || SvUTF8(TARG))) {
2078 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2079 r_flags | REXEC_CHECKED))
2083 LEAVE_SCOPE(oldsave);
2086 #ifdef PERL_COPY_ON_WRITE
2087 if (SvIsCOW(TARG)) {
2088 assert (!force_on_match);
2092 if (force_on_match) {
2094 s = SvPV_force(TARG, len);
2099 SvSCREAM_off(TARG); /* disable possible screamer */
2101 rxtainted |= RX_MATCH_TAINTED(rx);
2102 m = orig + rx->startp[0];
2103 d = orig + rx->endp[0];
2105 if (m - s > strend - d) { /* faster to shorten from end */
2107 Copy(c, m, clen, char);
2112 Move(d, m, i, char);
2116 SvCUR_set(TARG, m - s);
2119 else if ((i = m - s)) { /* faster from front */
2127 Copy(c, m, clen, char);
2132 Copy(c, d, clen, char);
2137 TAINT_IF(rxtainted & 1);
2143 if (iters++ > maxiters)
2144 DIE(aTHX_ "Substitution loop");
2145 rxtainted |= RX_MATCH_TAINTED(rx);
2146 m = rx->startp[0] + orig;
2150 Move(s, d, i, char);
2154 Copy(c, d, clen, char);
2157 s = rx->endp[0] + orig;
2158 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2160 /* don't match same null twice */
2161 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2164 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2165 Move(s, d, i+1, char); /* include the NUL */
2167 TAINT_IF(rxtainted & 1);
2169 PUSHs(sv_2mortal(newSViv((I32)iters)));
2171 (void)SvPOK_only_UTF8(TARG);
2172 TAINT_IF(rxtainted);
2173 if (SvSMAGICAL(TARG)) {
2181 LEAVE_SCOPE(oldsave);
2185 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2186 r_flags | REXEC_CHECKED))
2188 if (force_on_match) {
2190 s = SvPV_force(TARG, len);
2193 #ifdef PERL_COPY_ON_WRITE
2196 rxtainted |= RX_MATCH_TAINTED(rx);
2197 dstr = NEWSV(25, len);
2198 sv_setpvn(dstr, m, s-m);
2203 register PERL_CONTEXT *cx;
2207 RETURNOP(cPMOP->op_pmreplroot);
2209 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2211 if (iters++ > maxiters)
2212 DIE(aTHX_ "Substitution loop");
2213 rxtainted |= RX_MATCH_TAINTED(rx);
2214 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2219 strend = s + (strend - m);
2221 m = rx->startp[0] + orig;
2222 if (doutf8 && !SvUTF8(dstr))
2223 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2225 sv_catpvn(dstr, s, m-s);
2226 s = rx->endp[0] + orig;
2228 sv_catpvn(dstr, c, clen);
2231 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2232 TARG, NULL, r_flags));
2233 if (doutf8 && !DO_UTF8(TARG))
2234 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2236 sv_catpvn(dstr, s, strend - s);
2238 #ifdef PERL_COPY_ON_WRITE
2239 /* The match may make the string COW. If so, brilliant, because that's
2240 just saved us one malloc, copy and free - the regexp has donated
2241 the old buffer, and we malloc an entirely new one, rather than the
2242 regexp malloc()ing a buffer and copying our original, only for
2243 us to throw it away here during the substitution. */
2244 if (SvIsCOW(TARG)) {
2245 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2249 (void)SvOOK_off(TARG);
2251 Safefree(SvPVX(TARG));
2253 SvPVX(TARG) = SvPVX(dstr);
2254 SvCUR_set(TARG, SvCUR(dstr));
2255 SvLEN_set(TARG, SvLEN(dstr));
2256 doutf8 |= DO_UTF8(dstr);
2260 TAINT_IF(rxtainted & 1);
2262 PUSHs(sv_2mortal(newSViv((I32)iters)));
2264 (void)SvPOK_only(TARG);
2267 TAINT_IF(rxtainted);
2270 LEAVE_SCOPE(oldsave);
2279 LEAVE_SCOPE(oldsave);
2288 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2289 ++*PL_markstack_ptr;
2290 LEAVE; /* exit inner scope */
2293 if (PL_stack_base + *PL_markstack_ptr > SP) {
2295 I32 gimme = GIMME_V;
2297 LEAVE; /* exit outer scope */
2298 (void)POPMARK; /* pop src */
2299 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2300 (void)POPMARK; /* pop dst */
2301 SP = PL_stack_base + POPMARK; /* pop original mark */
2302 if (gimme == G_SCALAR) {
2303 if (PL_op->op_private & OPpGREP_LEX) {
2304 SV* sv = sv_newmortal();
2305 sv_setiv(sv, items);
2313 else if (gimme == G_ARRAY)
2320 ENTER; /* enter inner scope */
2323 src = PL_stack_base[*PL_markstack_ptr];
2325 if (PL_op->op_private & OPpGREP_LEX)
2326 PAD_SVl(PL_op->op_targ) = src;
2330 RETURNOP(cLOGOP->op_other);
2341 register PERL_CONTEXT *cx;
2345 cxstack_ix++; /* temporarily protect top context */
2348 if (gimme == G_SCALAR) {
2351 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2353 *MARK = SvREFCNT_inc(TOPs);
2358 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2360 *MARK = sv_mortalcopy(sv);
2365 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2369 *MARK = &PL_sv_undef;
2373 else if (gimme == G_ARRAY) {
2374 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2375 if (!SvTEMP(*MARK)) {
2376 *MARK = sv_mortalcopy(*MARK);
2377 TAINT_NOT; /* Each item is independent */
2385 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2386 PL_curpm = newpm; /* ... and pop $1 et al */
2389 return pop_return();
2392 /* This duplicates the above code because the above code must not
2393 * get any slower by more conditions */
2401 register PERL_CONTEXT *cx;
2405 cxstack_ix++; /* temporarily protect top context */
2409 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2410 /* We are an argument to a function or grep().
2411 * This kind of lvalueness was legal before lvalue
2412 * subroutines too, so be backward compatible:
2413 * cannot report errors. */
2415 /* Scalar context *is* possible, on the LHS of -> only,
2416 * as in f()->meth(). But this is not an lvalue. */
2417 if (gimme == G_SCALAR)
2419 if (gimme == G_ARRAY) {
2420 if (!CvLVALUE(cx->blk_sub.cv))
2421 goto temporise_array;
2422 EXTEND_MORTAL(SP - newsp);
2423 for (mark = newsp + 1; mark <= SP; mark++) {
2426 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2427 *mark = sv_mortalcopy(*mark);
2429 /* Can be a localized value subject to deletion. */
2430 PL_tmps_stack[++PL_tmps_ix] = *mark;
2431 (void)SvREFCNT_inc(*mark);
2436 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2437 /* Here we go for robustness, not for speed, so we change all
2438 * the refcounts so the caller gets a live guy. Cannot set
2439 * TEMP, so sv_2mortal is out of question. */
2440 if (!CvLVALUE(cx->blk_sub.cv)) {
2446 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2448 if (gimme == G_SCALAR) {
2452 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2458 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2459 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2460 : "a readonly value" : "a temporary");
2462 else { /* Can be a localized value
2463 * subject to deletion. */
2464 PL_tmps_stack[++PL_tmps_ix] = *mark;
2465 (void)SvREFCNT_inc(*mark);
2468 else { /* Should not happen? */
2474 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2475 (MARK > SP ? "Empty array" : "Array"));
2479 else if (gimme == G_ARRAY) {
2480 EXTEND_MORTAL(SP - newsp);
2481 for (mark = newsp + 1; mark <= SP; mark++) {
2482 if (*mark != &PL_sv_undef
2483 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2484 /* Might be flattened array after $#array = */
2491 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2492 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2495 /* Can be a localized value subject to deletion. */
2496 PL_tmps_stack[++PL_tmps_ix] = *mark;
2497 (void)SvREFCNT_inc(*mark);
2503 if (gimme == G_SCALAR) {
2507 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2509 *MARK = SvREFCNT_inc(TOPs);
2514 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2516 *MARK = sv_mortalcopy(sv);
2521 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2525 *MARK = &PL_sv_undef;
2529 else if (gimme == G_ARRAY) {
2531 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2532 if (!SvTEMP(*MARK)) {
2533 *MARK = sv_mortalcopy(*MARK);
2534 TAINT_NOT; /* Each item is independent */
2543 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2544 PL_curpm = newpm; /* ... and pop $1 et al */
2547 return pop_return();
2552 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2554 SV *dbsv = GvSV(PL_DBsub);
2556 if (!PERLDB_SUB_NN) {
2560 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2561 || strEQ(GvNAME(gv), "END")
2562 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2563 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2564 && (gv = (GV*)*svp) ))) {
2565 /* Use GV from the stack as a fallback. */
2566 /* GV is potentially non-unique, or contain different CV. */
2567 SV *tmp = newRV((SV*)cv);
2568 sv_setsv(dbsv, tmp);
2572 gv_efullname3(dbsv, gv, Nullch);
2576 (void)SvUPGRADE(dbsv, SVt_PVIV);
2577 (void)SvIOK_on(dbsv);
2578 SAVEIV(SvIVX(dbsv));
2579 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2583 PL_curcopdb = PL_curcop;
2584 cv = GvCV(PL_DBsub);
2594 register PERL_CONTEXT *cx;
2596 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2599 DIE(aTHX_ "Not a CODE reference");
2600 switch (SvTYPE(sv)) {
2601 /* This is overwhelming the most common case: */
2603 if (!(cv = GvCVu((GV*)sv)))
2604 cv = sv_2cv(sv, &stash, &gv, FALSE);
2616 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2618 SP = PL_stack_base + POPMARK;
2621 if (SvGMAGICAL(sv)) {
2625 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2628 sym = SvPV(sv, n_a);
2630 DIE(aTHX_ PL_no_usym, "a subroutine");
2631 if (PL_op->op_private & HINT_STRICT_REFS)
2632 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2633 cv = get_cv(sym, TRUE);
2638 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2639 tryAMAGICunDEREF(to_cv);
2642 if (SvTYPE(cv) == SVt_PVCV)
2647 DIE(aTHX_ "Not a CODE reference");
2648 /* This is the second most common case: */
2658 if (!CvROOT(cv) && !CvXSUB(cv)) {
2663 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2664 if (CvASSERTION(cv) && PL_DBassertion)
2665 sv_setiv(PL_DBassertion, 1);
2667 cv = get_db_sub(&sv, cv);
2669 DIE(aTHX_ "No DBsub routine");
2672 if (!(CvXSUB(cv))) {
2673 /* This path taken at least 75% of the time */
2675 register I32 items = SP - MARK;
2676 AV* padlist = CvPADLIST(cv);
2677 push_return(PL_op->op_next);
2678 PUSHBLOCK(cx, CXt_SUB, MARK);
2681 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2682 * that eval'' ops within this sub know the correct lexical space.
2683 * Owing the speed considerations, we choose instead to search for
2684 * the cv using find_runcv() when calling doeval().
2686 if (CvDEPTH(cv) >= 2) {
2687 PERL_STACK_OVERFLOW_CHECK();
2688 pad_push(padlist, CvDEPTH(cv), 1);
2690 PAD_SET_CUR(padlist, CvDEPTH(cv));
2697 DEBUG_S(PerlIO_printf(Perl_debug_log,
2698 "%p entersub preparing @_\n", thr));
2700 av = (AV*)PAD_SVl(0);
2702 /* @_ is normally not REAL--this should only ever
2703 * happen when DB::sub() calls things that modify @_ */
2708 cx->blk_sub.savearray = GvAV(PL_defgv);
2709 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2710 CX_CURPAD_SAVE(cx->blk_sub);
2711 cx->blk_sub.argarray = av;
2714 if (items > AvMAX(av) + 1) {
2716 if (AvARRAY(av) != ary) {
2717 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2718 SvPVX(av) = (char*)ary;
2720 if (items > AvMAX(av) + 1) {
2721 AvMAX(av) = items - 1;
2722 Renew(ary,items,SV*);
2724 SvPVX(av) = (char*)ary;
2727 Copy(MARK,AvARRAY(av),items,SV*);
2728 AvFILLp(av) = items - 1;
2736 /* warning must come *after* we fully set up the context
2737 * stuff so that __WARN__ handlers can safely dounwind()
2740 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2741 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2742 sub_crush_depth(cv);
2744 DEBUG_S(PerlIO_printf(Perl_debug_log,
2745 "%p entersub returning %p\n", thr, CvSTART(cv)));
2747 RETURNOP(CvSTART(cv));
2750 #ifdef PERL_XSUB_OLDSTYLE
2751 if (CvOLDSTYLE(cv)) {
2752 I32 (*fp3)(int,int,int);
2754 register I32 items = SP - MARK;
2755 /* We dont worry to copy from @_. */
2760 PL_stack_sp = mark + 1;
2761 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2762 items = (*fp3)(CvXSUBANY(cv).any_i32,
2763 MARK - PL_stack_base + 1,
2765 PL_stack_sp = PL_stack_base + items;
2768 #endif /* PERL_XSUB_OLDSTYLE */
2770 I32 markix = TOPMARK;
2775 /* Need to copy @_ to stack. Alternative may be to
2776 * switch stack to @_, and copy return values
2777 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2780 av = GvAV(PL_defgv);
2781 items = AvFILLp(av) + 1; /* @_ is not tieable */
2784 /* Mark is at the end of the stack. */
2786 Copy(AvARRAY(av), SP + 1, items, SV*);
2791 /* We assume first XSUB in &DB::sub is the called one. */
2793 SAVEVPTR(PL_curcop);
2794 PL_curcop = PL_curcopdb;
2797 /* Do we need to open block here? XXXX */
2798 (void)(*CvXSUB(cv))(aTHX_ cv);
2800 /* Enforce some sanity in scalar context. */
2801 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2802 if (markix > PL_stack_sp - PL_stack_base)
2803 *(PL_stack_base + markix) = &PL_sv_undef;
2805 *(PL_stack_base + markix) = *PL_stack_sp;
2806 PL_stack_sp = PL_stack_base + markix;
2813 assert (0); /* Cannot get here. */
2814 /* This is deliberately moved here as spaghetti code to keep it out of the
2821 /* anonymous or undef'd function leaves us no recourse */
2822 if (CvANON(cv) || !(gv = CvGV(cv)))
2823 DIE(aTHX_ "Undefined subroutine called");
2825 /* autoloaded stub? */
2826 if (cv != GvCV(gv)) {
2829 /* should call AUTOLOAD now? */
2832 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2839 sub_name = sv_newmortal();
2840 gv_efullname3(sub_name, gv, Nullch);
2841 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2845 DIE(aTHX_ "Not a CODE reference");
2851 Perl_sub_crush_depth(pTHX_ CV *cv)
2854 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2856 SV* tmpstr = sv_newmortal();
2857 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2858 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2868 IV elem = SvIV(elemsv);
2870 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2871 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2874 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2875 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2877 elem -= PL_curcop->cop_arybase;
2878 if (SvTYPE(av) != SVt_PVAV)
2880 svp = av_fetch(av, elem, lval && !defer);
2882 if (!svp || *svp == &PL_sv_undef) {
2885 DIE(aTHX_ PL_no_aelem, elem);
2886 lv = sv_newmortal();
2887 sv_upgrade(lv, SVt_PVLV);
2889 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2890 LvTARG(lv) = SvREFCNT_inc(av);
2891 LvTARGOFF(lv) = elem;
2896 if (PL_op->op_private & OPpLVAL_INTRO)
2897 save_aelem(av, elem, svp);
2898 else if (PL_op->op_private & OPpDEREF)
2899 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2901 sv = (svp ? *svp : &PL_sv_undef);
2902 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2903 sv = sv_mortalcopy(sv);
2909 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2915 Perl_croak(aTHX_ PL_no_modify);
2916 if (SvTYPE(sv) < SVt_RV)
2917 sv_upgrade(sv, SVt_RV);
2918 else if (SvTYPE(sv) >= SVt_PV) {
2919 (void)SvOOK_off(sv);
2920 Safefree(SvPVX(sv));
2921 SvLEN(sv) = SvCUR(sv) = 0;
2925 SvRV(sv) = NEWSV(355,0);
2928 SvRV(sv) = (SV*)newAV();
2931 SvRV(sv) = (SV*)newHV();
2946 if (SvTYPE(rsv) == SVt_PVCV) {
2952 SETs(method_common(sv, Null(U32*)));
2960 U32 hash = SvUVX(sv);
2962 XPUSHs(method_common(sv, &hash));
2967 S_method_common(pTHX_ SV* meth, U32* hashp)
2976 SV *packsv = Nullsv;
2979 name = SvPV(meth, namelen);
2980 sv = *(PL_stack_base + TOPMARK + 1);
2983 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2992 /* this isn't a reference */
2995 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2997 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2999 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3006 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3007 !(ob=(SV*)GvIO(iogv)))
3009 /* this isn't the name of a filehandle either */
3011 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3012 ? !isIDFIRST_utf8((U8*)packname)
3013 : !isIDFIRST(*packname)
3016 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3017 SvOK(sv) ? "without a package or object reference"
3018 : "on an undefined value");
3020 /* assume it's a package name */
3021 stash = gv_stashpvn(packname, packlen, FALSE);
3025 SV* ref = newSViv(PTR2IV(stash));
3026 hv_store(PL_stashcache, packname, packlen, ref, 0);
3030 /* it _is_ a filehandle name -- replace with a reference */
3031 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3034 /* if we got here, ob should be a reference or a glob */
3035 if (!ob || !(SvOBJECT(ob)
3036 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3039 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3043 stash = SvSTASH(ob);
3046 /* NOTE: stash may be null, hope hv_fetch_ent and
3047 gv_fetchmethod can cope (it seems they can) */
3049 /* shortcut for simple names */
3051 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3053 gv = (GV*)HeVAL(he);
3054 if (isGV(gv) && GvCV(gv) &&
3055 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3056 return (SV*)GvCV(gv);
3060 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3063 /* This code tries to figure out just what went wrong with
3064 gv_fetchmethod. It therefore needs to duplicate a lot of
3065 the internals of that function. We can't move it inside
3066 Perl_gv_fetchmethod_autoload(), however, since that would
3067 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3074 for (p = name; *p; p++) {
3076 sep = p, leaf = p + 1;
3077 else if (*p == ':' && *(p + 1) == ':')
3078 sep = p, leaf = p + 2;
3080 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3081 /* the method name is unqualified or starts with SUPER:: */
3082 packname = sep ? CopSTASHPV(PL_curcop) :
3083 stash ? HvNAME(stash) : packname;
3086 "Can't use anonymous symbol table for method lookup");
3088 packlen = strlen(packname);
3091 /* the method name is qualified */
3093 packlen = sep - name;
3096 /* we're relying on gv_fetchmethod not autovivifying the stash */
3097 if (gv_stashpvn(packname, packlen, FALSE)) {
3099 "Can't locate object method \"%s\" via package \"%.*s\"",
3100 leaf, (int)packlen, packname);
3104 "Can't locate object method \"%s\" via package \"%.*s\""
3105 " (perhaps you forgot to load \"%.*s\"?)",
3106 leaf, (int)packlen, packname, (int)packlen, packname);
3109 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;