3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
20 #define PERL_IN_PP_HOT_C
34 PL_curcop = (COP*)PL_op;
35 TAINT_NOT; /* Each statement is presumed innocent */
36 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
45 if (PL_op->op_private & OPpLVAL_INTRO)
46 PUSHs(save_scalar(cGVOP_gv));
48 PUSHs(GvSV(cGVOP_gv));
59 PL_curcop = (COP*)PL_op;
65 PUSHMARK(PL_stack_sp);
80 XPUSHs((SV*)cGVOP_gv);
91 RETURNOP(cLOGOP->op_other);
99 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
101 temp = left; left = right; right = temp;
103 if (PL_tainting && PL_tainted && !SvTAINTED(left))
105 SvSetMagicSV(right, left);
114 RETURNOP(cLOGOP->op_other);
116 RETURNOP(cLOGOP->op_next);
122 TAINT_NOT; /* Each statement is presumed innocent */
123 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
125 oldsave = PL_scopestack[PL_scopestack_ix - 1];
126 LEAVE_SCOPE(oldsave);
132 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
139 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
140 bool rbyte = !SvUTF8(right), rcopied = FALSE;
142 if (TARG == right && right != left) {
143 right = sv_2mortal(newSVpvn(rpv, rlen));
144 rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
149 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
150 lbyte = !SvUTF8(left);
151 sv_setpvn(TARG, lpv, llen);
157 else { /* TARG == left */
158 if (SvGMAGICAL(left))
159 mg_get(left); /* or mg_get(left) may happen here */
162 lpv = SvPV_nomg(left, llen);
163 lbyte = !SvUTF8(left);
166 #if defined(PERL_Y2KWARN)
167 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
168 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
169 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
171 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
172 "about to append an integer to '19'");
177 if (lbyte != rbyte) {
179 sv_utf8_upgrade_nomg(TARG);
182 right = sv_2mortal(newSVpvn(rpv, rlen));
183 sv_utf8_upgrade_nomg(right);
184 rpv = SvPV(right, rlen);
187 sv_catpvn_nomg(TARG, rpv, rlen);
198 if (PL_op->op_flags & OPf_MOD) {
199 if (PL_op->op_private & OPpLVAL_INTRO)
200 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
201 else if (PL_op->op_private & OPpDEREF) {
203 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
212 tryAMAGICunTARGET(iter, 0);
213 PL_last_in_gv = (GV*)(*PL_stack_sp--);
214 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
215 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
216 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
219 XPUSHs((SV*)PL_last_in_gv);
222 PL_last_in_gv = (GV*)(*PL_stack_sp--);
225 return do_readline();
230 dSP; tryAMAGICbinSET(eq,0);
231 #ifndef NV_PRESERVES_UV
232 if (SvROK(TOPs) && SvROK(TOPm1s)) {
234 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
238 #ifdef PERL_PRESERVE_IVUV
241 /* Unless the left argument is integer in range we are going
242 to have to use NV maths. Hence only attempt to coerce the
243 right argument if we know the left is integer. */
246 bool auvok = SvUOK(TOPm1s);
247 bool buvok = SvUOK(TOPs);
249 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
250 /* Casting IV to UV before comparison isn't going to matter
251 on 2s complement. On 1s complement or sign&magnitude
252 (if we have any of them) it could to make negative zero
253 differ from normal zero. As I understand it. (Need to
254 check - is negative zero implementation defined behaviour
256 UV buv = SvUVX(POPs);
257 UV auv = SvUVX(TOPs);
259 SETs(boolSV(auv == buv));
262 { /* ## Mixed IV,UV ## */
266 /* == is commutative so doesn't matter which is left or right */
268 /* top of stack (b) is the iv */
277 /* As uv is a UV, it's >0, so it cannot be == */
281 /* we know iv is >= 0 */
282 SETs(boolSV((UV)iv == SvUVX(uvp)));
290 SETs(boolSV(TOPn == value));
298 if (SvTYPE(TOPs) > SVt_PVLV)
299 DIE(aTHX_ PL_no_modify);
300 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
301 && SvIVX(TOPs) != IV_MAX)
304 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
306 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
319 RETURNOP(cLOGOP->op_other);
325 /* Most of this is lifted straight from pp_defined */
330 if (!sv || !SvANY(sv)) {
332 RETURNOP(cLOGOP->op_other);
335 switch (SvTYPE(sv)) {
337 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
341 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
345 if (CvROOT(sv) || CvXSUB(sv))
356 RETURNOP(cLOGOP->op_other);
361 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
362 useleft = USE_LEFT(TOPm1s);
363 #ifdef PERL_PRESERVE_IVUV
364 /* We must see if we can perform the addition with integers if possible,
365 as the integer code detects overflow while the NV code doesn't.
366 If either argument hasn't had a numeric conversion yet attempt to get
367 the IV. It's important to do this now, rather than just assuming that
368 it's not IOK as a PV of "9223372036854775806" may not take well to NV
369 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
370 integer in case the second argument is IV=9223372036854775806
371 We can (now) rely on sv_2iv to do the right thing, only setting the
372 public IOK flag if the value in the NV (or PV) slot is truly integer.
374 A side effect is that this also aggressively prefers integer maths over
375 fp maths for integer values.
377 How to detect overflow?
379 C 99 section 6.2.6.1 says
381 The range of nonnegative values of a signed integer type is a subrange
382 of the corresponding unsigned integer type, and the representation of
383 the same value in each type is the same. A computation involving
384 unsigned operands can never overflow, because a result that cannot be
385 represented by the resulting unsigned integer type is reduced modulo
386 the number that is one greater than the largest value that can be
387 represented by the resulting type.
391 which I read as "unsigned ints wrap."
393 signed integer overflow seems to be classed as "exception condition"
395 If an exceptional condition occurs during the evaluation of an
396 expression (that is, if the result is not mathematically defined or not
397 in the range of representable values for its type), the behavior is
400 (6.5, the 5th paragraph)
402 I had assumed that on 2s complement machines signed arithmetic would
403 wrap, hence coded pp_add and pp_subtract on the assumption that
404 everything perl builds on would be happy. After much wailing and
405 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
406 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
407 unsigned code below is actually shorter than the old code. :-)
412 /* Unless the left argument is integer in range we are going to have to
413 use NV maths. Hence only attempt to coerce the right argument if
414 we know the left is integer. */
422 /* left operand is undef, treat as zero. + 0 is identity,
423 Could SETi or SETu right now, but space optimise by not adding
424 lots of code to speed up what is probably a rarish case. */
426 /* Left operand is defined, so is it IV? */
429 if ((auvok = SvUOK(TOPm1s)))
432 register IV aiv = SvIVX(TOPm1s);
435 auvok = 1; /* Now acting as a sign flag. */
436 } else { /* 2s complement assumption for IV_MIN */
444 bool result_good = 0;
447 bool buvok = SvUOK(TOPs);
452 register IV biv = SvIVX(TOPs);
459 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
460 else "IV" now, independent of how it came in.
461 if a, b represents positive, A, B negative, a maps to -A etc
466 all UV maths. negate result if A negative.
467 add if signs same, subtract if signs differ. */
473 /* Must get smaller */
479 /* result really should be -(auv-buv). as its negation
480 of true value, need to swap our result flag */
497 if (result <= (UV)IV_MIN)
500 /* result valid, but out of range for IV. */
505 } /* Overflow, drop through to NVs. */
512 /* left operand is undef, treat as zero. + 0.0 is identity. */
516 SETn( value + TOPn );
524 AV *av = GvAV(cGVOP_gv);
525 U32 lval = PL_op->op_flags & OPf_MOD;
526 SV** svp = av_fetch(av, PL_op->op_private, lval);
527 SV *sv = (svp ? *svp : &PL_sv_undef);
529 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
530 sv = sv_mortalcopy(sv);
539 do_join(TARG, *MARK, MARK, SP);
550 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
551 * will be enough to hold an OP*.
553 SV* sv = sv_newmortal();
554 sv_upgrade(sv, SVt_PVLV);
556 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
564 /* Oversized hot code. */
568 dSP; dMARK; dORIGMARK;
574 if (PL_op->op_flags & OPf_STACKED)
579 if (gv && (io = GvIO(gv))
580 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
583 if (MARK == ORIGMARK) {
584 /* If using default handle then we need to make space to
585 * pass object as 1st arg, so move other args up ...
589 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
593 *MARK = SvTIED_obj((SV*)io, mg);
596 call_method("PRINT", G_SCALAR);
604 if (!(io = GvIO(gv))) {
605 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
606 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
608 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
609 report_evil_fh(gv, io, PL_op->op_type);
610 SETERRNO(EBADF,RMS_IFI);
613 else if (!(fp = IoOFP(io))) {
614 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
616 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
617 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
618 report_evil_fh(gv, io, PL_op->op_type);
620 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
625 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
627 if (!do_print(*MARK, fp))
631 if (!do_print(PL_ofs_sv, fp)) { /* $, */
640 if (!do_print(*MARK, fp))
648 if (PL_ors_sv && SvOK(PL_ors_sv))
649 if (!do_print(PL_ors_sv, fp)) /* $\ */
652 if (IoFLAGS(io) & IOf_FLUSH)
653 if (PerlIO_flush(fp) == EOF)
674 tryAMAGICunDEREF(to_av);
677 if (SvTYPE(av) != SVt_PVAV)
678 DIE(aTHX_ "Not an ARRAY reference");
679 if (PL_op->op_flags & OPf_REF) {
684 if (GIMME == G_SCALAR)
685 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
689 else if (PL_op->op_flags & OPf_MOD
690 && PL_op->op_private & OPpLVAL_INTRO)
691 Perl_croak(aTHX_ PL_no_localize_ref);
694 if (SvTYPE(sv) == SVt_PVAV) {
696 if (PL_op->op_flags & OPf_REF) {
701 if (GIMME == G_SCALAR)
702 Perl_croak(aTHX_ "Can't return array to lvalue"
711 if (SvTYPE(sv) != SVt_PVGV) {
715 if (SvGMAGICAL(sv)) {
721 if (PL_op->op_flags & OPf_REF ||
722 PL_op->op_private & HINT_STRICT_REFS)
723 DIE(aTHX_ PL_no_usym, "an ARRAY");
724 if (ckWARN(WARN_UNINITIALIZED))
726 if (GIMME == G_ARRAY) {
733 if ((PL_op->op_flags & OPf_SPECIAL) &&
734 !(PL_op->op_flags & OPf_MOD))
736 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
738 && (!is_gv_magical(sym,len,0)
739 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
745 if (PL_op->op_private & HINT_STRICT_REFS)
746 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
747 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
754 if (PL_op->op_private & OPpLVAL_INTRO)
756 if (PL_op->op_flags & OPf_REF) {
761 if (GIMME == G_SCALAR)
762 Perl_croak(aTHX_ "Can't return array to lvalue"
770 if (GIMME == G_ARRAY) {
771 I32 maxarg = AvFILL(av) + 1;
772 (void)POPs; /* XXXX May be optimized away? */
774 if (SvRMAGICAL(av)) {
776 for (i=0; i < (U32)maxarg; i++) {
777 SV **svp = av_fetch(av, i, FALSE);
778 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
782 Copy(AvARRAY(av), SP+1, maxarg, SV*);
786 else if (GIMME_V == G_SCALAR) {
788 I32 maxarg = AvFILL(av) + 1;
802 tryAMAGICunDEREF(to_hv);
805 if (SvTYPE(hv) != SVt_PVHV)
806 DIE(aTHX_ "Not a HASH reference");
807 if (PL_op->op_flags & OPf_REF) {
812 if (gimme != G_ARRAY)
813 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
817 else if (PL_op->op_flags & OPf_MOD
818 && PL_op->op_private & OPpLVAL_INTRO)
819 Perl_croak(aTHX_ PL_no_localize_ref);
822 if (SvTYPE(sv) == SVt_PVHV) {
824 if (PL_op->op_flags & OPf_REF) {
829 if (gimme != G_ARRAY)
830 Perl_croak(aTHX_ "Can't return hash to lvalue"
839 if (SvTYPE(sv) != SVt_PVGV) {
843 if (SvGMAGICAL(sv)) {
849 if (PL_op->op_flags & OPf_REF ||
850 PL_op->op_private & HINT_STRICT_REFS)
851 DIE(aTHX_ PL_no_usym, "a HASH");
852 if (ckWARN(WARN_UNINITIALIZED))
854 if (gimme == G_ARRAY) {
861 if ((PL_op->op_flags & OPf_SPECIAL) &&
862 !(PL_op->op_flags & OPf_MOD))
864 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
866 && (!is_gv_magical(sym,len,0)
867 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
873 if (PL_op->op_private & HINT_STRICT_REFS)
874 DIE(aTHX_ PL_no_symref, sym, "a HASH");
875 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
882 if (PL_op->op_private & OPpLVAL_INTRO)
884 if (PL_op->op_flags & OPf_REF) {
889 if (gimme != G_ARRAY)
890 Perl_croak(aTHX_ "Can't return hash to lvalue"
898 if (gimme == G_ARRAY) { /* array wanted */
899 *PL_stack_sp = (SV*)hv;
902 else if (gimme == G_SCALAR) {
904 if (SvRMAGICAL(hv) && mg_find((SV *)hv, PERL_MAGIC_tied))
905 Perl_croak(aTHX_ "Can't provide tied hash usage; "
906 "use keys(%%hash) to test if empty");
908 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
909 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
919 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
925 if (ckWARN(WARN_MISC)) {
926 if (relem == firstrelem &&
928 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
929 SvTYPE(SvRV(*relem)) == SVt_PVHV))
931 Perl_warner(aTHX_ packWARN(WARN_MISC),
932 "Reference found where even-sized list expected");
935 Perl_warner(aTHX_ packWARN(WARN_MISC),
936 "Odd number of elements in hash assignment");
939 tmpstr = NEWSV(29,0);
940 didstore = hv_store_ent(hash,*relem,tmpstr,0);
941 if (SvMAGICAL(hash)) {
942 if (SvSMAGICAL(tmpstr))
954 SV **lastlelem = PL_stack_sp;
955 SV **lastrelem = PL_stack_base + POPMARK;
956 SV **firstrelem = PL_stack_base + POPMARK + 1;
957 SV **firstlelem = lastrelem + 1;
970 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
972 /* If there's a common identifier on both sides we have to take
973 * special care that assigning the identifier on the left doesn't
974 * clobber a value on the right that's used later in the list.
976 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
977 EXTEND_MORTAL(lastrelem - firstrelem + 1);
978 for (relem = firstrelem; relem <= lastrelem; relem++) {
981 TAINT_NOT; /* Each item is independent */
982 *relem = sv_mortalcopy(sv);
992 while (lelem <= lastlelem) {
993 TAINT_NOT; /* Each item stands on its own, taintwise. */
995 switch (SvTYPE(sv)) {
998 magic = SvMAGICAL(ary) != 0;
1000 av_extend(ary, lastrelem - relem);
1002 while (relem <= lastrelem) { /* gobble up all the rest */
1006 sv_setsv(sv,*relem);
1008 didstore = av_store(ary,i++,sv);
1018 case SVt_PVHV: { /* normal hash */
1022 magic = SvMAGICAL(hash) != 0;
1025 while (relem < lastrelem) { /* gobble up all the rest */
1030 sv = &PL_sv_no, relem++;
1031 tmpstr = NEWSV(29,0);
1033 sv_setsv(tmpstr,*relem); /* value */
1034 *(relem++) = tmpstr;
1035 didstore = hv_store_ent(hash,sv,tmpstr,0);
1037 if (SvSMAGICAL(tmpstr))
1044 if (relem == lastrelem) {
1045 do_oddball(hash, relem, firstrelem);
1051 if (SvIMMORTAL(sv)) {
1052 if (relem <= lastrelem)
1056 if (relem <= lastrelem) {
1057 sv_setsv(sv, *relem);
1061 sv_setsv(sv, &PL_sv_undef);
1066 if (PL_delaymagic & ~DM_DELAY) {
1067 if (PL_delaymagic & DM_UID) {
1068 #ifdef HAS_SETRESUID
1069 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1071 # ifdef HAS_SETREUID
1072 (void)setreuid(PL_uid,PL_euid);
1075 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1076 (void)setruid(PL_uid);
1077 PL_delaymagic &= ~DM_RUID;
1079 # endif /* HAS_SETRUID */
1081 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1082 (void)seteuid(PL_uid);
1083 PL_delaymagic &= ~DM_EUID;
1085 # endif /* HAS_SETEUID */
1086 if (PL_delaymagic & DM_UID) {
1087 if (PL_uid != PL_euid)
1088 DIE(aTHX_ "No setreuid available");
1089 (void)PerlProc_setuid(PL_uid);
1091 # endif /* HAS_SETREUID */
1092 #endif /* HAS_SETRESUID */
1093 PL_uid = PerlProc_getuid();
1094 PL_euid = PerlProc_geteuid();
1096 if (PL_delaymagic & DM_GID) {
1097 #ifdef HAS_SETRESGID
1098 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1100 # ifdef HAS_SETREGID
1101 (void)setregid(PL_gid,PL_egid);
1104 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1105 (void)setrgid(PL_gid);
1106 PL_delaymagic &= ~DM_RGID;
1108 # endif /* HAS_SETRGID */
1110 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1111 (void)setegid(PL_gid);
1112 PL_delaymagic &= ~DM_EGID;
1114 # endif /* HAS_SETEGID */
1115 if (PL_delaymagic & DM_GID) {
1116 if (PL_gid != PL_egid)
1117 DIE(aTHX_ "No setregid available");
1118 (void)PerlProc_setgid(PL_gid);
1120 # endif /* HAS_SETREGID */
1121 #endif /* HAS_SETRESGID */
1122 PL_gid = PerlProc_getgid();
1123 PL_egid = PerlProc_getegid();
1125 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1130 if (gimme == G_VOID)
1131 SP = firstrelem - 1;
1132 else if (gimme == G_SCALAR) {
1135 SETi(lastrelem - firstrelem + 1);
1141 SP = firstrelem + (lastlelem - firstlelem);
1142 lelem = firstlelem + (relem - firstrelem);
1144 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1152 register PMOP *pm = cPMOP;
1153 SV *rv = sv_newmortal();
1154 SV *sv = newSVrv(rv, "Regexp");
1155 if (pm->op_pmdynflags & PMdf_TAINTED)
1157 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1164 register PMOP *pm = cPMOP;
1170 I32 r_flags = REXEC_CHECKED;
1171 char *truebase; /* Start of string */
1172 register REGEXP *rx = PM_GETRE(pm);
1177 I32 oldsave = PL_savestack_ix;
1178 I32 update_minmatch = 1;
1179 I32 had_zerolen = 0;
1181 if (PL_op->op_flags & OPf_STACKED)
1188 PUTBACK; /* EVAL blocks need stack_sp. */
1189 s = SvPV(TARG, len);
1192 DIE(aTHX_ "panic: pp_match");
1193 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1194 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1197 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1199 /* PMdf_USED is set after a ?? matches once */
1200 if (pm->op_pmdynflags & PMdf_USED) {
1202 if (gimme == G_ARRAY)
1207 /* empty pattern special-cased to use last successful pattern if possible */
1208 if (!rx->prelen && PL_curpm) {
1213 if (rx->minlen > (I32)len)
1218 /* XXXX What part of this is needed with true \G-support? */
1219 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1221 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1222 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1223 if (mg && mg->mg_len >= 0) {
1224 if (!(rx->reganch & ROPT_GPOS_SEEN))
1225 rx->endp[0] = rx->startp[0] = mg->mg_len;
1226 else if (rx->reganch & ROPT_ANCH_GPOS) {
1227 r_flags |= REXEC_IGNOREPOS;
1228 rx->endp[0] = rx->startp[0] = mg->mg_len;
1230 minmatch = (mg->mg_flags & MGf_MINMATCH);
1231 update_minmatch = 0;
1235 if ((!global && rx->nparens)
1236 || SvTEMP(TARG) || PL_sawampersand)
1237 r_flags |= REXEC_COPY_STR;
1239 r_flags |= REXEC_SCREAM;
1241 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1242 SAVEINT(PL_multiline);
1243 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1247 if (global && rx->startp[0] != -1) {
1248 t = s = rx->endp[0] + truebase;
1249 if ((s + rx->minlen) > strend)
1251 if (update_minmatch++)
1252 minmatch = had_zerolen;
1254 if (rx->reganch & RE_USE_INTUIT &&
1255 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1256 PL_bostr = truebase;
1257 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1261 if ( (rx->reganch & ROPT_CHECK_ALL)
1263 && ((rx->reganch & ROPT_NOSCAN)
1264 || !((rx->reganch & RE_INTUIT_TAIL)
1265 && (r_flags & REXEC_SCREAM)))
1266 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1269 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1272 if (dynpm->op_pmflags & PMf_ONCE)
1273 dynpm->op_pmdynflags |= PMdf_USED;
1282 RX_MATCH_TAINTED_on(rx);
1283 TAINT_IF(RX_MATCH_TAINTED(rx));
1284 if (gimme == G_ARRAY) {
1285 I32 nparens, i, len;
1287 nparens = rx->nparens;
1288 if (global && !nparens)
1292 SPAGAIN; /* EVAL blocks could move the stack. */
1293 EXTEND(SP, nparens + i);
1294 EXTEND_MORTAL(nparens + i);
1295 for (i = !i; i <= nparens; i++) {
1296 PUSHs(sv_newmortal());
1298 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1299 len = rx->endp[i] - rx->startp[i];
1300 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1301 len < 0 || len > strend - s)
1302 DIE(aTHX_ "panic: pp_match start/end pointers");
1303 s = rx->startp[i] + truebase;
1304 sv_setpvn(*SP, s, len);
1305 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1310 if (dynpm->op_pmflags & PMf_CONTINUE) {
1312 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1313 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1315 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1316 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1318 if (rx->startp[0] != -1) {
1319 mg->mg_len = rx->endp[0];
1320 if (rx->startp[0] == rx->endp[0])
1321 mg->mg_flags |= MGf_MINMATCH;
1323 mg->mg_flags &= ~MGf_MINMATCH;
1326 had_zerolen = (rx->startp[0] != -1
1327 && rx->startp[0] == rx->endp[0]);
1328 PUTBACK; /* EVAL blocks may use stack */
1329 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1334 LEAVE_SCOPE(oldsave);
1340 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1341 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1343 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1344 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1346 if (rx->startp[0] != -1) {
1347 mg->mg_len = rx->endp[0];
1348 if (rx->startp[0] == rx->endp[0])
1349 mg->mg_flags |= MGf_MINMATCH;
1351 mg->mg_flags &= ~MGf_MINMATCH;
1354 LEAVE_SCOPE(oldsave);
1358 yup: /* Confirmed by INTUIT */
1360 RX_MATCH_TAINTED_on(rx);
1361 TAINT_IF(RX_MATCH_TAINTED(rx));
1363 if (dynpm->op_pmflags & PMf_ONCE)
1364 dynpm->op_pmdynflags |= PMdf_USED;
1365 if (RX_MATCH_COPIED(rx))
1366 Safefree(rx->subbeg);
1367 RX_MATCH_COPIED_off(rx);
1368 rx->subbeg = Nullch;
1370 rx->subbeg = truebase;
1371 rx->startp[0] = s - truebase;
1372 if (RX_MATCH_UTF8(rx)) {
1373 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1374 rx->endp[0] = t - truebase;
1377 rx->endp[0] = s - truebase + rx->minlen;
1379 rx->sublen = strend - truebase;
1382 if (PL_sawampersand) {
1384 #ifdef PERL_COPY_ON_WRITE
1385 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1387 PerlIO_printf(Perl_debug_log,
1388 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1389 (int) SvTYPE(TARG), truebase, t,
1392 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1393 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1394 assert (SvPOKp(rx->saved_copy));
1399 rx->subbeg = savepvn(t, strend - t);
1400 #ifdef PERL_COPY_ON_WRITE
1401 rx->saved_copy = Nullsv;
1404 rx->sublen = strend - t;
1405 RX_MATCH_COPIED_on(rx);
1406 off = rx->startp[0] = s - t;
1407 rx->endp[0] = off + rx->minlen;
1409 else { /* startp/endp are used by @- @+. */
1410 rx->startp[0] = s - truebase;
1411 rx->endp[0] = s - truebase + rx->minlen;
1413 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1414 LEAVE_SCOPE(oldsave);
1419 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1420 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1421 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1426 LEAVE_SCOPE(oldsave);
1427 if (gimme == G_ARRAY)
1433 Perl_do_readline(pTHX)
1435 dSP; dTARGETSTACKED;
1440 register IO *io = GvIO(PL_last_in_gv);
1441 register I32 type = PL_op->op_type;
1442 I32 gimme = GIMME_V;
1445 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1447 XPUSHs(SvTIED_obj((SV*)io, mg));
1450 call_method("READLINE", gimme);
1453 if (gimme == G_SCALAR) {
1455 SvSetSV_nosteal(TARG, result);
1464 if (IoFLAGS(io) & IOf_ARGV) {
1465 if (IoFLAGS(io) & IOf_START) {
1467 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1468 IoFLAGS(io) &= ~IOf_START;
1469 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1470 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1471 SvSETMAGIC(GvSV(PL_last_in_gv));
1476 fp = nextargv(PL_last_in_gv);
1477 if (!fp) { /* Note: fp != IoIFP(io) */
1478 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1481 else if (type == OP_GLOB)
1482 fp = Perl_start_glob(aTHX_ POPs, io);
1484 else if (type == OP_GLOB)
1486 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1487 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1491 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1492 && (!io || !(IoFLAGS(io) & IOf_START))) {
1493 if (type == OP_GLOB)
1494 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1495 "glob failed (can't start child: %s)",
1498 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1500 if (gimme == G_SCALAR) {
1501 /* undef TARG, and push that undefined value */
1502 if (type != OP_RCATLINE) {
1503 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1504 (void)SvOK_off(TARG);
1511 if (gimme == G_SCALAR) {
1515 (void)SvUPGRADE(sv, SVt_PV);
1516 tmplen = SvLEN(sv); /* remember if already alloced */
1517 if (!tmplen && !SvREADONLY(sv))
1518 Sv_Grow(sv, 80); /* try short-buffering it */
1520 if (type == OP_RCATLINE && SvOK(sv)) {
1523 (void)SvPV_force(sv, n_a);
1529 sv = sv_2mortal(NEWSV(57, 80));
1533 /* This should not be marked tainted if the fp is marked clean */
1534 #define MAYBE_TAINT_LINE(io, sv) \
1535 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1540 /* delay EOF state for a snarfed empty file */
1541 #define SNARF_EOF(gimme,rs,io,sv) \
1542 (gimme != G_SCALAR || SvCUR(sv) \
1543 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1547 if (!sv_gets(sv, fp, offset)
1548 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1550 PerlIO_clearerr(fp);
1551 if (IoFLAGS(io) & IOf_ARGV) {
1552 fp = nextargv(PL_last_in_gv);
1555 (void)do_close(PL_last_in_gv, FALSE);
1557 else if (type == OP_GLOB) {
1558 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1559 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1560 "glob failed (child exited with status %d%s)",
1561 (int)(STATUS_CURRENT >> 8),
1562 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1565 if (gimme == G_SCALAR) {
1566 if (type != OP_RCATLINE) {
1567 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1568 (void)SvOK_off(TARG);
1573 MAYBE_TAINT_LINE(io, sv);
1576 MAYBE_TAINT_LINE(io, sv);
1578 IoFLAGS(io) |= IOf_NOLINE;
1582 if (type == OP_GLOB) {
1585 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1586 tmps = SvEND(sv) - 1;
1587 if (*tmps == *SvPVX(PL_rs)) {
1592 for (tmps = SvPVX(sv); *tmps; tmps++)
1593 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1594 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1596 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1597 (void)POPs; /* Unmatched wildcard? Chuck it... */
1600 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1601 U8 *s = (U8*)SvPVX(sv) + offset;
1602 STRLEN len = SvCUR(sv) - offset;
1605 if (ckWARN(WARN_UTF8) &&
1606 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1607 /* Emulate :encoding(utf8) warning in the same case. */
1608 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1609 "utf8 \"\\x%02X\" does not map to Unicode",
1610 f < (U8*)SvEND(sv) ? *f : 0);
1612 if (gimme == G_ARRAY) {
1613 if (SvLEN(sv) - SvCUR(sv) > 20) {
1614 SvLEN_set(sv, SvCUR(sv)+1);
1615 Renew(SvPVX(sv), SvLEN(sv), char);
1617 sv = sv_2mortal(NEWSV(58, 80));
1620 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1621 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1625 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1626 Renew(SvPVX(sv), SvLEN(sv), char);
1635 register PERL_CONTEXT *cx;
1636 I32 gimme = OP_GIMME(PL_op, -1);
1639 if (cxstack_ix >= 0)
1640 gimme = cxstack[cxstack_ix].blk_gimme;
1648 PUSHBLOCK(cx, CXt_BLOCK, SP);
1660 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1661 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1663 #ifdef PERL_COPY_ON_WRITE
1664 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1666 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1670 if (SvTYPE(hv) == SVt_PVHV) {
1671 if (PL_op->op_private & OPpLVAL_INTRO) {
1674 /* does the element we're localizing already exist? */
1676 /* can we determine whether it exists? */
1678 || mg_find((SV*)hv, PERL_MAGIC_env)
1679 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1680 /* Try to preserve the existenceness of a tied hash
1681 * element by using EXISTS and DELETE if possible.
1682 * Fallback to FETCH and STORE otherwise */
1683 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1684 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1685 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1687 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1690 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1691 svp = he ? &HeVAL(he) : 0;
1697 if (!svp || *svp == &PL_sv_undef) {
1702 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1704 lv = sv_newmortal();
1705 sv_upgrade(lv, SVt_PVLV);
1707 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1708 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1709 LvTARG(lv) = SvREFCNT_inc(hv);
1714 if (PL_op->op_private & OPpLVAL_INTRO) {
1715 if (HvNAME(hv) && isGV(*svp))
1716 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1720 char *key = SvPV(keysv, keylen);
1721 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1723 save_helem(hv, keysv, svp);
1726 else if (PL_op->op_private & OPpDEREF)
1727 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1729 sv = (svp ? *svp : &PL_sv_undef);
1730 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1731 * Pushing the magical RHS on to the stack is useless, since
1732 * that magic is soon destined to be misled by the local(),
1733 * and thus the later pp_sassign() will fail to mg_get() the
1734 * old value. This should also cure problems with delayed
1735 * mg_get()s. GSAR 98-07-03 */
1736 if (!lval && SvGMAGICAL(sv))
1737 sv = sv_mortalcopy(sv);
1745 register PERL_CONTEXT *cx;
1751 if (PL_op->op_flags & OPf_SPECIAL) {
1752 cx = &cxstack[cxstack_ix];
1753 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1758 gimme = OP_GIMME(PL_op, -1);
1760 if (cxstack_ix >= 0)
1761 gimme = cxstack[cxstack_ix].blk_gimme;
1767 if (gimme == G_VOID)
1769 else if (gimme == G_SCALAR) {
1772 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1775 *MARK = sv_mortalcopy(TOPs);
1778 *MARK = &PL_sv_undef;
1782 else if (gimme == G_ARRAY) {
1783 /* in case LEAVE wipes old return values */
1784 for (mark = newsp + 1; mark <= SP; mark++) {
1785 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1786 *mark = sv_mortalcopy(*mark);
1787 TAINT_NOT; /* Each item is independent */
1791 PL_curpm = newpm; /* Don't pop $1 et al till now */
1801 register PERL_CONTEXT *cx;
1807 cx = &cxstack[cxstack_ix];
1808 if (CxTYPE(cx) != CXt_LOOP)
1809 DIE(aTHX_ "panic: pp_iter");
1811 itersvp = CxITERVAR(cx);
1812 av = cx->blk_loop.iterary;
1813 if (SvTYPE(av) != SVt_PVAV) {
1814 /* iterate ($min .. $max) */
1815 if (cx->blk_loop.iterlval) {
1816 /* string increment */
1817 register SV* cur = cx->blk_loop.iterlval;
1819 char *max = SvPV((SV*)av, maxlen);
1820 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1821 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1822 /* safe to reuse old SV */
1823 sv_setsv(*itersvp, cur);
1827 /* we need a fresh SV every time so that loop body sees a
1828 * completely new SV for closures/references to work as
1830 SvREFCNT_dec(*itersvp);
1831 *itersvp = newSVsv(cur);
1833 if (strEQ(SvPVX(cur), max))
1834 sv_setiv(cur, 0); /* terminate next time */
1841 /* integer increment */
1842 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1845 /* don't risk potential race */
1846 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1847 /* safe to reuse old SV */
1848 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1852 /* we need a fresh SV every time so that loop body sees a
1853 * completely new SV for closures/references to work as they
1855 SvREFCNT_dec(*itersvp);
1856 *itersvp = newSViv(cx->blk_loop.iterix++);
1862 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1865 SvREFCNT_dec(*itersvp);
1867 if (SvMAGICAL(av) || AvREIFY(av)) {
1868 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1875 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1877 if (sv && SvREFCNT(sv) == 0) {
1879 Perl_croak(aTHX_ "Use of freed value in iteration");
1886 if (av != PL_curstack && sv == &PL_sv_undef) {
1887 SV *lv = cx->blk_loop.iterlval;
1888 if (lv && SvREFCNT(lv) > 1) {
1893 SvREFCNT_dec(LvTARG(lv));
1895 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1896 sv_upgrade(lv, SVt_PVLV);
1898 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1900 LvTARG(lv) = SvREFCNT_inc(av);
1901 LvTARGOFF(lv) = cx->blk_loop.iterix;
1902 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1906 *itersvp = SvREFCNT_inc(sv);
1913 register PMOP *pm = cPMOP;
1929 register REGEXP *rx = PM_GETRE(pm);
1931 int force_on_match = 0;
1932 I32 oldsave = PL_savestack_ix;
1934 bool doutf8 = FALSE;
1935 #ifdef PERL_COPY_ON_WRITE
1940 /* known replacement string? */
1941 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1942 if (PL_op->op_flags & OPf_STACKED)
1949 #ifdef PERL_COPY_ON_WRITE
1950 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1951 because they make integers such as 256 "false". */
1952 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1955 sv_force_normal_flags(TARG,0);
1958 #ifdef PERL_COPY_ON_WRITE
1962 || (SvTYPE(TARG) > SVt_PVLV
1963 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1964 DIE(aTHX_ PL_no_modify);
1967 s = SvPV(TARG, len);
1968 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1970 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1971 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1976 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1980 DIE(aTHX_ "panic: pp_subst");
1983 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
1984 maxiters = 2 * slen + 10; /* We can match twice at each
1985 position, once with zero-length,
1986 second time with non-zero. */
1988 if (!rx->prelen && PL_curpm) {
1992 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1993 ? REXEC_COPY_STR : 0;
1995 r_flags |= REXEC_SCREAM;
1996 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1997 SAVEINT(PL_multiline);
1998 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2001 if (rx->reganch & RE_USE_INTUIT) {
2003 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2007 /* How to do it in subst? */
2008 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2010 && ((rx->reganch & ROPT_NOSCAN)
2011 || !((rx->reganch & RE_INTUIT_TAIL)
2012 && (r_flags & REXEC_SCREAM))))
2017 /* only replace once? */
2018 once = !(rpm->op_pmflags & PMf_GLOBAL);
2020 /* known replacement string? */
2022 /* replacement needing upgrading? */
2023 if (DO_UTF8(TARG) && !doutf8) {
2024 nsv = sv_newmortal();
2027 sv_recode_to_utf8(nsv, PL_encoding);
2029 sv_utf8_upgrade(nsv);
2030 c = SvPV(nsv, clen);
2034 c = SvPV(dstr, clen);
2035 doutf8 = DO_UTF8(dstr);
2043 /* can do inplace substitution? */
2045 #ifdef PERL_COPY_ON_WRITE
2048 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2049 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2050 && (!doutf8 || SvUTF8(TARG))) {
2051 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2052 r_flags | REXEC_CHECKED))
2056 LEAVE_SCOPE(oldsave);
2059 #ifdef PERL_COPY_ON_WRITE
2060 if (SvIsCOW(TARG)) {
2061 assert (!force_on_match);
2065 if (force_on_match) {
2067 s = SvPV_force(TARG, len);
2072 SvSCREAM_off(TARG); /* disable possible screamer */
2074 rxtainted |= RX_MATCH_TAINTED(rx);
2075 m = orig + rx->startp[0];
2076 d = orig + rx->endp[0];
2078 if (m - s > strend - d) { /* faster to shorten from end */
2080 Copy(c, m, clen, char);
2085 Move(d, m, i, char);
2089 SvCUR_set(TARG, m - s);
2092 else if ((i = m - s)) { /* faster from front */
2100 Copy(c, m, clen, char);
2105 Copy(c, d, clen, char);
2110 TAINT_IF(rxtainted & 1);
2116 if (iters++ > maxiters)
2117 DIE(aTHX_ "Substitution loop");
2118 rxtainted |= RX_MATCH_TAINTED(rx);
2119 m = rx->startp[0] + orig;
2123 Move(s, d, i, char);
2127 Copy(c, d, clen, char);
2130 s = rx->endp[0] + orig;
2131 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2133 /* don't match same null twice */
2134 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2137 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2138 Move(s, d, i+1, char); /* include the NUL */
2140 TAINT_IF(rxtainted & 1);
2142 PUSHs(sv_2mortal(newSViv((I32)iters)));
2144 (void)SvPOK_only_UTF8(TARG);
2145 TAINT_IF(rxtainted);
2146 if (SvSMAGICAL(TARG)) {
2154 LEAVE_SCOPE(oldsave);
2158 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2159 r_flags | REXEC_CHECKED))
2161 if (force_on_match) {
2163 s = SvPV_force(TARG, len);
2166 #ifdef PERL_COPY_ON_WRITE
2169 rxtainted |= RX_MATCH_TAINTED(rx);
2170 dstr = NEWSV(25, len);
2171 sv_setpvn(dstr, m, s-m);
2176 register PERL_CONTEXT *cx;
2180 RETURNOP(cPMOP->op_pmreplroot);
2182 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2184 if (iters++ > maxiters)
2185 DIE(aTHX_ "Substitution loop");
2186 rxtainted |= RX_MATCH_TAINTED(rx);
2187 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2192 strend = s + (strend - m);
2194 m = rx->startp[0] + orig;
2195 if (doutf8 && !SvUTF8(dstr))
2196 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2198 sv_catpvn(dstr, s, m-s);
2199 s = rx->endp[0] + orig;
2201 sv_catpvn(dstr, c, clen);
2204 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2205 TARG, NULL, r_flags));
2206 if (doutf8 && !DO_UTF8(TARG))
2207 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2209 sv_catpvn(dstr, s, strend - s);
2211 #ifdef PERL_COPY_ON_WRITE
2212 /* The match may make the string COW. If so, brilliant, because that's
2213 just saved us one malloc, copy and free - the regexp has donated
2214 the old buffer, and we malloc an entirely new one, rather than the
2215 regexp malloc()ing a buffer and copying our original, only for
2216 us to throw it away here during the substitution. */
2217 if (SvIsCOW(TARG)) {
2218 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2222 (void)SvOOK_off(TARG);
2224 Safefree(SvPVX(TARG));
2226 SvPVX(TARG) = SvPVX(dstr);
2227 SvCUR_set(TARG, SvCUR(dstr));
2228 SvLEN_set(TARG, SvLEN(dstr));
2229 doutf8 |= DO_UTF8(dstr);
2233 TAINT_IF(rxtainted & 1);
2235 PUSHs(sv_2mortal(newSViv((I32)iters)));
2237 (void)SvPOK_only(TARG);
2240 TAINT_IF(rxtainted);
2243 LEAVE_SCOPE(oldsave);
2252 LEAVE_SCOPE(oldsave);
2261 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2262 ++*PL_markstack_ptr;
2263 LEAVE; /* exit inner scope */
2266 if (PL_stack_base + *PL_markstack_ptr > SP) {
2268 I32 gimme = GIMME_V;
2270 LEAVE; /* exit outer scope */
2271 (void)POPMARK; /* pop src */
2272 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2273 (void)POPMARK; /* pop dst */
2274 SP = PL_stack_base + POPMARK; /* pop original mark */
2275 if (gimme == G_SCALAR) {
2279 else if (gimme == G_ARRAY)
2286 ENTER; /* enter inner scope */
2289 src = PL_stack_base[*PL_markstack_ptr];
2293 RETURNOP(cLOGOP->op_other);
2304 register PERL_CONTEXT *cx;
2308 cxstack_ix++; /* temporarily protect top context */
2311 if (gimme == G_SCALAR) {
2314 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2316 *MARK = SvREFCNT_inc(TOPs);
2321 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2323 *MARK = sv_mortalcopy(sv);
2328 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2332 *MARK = &PL_sv_undef;
2336 else if (gimme == G_ARRAY) {
2337 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2338 if (!SvTEMP(*MARK)) {
2339 *MARK = sv_mortalcopy(*MARK);
2340 TAINT_NOT; /* Each item is independent */
2348 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2349 PL_curpm = newpm; /* ... and pop $1 et al */
2352 return pop_return();
2355 /* This duplicates the above code because the above code must not
2356 * get any slower by more conditions */
2364 register PERL_CONTEXT *cx;
2368 cxstack_ix++; /* temporarily protect top context */
2372 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2373 /* We are an argument to a function or grep().
2374 * This kind of lvalueness was legal before lvalue
2375 * subroutines too, so be backward compatible:
2376 * cannot report errors. */
2378 /* Scalar context *is* possible, on the LHS of -> only,
2379 * as in f()->meth(). But this is not an lvalue. */
2380 if (gimme == G_SCALAR)
2382 if (gimme == G_ARRAY) {
2383 if (!CvLVALUE(cx->blk_sub.cv))
2384 goto temporise_array;
2385 EXTEND_MORTAL(SP - newsp);
2386 for (mark = newsp + 1; mark <= SP; mark++) {
2389 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2390 *mark = sv_mortalcopy(*mark);
2392 /* Can be a localized value subject to deletion. */
2393 PL_tmps_stack[++PL_tmps_ix] = *mark;
2394 (void)SvREFCNT_inc(*mark);
2399 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2400 /* Here we go for robustness, not for speed, so we change all
2401 * the refcounts so the caller gets a live guy. Cannot set
2402 * TEMP, so sv_2mortal is out of question. */
2403 if (!CvLVALUE(cx->blk_sub.cv)) {
2409 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2411 if (gimme == G_SCALAR) {
2415 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2421 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2422 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2423 : "a readonly value" : "a temporary");
2425 else { /* Can be a localized value
2426 * subject to deletion. */
2427 PL_tmps_stack[++PL_tmps_ix] = *mark;
2428 (void)SvREFCNT_inc(*mark);
2431 else { /* Should not happen? */
2437 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2438 (MARK > SP ? "Empty array" : "Array"));
2442 else if (gimme == G_ARRAY) {
2443 EXTEND_MORTAL(SP - newsp);
2444 for (mark = newsp + 1; mark <= SP; mark++) {
2445 if (*mark != &PL_sv_undef
2446 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2447 /* Might be flattened array after $#array = */
2454 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2455 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2458 /* Can be a localized value subject to deletion. */
2459 PL_tmps_stack[++PL_tmps_ix] = *mark;
2460 (void)SvREFCNT_inc(*mark);
2466 if (gimme == G_SCALAR) {
2470 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2472 *MARK = SvREFCNT_inc(TOPs);
2477 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2479 *MARK = sv_mortalcopy(sv);
2484 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2488 *MARK = &PL_sv_undef;
2492 else if (gimme == G_ARRAY) {
2494 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2495 if (!SvTEMP(*MARK)) {
2496 *MARK = sv_mortalcopy(*MARK);
2497 TAINT_NOT; /* Each item is independent */
2506 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2507 PL_curpm = newpm; /* ... and pop $1 et al */
2510 return pop_return();
2515 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2517 SV *dbsv = GvSV(PL_DBsub);
2519 if (!PERLDB_SUB_NN) {
2523 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2524 || strEQ(GvNAME(gv), "END")
2525 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2526 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2527 && (gv = (GV*)*svp) ))) {
2528 /* Use GV from the stack as a fallback. */
2529 /* GV is potentially non-unique, or contain different CV. */
2530 SV *tmp = newRV((SV*)cv);
2531 sv_setsv(dbsv, tmp);
2535 gv_efullname3(dbsv, gv, Nullch);
2539 (void)SvUPGRADE(dbsv, SVt_PVIV);
2540 (void)SvIOK_on(dbsv);
2541 SAVEIV(SvIVX(dbsv));
2542 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2546 PL_curcopdb = PL_curcop;
2547 cv = GvCV(PL_DBsub);
2557 register PERL_CONTEXT *cx;
2559 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2562 DIE(aTHX_ "Not a CODE reference");
2563 switch (SvTYPE(sv)) {
2564 /* This is overwhelming the most common case: */
2566 if (!(cv = GvCVu((GV*)sv)))
2567 cv = sv_2cv(sv, &stash, &gv, FALSE);
2579 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2581 SP = PL_stack_base + POPMARK;
2584 if (SvGMAGICAL(sv)) {
2588 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2591 sym = SvPV(sv, n_a);
2593 DIE(aTHX_ PL_no_usym, "a subroutine");
2594 if (PL_op->op_private & HINT_STRICT_REFS)
2595 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2596 cv = get_cv(sym, TRUE);
2601 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2602 tryAMAGICunDEREF(to_cv);
2605 if (SvTYPE(cv) == SVt_PVCV)
2610 DIE(aTHX_ "Not a CODE reference");
2611 /* This is the second most common case: */
2621 if (!CvROOT(cv) && !CvXSUB(cv)) {
2626 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2627 if (CvASSERTION(cv) && PL_DBassertion)
2628 sv_setiv(PL_DBassertion, 1);
2630 cv = get_db_sub(&sv, cv);
2632 DIE(aTHX_ "No DBsub routine");
2635 if (!(CvXSUB(cv))) {
2636 /* This path taken at least 75% of the time */
2638 register I32 items = SP - MARK;
2639 AV* padlist = CvPADLIST(cv);
2640 push_return(PL_op->op_next);
2641 PUSHBLOCK(cx, CXt_SUB, MARK);
2644 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2645 * that eval'' ops within this sub know the correct lexical space.
2646 * Owing the speed considerations, we choose instead to search for
2647 * the cv using find_runcv() when calling doeval().
2649 if (CvDEPTH(cv) < 2)
2650 (void)SvREFCNT_inc(cv);
2652 PERL_STACK_OVERFLOW_CHECK();
2653 pad_push(padlist, CvDEPTH(cv), 1);
2655 PAD_SET_CUR(padlist, CvDEPTH(cv));
2662 DEBUG_S(PerlIO_printf(Perl_debug_log,
2663 "%p entersub preparing @_\n", thr));
2665 av = (AV*)PAD_SVl(0);
2667 /* @_ is normally not REAL--this should only ever
2668 * happen when DB::sub() calls things that modify @_ */
2673 cx->blk_sub.savearray = GvAV(PL_defgv);
2674 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2675 CX_CURPAD_SAVE(cx->blk_sub);
2676 cx->blk_sub.argarray = av;
2679 if (items > AvMAX(av) + 1) {
2681 if (AvARRAY(av) != ary) {
2682 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2683 SvPVX(av) = (char*)ary;
2685 if (items > AvMAX(av) + 1) {
2686 AvMAX(av) = items - 1;
2687 Renew(ary,items,SV*);
2689 SvPVX(av) = (char*)ary;
2692 Copy(MARK,AvARRAY(av),items,SV*);
2693 AvFILLp(av) = items - 1;
2701 /* warning must come *after* we fully set up the context
2702 * stuff so that __WARN__ handlers can safely dounwind()
2705 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2706 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2707 sub_crush_depth(cv);
2709 DEBUG_S(PerlIO_printf(Perl_debug_log,
2710 "%p entersub returning %p\n", thr, CvSTART(cv)));
2712 RETURNOP(CvSTART(cv));
2715 #ifdef PERL_XSUB_OLDSTYLE
2716 if (CvOLDSTYLE(cv)) {
2717 I32 (*fp3)(int,int,int);
2719 register I32 items = SP - MARK;
2720 /* We dont worry to copy from @_. */
2725 PL_stack_sp = mark + 1;
2726 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2727 items = (*fp3)(CvXSUBANY(cv).any_i32,
2728 MARK - PL_stack_base + 1,
2730 PL_stack_sp = PL_stack_base + items;
2733 #endif /* PERL_XSUB_OLDSTYLE */
2735 I32 markix = TOPMARK;
2740 /* Need to copy @_ to stack. Alternative may be to
2741 * switch stack to @_, and copy return values
2742 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2745 av = GvAV(PL_defgv);
2746 items = AvFILLp(av) + 1; /* @_ is not tieable */
2749 /* Mark is at the end of the stack. */
2751 Copy(AvARRAY(av), SP + 1, items, SV*);
2756 /* We assume first XSUB in &DB::sub is the called one. */
2758 SAVEVPTR(PL_curcop);
2759 PL_curcop = PL_curcopdb;
2762 /* Do we need to open block here? XXXX */
2763 (void)(*CvXSUB(cv))(aTHX_ cv);
2765 /* Enforce some sanity in scalar context. */
2766 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2767 if (markix > PL_stack_sp - PL_stack_base)
2768 *(PL_stack_base + markix) = &PL_sv_undef;
2770 *(PL_stack_base + markix) = *PL_stack_sp;
2771 PL_stack_sp = PL_stack_base + markix;
2778 assert (0); /* Cannot get here. */
2779 /* This is deliberately moved here as spaghetti code to keep it out of the
2786 /* anonymous or undef'd function leaves us no recourse */
2787 if (CvANON(cv) || !(gv = CvGV(cv)))
2788 DIE(aTHX_ "Undefined subroutine called");
2790 /* autoloaded stub? */
2791 if (cv != GvCV(gv)) {
2794 /* should call AUTOLOAD now? */
2797 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2804 sub_name = sv_newmortal();
2805 gv_efullname3(sub_name, gv, Nullch);
2806 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2810 DIE(aTHX_ "Not a CODE reference");
2816 Perl_sub_crush_depth(pTHX_ CV *cv)
2819 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2821 SV* tmpstr = sv_newmortal();
2822 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2823 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2833 IV elem = SvIV(elemsv);
2835 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2836 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2839 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2840 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2842 elem -= PL_curcop->cop_arybase;
2843 if (SvTYPE(av) != SVt_PVAV)
2845 svp = av_fetch(av, elem, lval && !defer);
2847 if (!svp || *svp == &PL_sv_undef) {
2850 DIE(aTHX_ PL_no_aelem, elem);
2851 lv = sv_newmortal();
2852 sv_upgrade(lv, SVt_PVLV);
2854 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2855 LvTARG(lv) = SvREFCNT_inc(av);
2856 LvTARGOFF(lv) = elem;
2861 if (PL_op->op_private & OPpLVAL_INTRO)
2862 save_aelem(av, elem, svp);
2863 else if (PL_op->op_private & OPpDEREF)
2864 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2866 sv = (svp ? *svp : &PL_sv_undef);
2867 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2868 sv = sv_mortalcopy(sv);
2874 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2880 Perl_croak(aTHX_ PL_no_modify);
2881 if (SvTYPE(sv) < SVt_RV)
2882 sv_upgrade(sv, SVt_RV);
2883 else if (SvTYPE(sv) >= SVt_PV) {
2884 (void)SvOOK_off(sv);
2885 Safefree(SvPVX(sv));
2886 SvLEN(sv) = SvCUR(sv) = 0;
2890 SvRV(sv) = NEWSV(355,0);
2893 SvRV(sv) = (SV*)newAV();
2896 SvRV(sv) = (SV*)newHV();
2911 if (SvTYPE(rsv) == SVt_PVCV) {
2917 SETs(method_common(sv, Null(U32*)));
2925 U32 hash = SvUVX(sv);
2927 XPUSHs(method_common(sv, &hash));
2932 S_method_common(pTHX_ SV* meth, U32* hashp)
2941 SV *packsv = Nullsv;
2944 name = SvPV(meth, namelen);
2945 sv = *(PL_stack_base + TOPMARK + 1);
2948 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2957 /* this isn't a reference */
2960 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2962 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2964 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2971 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2972 !(ob=(SV*)GvIO(iogv)))
2974 /* this isn't the name of a filehandle either */
2976 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2977 ? !isIDFIRST_utf8((U8*)packname)
2978 : !isIDFIRST(*packname)
2981 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2982 SvOK(sv) ? "without a package or object reference"
2983 : "on an undefined value");
2985 /* assume it's a package name */
2986 stash = gv_stashpvn(packname, packlen, FALSE);
2990 SV* ref = newSViv(PTR2IV(stash));
2991 hv_store(PL_stashcache, packname, packlen, ref, 0);
2995 /* it _is_ a filehandle name -- replace with a reference */
2996 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2999 /* if we got here, ob should be a reference or a glob */
3000 if (!ob || !(SvOBJECT(ob)
3001 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3004 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3008 stash = SvSTASH(ob);
3011 /* NOTE: stash may be null, hope hv_fetch_ent and
3012 gv_fetchmethod can cope (it seems they can) */
3014 /* shortcut for simple names */
3016 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3018 gv = (GV*)HeVAL(he);
3019 if (isGV(gv) && GvCV(gv) &&
3020 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3021 return (SV*)GvCV(gv);
3025 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3028 /* This code tries to figure out just what went wrong with
3029 gv_fetchmethod. It therefore needs to duplicate a lot of
3030 the internals of that function. We can't move it inside
3031 Perl_gv_fetchmethod_autoload(), however, since that would
3032 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3039 for (p = name; *p; p++) {
3041 sep = p, leaf = p + 1;
3042 else if (*p == ':' && *(p + 1) == ':')
3043 sep = p, leaf = p + 2;
3045 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3046 /* the method name is unqualified or starts with SUPER:: */
3047 packname = sep ? CopSTASHPV(PL_curcop) :
3048 stash ? HvNAME(stash) : packname;
3051 "Can't use anonymous symbol table for method lookup");
3053 packlen = strlen(packname);
3056 /* the method name is qualified */
3058 packlen = sep - name;
3061 /* we're relying on gv_fetchmethod not autovivifying the stash */
3062 if (gv_stashpvn(packname, packlen, FALSE)) {
3064 "Can't locate object method \"%s\" via package \"%.*s\"",
3065 leaf, (int)packlen, packname);
3069 "Can't locate object method \"%s\" via package \"%.*s\""
3070 " (perhaps you forgot to load \"%.*s\"?)",
3071 leaf, (int)packlen, packname, (int)packlen, packname);
3074 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;