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
1856 *itersvp = newSVsv(cur);
1857 SvREFCNT_dec(oldsv);
1859 if (strEQ(SvPVX(cur), max))
1860 sv_setiv(cur, 0); /* terminate next time */
1867 /* integer increment */
1868 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1871 /* don't risk potential race */
1872 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1873 /* safe to reuse old SV */
1874 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1878 /* we need a fresh SV every time so that loop body sees a
1879 * completely new SV for closures/references to work as they
1882 *itersvp = newSViv(cx->blk_loop.iterix++);
1883 SvREFCNT_dec(oldsv);
1889 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
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;
1932 *itersvp = SvREFCNT_inc(sv);
1933 SvREFCNT_dec(oldsv);
1941 register PMOP *pm = cPMOP;
1957 register REGEXP *rx = PM_GETRE(pm);
1959 int force_on_match = 0;
1960 I32 oldsave = PL_savestack_ix;
1962 bool doutf8 = FALSE;
1963 #ifdef PERL_COPY_ON_WRITE
1968 /* known replacement string? */
1969 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1970 if (PL_op->op_flags & OPf_STACKED)
1972 else if (PL_op->op_private & OPpTARGET_MY)
1979 #ifdef PERL_COPY_ON_WRITE
1980 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1981 because they make integers such as 256 "false". */
1982 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1985 sv_force_normal_flags(TARG,0);
1988 #ifdef PERL_COPY_ON_WRITE
1992 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1993 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1994 DIE(aTHX_ PL_no_modify);
1997 s = SvPV(TARG, len);
1998 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2000 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2001 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2006 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2010 DIE(aTHX_ "panic: pp_subst");
2013 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2014 maxiters = 2 * slen + 10; /* We can match twice at each
2015 position, once with zero-length,
2016 second time with non-zero. */
2018 if (!rx->prelen && PL_curpm) {
2022 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2023 ? REXEC_COPY_STR : 0;
2025 r_flags |= REXEC_SCREAM;
2026 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
2027 SAVEINT(PL_multiline);
2028 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2031 if (rx->reganch & RE_USE_INTUIT) {
2033 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2037 /* How to do it in subst? */
2038 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2040 && ((rx->reganch & ROPT_NOSCAN)
2041 || !((rx->reganch & RE_INTUIT_TAIL)
2042 && (r_flags & REXEC_SCREAM))))
2047 /* only replace once? */
2048 once = !(rpm->op_pmflags & PMf_GLOBAL);
2050 /* known replacement string? */
2052 /* replacement needing upgrading? */
2053 if (DO_UTF8(TARG) && !doutf8) {
2054 nsv = sv_newmortal();
2057 sv_recode_to_utf8(nsv, PL_encoding);
2059 sv_utf8_upgrade(nsv);
2060 c = SvPV(nsv, clen);
2064 c = SvPV(dstr, clen);
2065 doutf8 = DO_UTF8(dstr);
2073 /* can do inplace substitution? */
2075 #ifdef PERL_COPY_ON_WRITE
2078 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2079 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2080 && (!doutf8 || SvUTF8(TARG))) {
2081 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2082 r_flags | REXEC_CHECKED))
2086 LEAVE_SCOPE(oldsave);
2089 #ifdef PERL_COPY_ON_WRITE
2090 if (SvIsCOW(TARG)) {
2091 assert (!force_on_match);
2095 if (force_on_match) {
2097 s = SvPV_force(TARG, len);
2102 SvSCREAM_off(TARG); /* disable possible screamer */
2104 rxtainted |= RX_MATCH_TAINTED(rx);
2105 m = orig + rx->startp[0];
2106 d = orig + rx->endp[0];
2108 if (m - s > strend - d) { /* faster to shorten from end */
2110 Copy(c, m, clen, char);
2115 Move(d, m, i, char);
2119 SvCUR_set(TARG, m - s);
2122 else if ((i = m - s)) { /* faster from front */
2130 Copy(c, m, clen, char);
2135 Copy(c, d, clen, char);
2140 TAINT_IF(rxtainted & 1);
2146 if (iters++ > maxiters)
2147 DIE(aTHX_ "Substitution loop");
2148 rxtainted |= RX_MATCH_TAINTED(rx);
2149 m = rx->startp[0] + orig;
2153 Move(s, d, i, char);
2157 Copy(c, d, clen, char);
2160 s = rx->endp[0] + orig;
2161 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2163 /* don't match same null twice */
2164 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2167 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2168 Move(s, d, i+1, char); /* include the NUL */
2170 TAINT_IF(rxtainted & 1);
2172 PUSHs(sv_2mortal(newSViv((I32)iters)));
2174 (void)SvPOK_only_UTF8(TARG);
2175 TAINT_IF(rxtainted);
2176 if (SvSMAGICAL(TARG)) {
2184 LEAVE_SCOPE(oldsave);
2188 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2189 r_flags | REXEC_CHECKED))
2191 if (force_on_match) {
2193 s = SvPV_force(TARG, len);
2196 #ifdef PERL_COPY_ON_WRITE
2199 rxtainted |= RX_MATCH_TAINTED(rx);
2200 dstr = NEWSV(25, len);
2201 sv_setpvn(dstr, m, s-m);
2206 register PERL_CONTEXT *cx;
2210 RETURNOP(cPMOP->op_pmreplroot);
2212 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2214 if (iters++ > maxiters)
2215 DIE(aTHX_ "Substitution loop");
2216 rxtainted |= RX_MATCH_TAINTED(rx);
2217 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2222 strend = s + (strend - m);
2224 m = rx->startp[0] + orig;
2225 if (doutf8 && !SvUTF8(dstr))
2226 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2228 sv_catpvn(dstr, s, m-s);
2229 s = rx->endp[0] + orig;
2231 sv_catpvn(dstr, c, clen);
2234 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2235 TARG, NULL, r_flags));
2236 if (doutf8 && !DO_UTF8(TARG))
2237 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2239 sv_catpvn(dstr, s, strend - s);
2241 #ifdef PERL_COPY_ON_WRITE
2242 /* The match may make the string COW. If so, brilliant, because that's
2243 just saved us one malloc, copy and free - the regexp has donated
2244 the old buffer, and we malloc an entirely new one, rather than the
2245 regexp malloc()ing a buffer and copying our original, only for
2246 us to throw it away here during the substitution. */
2247 if (SvIsCOW(TARG)) {
2248 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2252 (void)SvOOK_off(TARG);
2254 Safefree(SvPVX(TARG));
2256 SvPVX(TARG) = SvPVX(dstr);
2257 SvCUR_set(TARG, SvCUR(dstr));
2258 SvLEN_set(TARG, SvLEN(dstr));
2259 doutf8 |= DO_UTF8(dstr);
2263 TAINT_IF(rxtainted & 1);
2265 PUSHs(sv_2mortal(newSViv((I32)iters)));
2267 (void)SvPOK_only(TARG);
2270 TAINT_IF(rxtainted);
2273 LEAVE_SCOPE(oldsave);
2282 LEAVE_SCOPE(oldsave);
2291 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2292 ++*PL_markstack_ptr;
2293 LEAVE; /* exit inner scope */
2296 if (PL_stack_base + *PL_markstack_ptr > SP) {
2298 I32 gimme = GIMME_V;
2300 LEAVE; /* exit outer scope */
2301 (void)POPMARK; /* pop src */
2302 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2303 (void)POPMARK; /* pop dst */
2304 SP = PL_stack_base + POPMARK; /* pop original mark */
2305 if (gimme == G_SCALAR) {
2306 if (PL_op->op_private & OPpGREP_LEX) {
2307 SV* sv = sv_newmortal();
2308 sv_setiv(sv, items);
2316 else if (gimme == G_ARRAY)
2323 ENTER; /* enter inner scope */
2326 src = PL_stack_base[*PL_markstack_ptr];
2328 if (PL_op->op_private & OPpGREP_LEX)
2329 PAD_SVl(PL_op->op_targ) = src;
2333 RETURNOP(cLOGOP->op_other);
2344 register PERL_CONTEXT *cx;
2348 cxstack_ix++; /* temporarily protect top context */
2351 if (gimme == G_SCALAR) {
2354 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2356 *MARK = SvREFCNT_inc(TOPs);
2361 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2363 *MARK = sv_mortalcopy(sv);
2368 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2372 *MARK = &PL_sv_undef;
2376 else if (gimme == G_ARRAY) {
2377 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2378 if (!SvTEMP(*MARK)) {
2379 *MARK = sv_mortalcopy(*MARK);
2380 TAINT_NOT; /* Each item is independent */
2388 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2389 PL_curpm = newpm; /* ... and pop $1 et al */
2392 return pop_return();
2395 /* This duplicates the above code because the above code must not
2396 * get any slower by more conditions */
2404 register PERL_CONTEXT *cx;
2408 cxstack_ix++; /* temporarily protect top context */
2412 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2413 /* We are an argument to a function or grep().
2414 * This kind of lvalueness was legal before lvalue
2415 * subroutines too, so be backward compatible:
2416 * cannot report errors. */
2418 /* Scalar context *is* possible, on the LHS of -> only,
2419 * as in f()->meth(). But this is not an lvalue. */
2420 if (gimme == G_SCALAR)
2422 if (gimme == G_ARRAY) {
2423 if (!CvLVALUE(cx->blk_sub.cv))
2424 goto temporise_array;
2425 EXTEND_MORTAL(SP - newsp);
2426 for (mark = newsp + 1; mark <= SP; mark++) {
2429 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2430 *mark = sv_mortalcopy(*mark);
2432 /* Can be a localized value subject to deletion. */
2433 PL_tmps_stack[++PL_tmps_ix] = *mark;
2434 (void)SvREFCNT_inc(*mark);
2439 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2440 /* Here we go for robustness, not for speed, so we change all
2441 * the refcounts so the caller gets a live guy. Cannot set
2442 * TEMP, so sv_2mortal is out of question. */
2443 if (!CvLVALUE(cx->blk_sub.cv)) {
2449 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2451 if (gimme == G_SCALAR) {
2455 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2461 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2462 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2463 : "a readonly value" : "a temporary");
2465 else { /* Can be a localized value
2466 * subject to deletion. */
2467 PL_tmps_stack[++PL_tmps_ix] = *mark;
2468 (void)SvREFCNT_inc(*mark);
2471 else { /* Should not happen? */
2477 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2478 (MARK > SP ? "Empty array" : "Array"));
2482 else if (gimme == G_ARRAY) {
2483 EXTEND_MORTAL(SP - newsp);
2484 for (mark = newsp + 1; mark <= SP; mark++) {
2485 if (*mark != &PL_sv_undef
2486 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2487 /* Might be flattened array after $#array = */
2494 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2495 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2498 /* Can be a localized value subject to deletion. */
2499 PL_tmps_stack[++PL_tmps_ix] = *mark;
2500 (void)SvREFCNT_inc(*mark);
2506 if (gimme == G_SCALAR) {
2510 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2512 *MARK = SvREFCNT_inc(TOPs);
2517 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2519 *MARK = sv_mortalcopy(sv);
2524 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2528 *MARK = &PL_sv_undef;
2532 else if (gimme == G_ARRAY) {
2534 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2535 if (!SvTEMP(*MARK)) {
2536 *MARK = sv_mortalcopy(*MARK);
2537 TAINT_NOT; /* Each item is independent */
2546 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2547 PL_curpm = newpm; /* ... and pop $1 et al */
2550 return pop_return();
2555 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2557 SV *dbsv = GvSV(PL_DBsub);
2559 if (!PERLDB_SUB_NN) {
2563 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2564 || strEQ(GvNAME(gv), "END")
2565 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2566 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2567 && (gv = (GV*)*svp) ))) {
2568 /* Use GV from the stack as a fallback. */
2569 /* GV is potentially non-unique, or contain different CV. */
2570 SV *tmp = newRV((SV*)cv);
2571 sv_setsv(dbsv, tmp);
2575 gv_efullname3(dbsv, gv, Nullch);
2579 (void)SvUPGRADE(dbsv, SVt_PVIV);
2580 (void)SvIOK_on(dbsv);
2581 SAVEIV(SvIVX(dbsv));
2582 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2586 PL_curcopdb = PL_curcop;
2587 cv = GvCV(PL_DBsub);
2597 register PERL_CONTEXT *cx;
2599 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2602 DIE(aTHX_ "Not a CODE reference");
2603 switch (SvTYPE(sv)) {
2604 /* This is overwhelming the most common case: */
2606 if (!(cv = GvCVu((GV*)sv)))
2607 cv = sv_2cv(sv, &stash, &gv, FALSE);
2619 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2621 SP = PL_stack_base + POPMARK;
2624 if (SvGMAGICAL(sv)) {
2628 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2631 sym = SvPV(sv, n_a);
2633 DIE(aTHX_ PL_no_usym, "a subroutine");
2634 if (PL_op->op_private & HINT_STRICT_REFS)
2635 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2636 cv = get_cv(sym, TRUE);
2641 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2642 tryAMAGICunDEREF(to_cv);
2645 if (SvTYPE(cv) == SVt_PVCV)
2650 DIE(aTHX_ "Not a CODE reference");
2651 /* This is the second most common case: */
2661 if (!CvROOT(cv) && !CvXSUB(cv)) {
2666 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2667 if (CvASSERTION(cv) && PL_DBassertion)
2668 sv_setiv(PL_DBassertion, 1);
2670 cv = get_db_sub(&sv, cv);
2672 DIE(aTHX_ "No DBsub routine");
2675 if (!(CvXSUB(cv))) {
2676 /* This path taken at least 75% of the time */
2678 register I32 items = SP - MARK;
2679 AV* padlist = CvPADLIST(cv);
2680 push_return(PL_op->op_next);
2681 PUSHBLOCK(cx, CXt_SUB, MARK);
2684 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2685 * that eval'' ops within this sub know the correct lexical space.
2686 * Owing the speed considerations, we choose instead to search for
2687 * the cv using find_runcv() when calling doeval().
2689 if (CvDEPTH(cv) >= 2) {
2690 PERL_STACK_OVERFLOW_CHECK();
2691 pad_push(padlist, CvDEPTH(cv), 1);
2693 PAD_SET_CUR(padlist, CvDEPTH(cv));
2700 DEBUG_S(PerlIO_printf(Perl_debug_log,
2701 "%p entersub preparing @_\n", thr));
2703 av = (AV*)PAD_SVl(0);
2705 /* @_ is normally not REAL--this should only ever
2706 * happen when DB::sub() calls things that modify @_ */
2711 cx->blk_sub.savearray = GvAV(PL_defgv);
2712 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2713 CX_CURPAD_SAVE(cx->blk_sub);
2714 cx->blk_sub.argarray = av;
2717 if (items > AvMAX(av) + 1) {
2719 if (AvARRAY(av) != ary) {
2720 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2721 SvPVX(av) = (char*)ary;
2723 if (items > AvMAX(av) + 1) {
2724 AvMAX(av) = items - 1;
2725 Renew(ary,items,SV*);
2727 SvPVX(av) = (char*)ary;
2730 Copy(MARK,AvARRAY(av),items,SV*);
2731 AvFILLp(av) = items - 1;
2739 /* warning must come *after* we fully set up the context
2740 * stuff so that __WARN__ handlers can safely dounwind()
2743 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2744 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2745 sub_crush_depth(cv);
2747 DEBUG_S(PerlIO_printf(Perl_debug_log,
2748 "%p entersub returning %p\n", thr, CvSTART(cv)));
2750 RETURNOP(CvSTART(cv));
2753 #ifdef PERL_XSUB_OLDSTYLE
2754 if (CvOLDSTYLE(cv)) {
2755 I32 (*fp3)(int,int,int);
2757 register I32 items = SP - MARK;
2758 /* We dont worry to copy from @_. */
2763 PL_stack_sp = mark + 1;
2764 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2765 items = (*fp3)(CvXSUBANY(cv).any_i32,
2766 MARK - PL_stack_base + 1,
2768 PL_stack_sp = PL_stack_base + items;
2771 #endif /* PERL_XSUB_OLDSTYLE */
2773 I32 markix = TOPMARK;
2778 /* Need to copy @_ to stack. Alternative may be to
2779 * switch stack to @_, and copy return values
2780 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2783 av = GvAV(PL_defgv);
2784 items = AvFILLp(av) + 1; /* @_ is not tieable */
2787 /* Mark is at the end of the stack. */
2789 Copy(AvARRAY(av), SP + 1, items, SV*);
2794 /* We assume first XSUB in &DB::sub is the called one. */
2796 SAVEVPTR(PL_curcop);
2797 PL_curcop = PL_curcopdb;
2800 /* Do we need to open block here? XXXX */
2801 (void)(*CvXSUB(cv))(aTHX_ cv);
2803 /* Enforce some sanity in scalar context. */
2804 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2805 if (markix > PL_stack_sp - PL_stack_base)
2806 *(PL_stack_base + markix) = &PL_sv_undef;
2808 *(PL_stack_base + markix) = *PL_stack_sp;
2809 PL_stack_sp = PL_stack_base + markix;
2816 assert (0); /* Cannot get here. */
2817 /* This is deliberately moved here as spaghetti code to keep it out of the
2824 /* anonymous or undef'd function leaves us no recourse */
2825 if (CvANON(cv) || !(gv = CvGV(cv)))
2826 DIE(aTHX_ "Undefined subroutine called");
2828 /* autoloaded stub? */
2829 if (cv != GvCV(gv)) {
2832 /* should call AUTOLOAD now? */
2835 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2842 sub_name = sv_newmortal();
2843 gv_efullname3(sub_name, gv, Nullch);
2844 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2848 DIE(aTHX_ "Not a CODE reference");
2854 Perl_sub_crush_depth(pTHX_ CV *cv)
2857 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2859 SV* tmpstr = sv_newmortal();
2860 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2861 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2871 IV elem = SvIV(elemsv);
2873 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2874 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2877 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2878 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2880 elem -= PL_curcop->cop_arybase;
2881 if (SvTYPE(av) != SVt_PVAV)
2883 svp = av_fetch(av, elem, lval && !defer);
2885 #ifdef PERL_MALLOC_WRAP
2886 static const char oom_array_extend[] =
2887 "Out of memory during array extend"; /* Duplicated in av.c */
2888 if (SvUOK(elemsv)) {
2889 UV uv = SvUV(elemsv);
2890 elem = uv > IV_MAX ? IV_MAX : uv;
2892 else if (SvNOK(elemsv))
2893 elem = (IV)SvNV(elemsv);
2895 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2897 if (!svp || *svp == &PL_sv_undef) {
2900 DIE(aTHX_ PL_no_aelem, elem);
2901 lv = sv_newmortal();
2902 sv_upgrade(lv, SVt_PVLV);
2904 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2905 LvTARG(lv) = SvREFCNT_inc(av);
2906 LvTARGOFF(lv) = elem;
2911 if (PL_op->op_private & OPpLVAL_INTRO)
2912 save_aelem(av, elem, svp);
2913 else if (PL_op->op_private & OPpDEREF)
2914 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2916 sv = (svp ? *svp : &PL_sv_undef);
2917 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2918 sv = sv_mortalcopy(sv);
2924 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2930 Perl_croak(aTHX_ PL_no_modify);
2931 if (SvTYPE(sv) < SVt_RV)
2932 sv_upgrade(sv, SVt_RV);
2933 else if (SvTYPE(sv) >= SVt_PV) {
2934 (void)SvOOK_off(sv);
2935 Safefree(SvPVX(sv));
2936 SvLEN(sv) = SvCUR(sv) = 0;
2940 SvRV(sv) = NEWSV(355,0);
2943 SvRV(sv) = (SV*)newAV();
2946 SvRV(sv) = (SV*)newHV();
2961 if (SvTYPE(rsv) == SVt_PVCV) {
2967 SETs(method_common(sv, Null(U32*)));
2975 U32 hash = SvUVX(sv);
2977 XPUSHs(method_common(sv, &hash));
2982 S_method_common(pTHX_ SV* meth, U32* hashp)
2991 SV *packsv = Nullsv;
2994 name = SvPV(meth, namelen);
2995 sv = *(PL_stack_base + TOPMARK + 1);
2998 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3007 /* this isn't a reference */
3010 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3012 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3014 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3021 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3022 !(ob=(SV*)GvIO(iogv)))
3024 /* this isn't the name of a filehandle either */
3026 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3027 ? !isIDFIRST_utf8((U8*)packname)
3028 : !isIDFIRST(*packname)
3031 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3032 SvOK(sv) ? "without a package or object reference"
3033 : "on an undefined value");
3035 /* assume it's a package name */
3036 stash = gv_stashpvn(packname, packlen, FALSE);
3040 SV* ref = newSViv(PTR2IV(stash));
3041 hv_store(PL_stashcache, packname, packlen, ref, 0);
3045 /* it _is_ a filehandle name -- replace with a reference */
3046 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3049 /* if we got here, ob should be a reference or a glob */
3050 if (!ob || !(SvOBJECT(ob)
3051 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3054 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3058 stash = SvSTASH(ob);
3061 /* NOTE: stash may be null, hope hv_fetch_ent and
3062 gv_fetchmethod can cope (it seems they can) */
3064 /* shortcut for simple names */
3066 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3068 gv = (GV*)HeVAL(he);
3069 if (isGV(gv) && GvCV(gv) &&
3070 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3071 return (SV*)GvCV(gv);
3075 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3078 /* This code tries to figure out just what went wrong with
3079 gv_fetchmethod. It therefore needs to duplicate a lot of
3080 the internals of that function. We can't move it inside
3081 Perl_gv_fetchmethod_autoload(), however, since that would
3082 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3089 for (p = name; *p; p++) {
3091 sep = p, leaf = p + 1;
3092 else if (*p == ':' && *(p + 1) == ':')
3093 sep = p, leaf = p + 2;
3095 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3096 /* the method name is unqualified or starts with SUPER:: */
3097 packname = sep ? CopSTASHPV(PL_curcop) :
3098 stash ? HvNAME(stash) : packname;
3101 "Can't use anonymous symbol table for method lookup");
3103 packlen = strlen(packname);
3106 /* the method name is qualified */
3108 packlen = sep - name;
3111 /* we're relying on gv_fetchmethod not autovivifying the stash */
3112 if (gv_stashpvn(packname, packlen, FALSE)) {
3114 "Can't locate object method \"%s\" via package \"%.*s\"",
3115 leaf, (int)packlen, packname);
3119 "Can't locate object method \"%s\" via package \"%.*s\""
3120 " (perhaps you forgot to load \"%.*s\"?)",
3121 leaf, (int)packlen, packname, (int)packlen, packname);
3124 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;