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 UTF8 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;
801 tryAMAGICunDEREF(to_hv);
804 if (SvTYPE(hv) != SVt_PVHV)
805 DIE(aTHX_ "Not a HASH reference");
806 if (PL_op->op_flags & OPf_REF) {
811 if (GIMME != G_SCALAR)
812 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
816 else if (PL_op->op_flags & OPf_MOD
817 && PL_op->op_private & OPpLVAL_INTRO)
818 Perl_croak(aTHX_ PL_no_localize_ref);
821 if (SvTYPE(sv) == SVt_PVHV) {
823 if (PL_op->op_flags & OPf_REF) {
828 if (GIMME == G_SCALAR)
829 Perl_croak(aTHX_ "Can't return hash to lvalue"
838 if (SvTYPE(sv) != SVt_PVGV) {
842 if (SvGMAGICAL(sv)) {
848 if (PL_op->op_flags & OPf_REF ||
849 PL_op->op_private & HINT_STRICT_REFS)
850 DIE(aTHX_ PL_no_usym, "a HASH");
851 if (ckWARN(WARN_UNINITIALIZED))
853 if (GIMME == G_ARRAY) {
860 if ((PL_op->op_flags & OPf_SPECIAL) &&
861 !(PL_op->op_flags & OPf_MOD))
863 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
865 && (!is_gv_magical(sym,len,0)
866 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
872 if (PL_op->op_private & HINT_STRICT_REFS)
873 DIE(aTHX_ PL_no_symref, sym, "a HASH");
874 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
881 if (PL_op->op_private & OPpLVAL_INTRO)
883 if (PL_op->op_flags & OPf_REF) {
888 if (GIMME == G_SCALAR)
889 Perl_croak(aTHX_ "Can't return hash to lvalue"
897 if (GIMME == G_ARRAY) { /* array wanted */
898 *PL_stack_sp = (SV*)hv;
904 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
905 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
915 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
921 if (ckWARN(WARN_MISC)) {
922 if (relem == firstrelem &&
924 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
925 SvTYPE(SvRV(*relem)) == SVt_PVHV))
927 Perl_warner(aTHX_ packWARN(WARN_MISC),
928 "Reference found where even-sized list expected");
931 Perl_warner(aTHX_ packWARN(WARN_MISC),
932 "Odd number of elements in hash assignment");
935 tmpstr = NEWSV(29,0);
936 didstore = hv_store_ent(hash,*relem,tmpstr,0);
937 if (SvMAGICAL(hash)) {
938 if (SvSMAGICAL(tmpstr))
950 SV **lastlelem = PL_stack_sp;
951 SV **lastrelem = PL_stack_base + POPMARK;
952 SV **firstrelem = PL_stack_base + POPMARK + 1;
953 SV **firstlelem = lastrelem + 1;
966 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
968 /* If there's a common identifier on both sides we have to take
969 * special care that assigning the identifier on the left doesn't
970 * clobber a value on the right that's used later in the list.
972 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
973 EXTEND_MORTAL(lastrelem - firstrelem + 1);
974 for (relem = firstrelem; relem <= lastrelem; relem++) {
977 TAINT_NOT; /* Each item is independent */
978 *relem = sv_mortalcopy(sv);
988 while (lelem <= lastlelem) {
989 TAINT_NOT; /* Each item stands on its own, taintwise. */
991 switch (SvTYPE(sv)) {
994 magic = SvMAGICAL(ary) != 0;
996 av_extend(ary, lastrelem - relem);
998 while (relem <= lastrelem) { /* gobble up all the rest */
1002 sv_setsv(sv,*relem);
1004 didstore = av_store(ary,i++,sv);
1014 case SVt_PVHV: { /* normal hash */
1018 magic = SvMAGICAL(hash) != 0;
1021 while (relem < lastrelem) { /* gobble up all the rest */
1026 sv = &PL_sv_no, relem++;
1027 tmpstr = NEWSV(29,0);
1029 sv_setsv(tmpstr,*relem); /* value */
1030 *(relem++) = tmpstr;
1031 didstore = hv_store_ent(hash,sv,tmpstr,0);
1033 if (SvSMAGICAL(tmpstr))
1040 if (relem == lastrelem) {
1041 do_oddball(hash, relem, firstrelem);
1047 if (SvIMMORTAL(sv)) {
1048 if (relem <= lastrelem)
1052 if (relem <= lastrelem) {
1053 sv_setsv(sv, *relem);
1057 sv_setsv(sv, &PL_sv_undef);
1062 if (PL_delaymagic & ~DM_DELAY) {
1063 if (PL_delaymagic & DM_UID) {
1064 #ifdef HAS_SETRESUID
1065 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1067 # ifdef HAS_SETREUID
1068 (void)setreuid(PL_uid,PL_euid);
1071 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1072 (void)setruid(PL_uid);
1073 PL_delaymagic &= ~DM_RUID;
1075 # endif /* HAS_SETRUID */
1077 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1078 (void)seteuid(PL_uid);
1079 PL_delaymagic &= ~DM_EUID;
1081 # endif /* HAS_SETEUID */
1082 if (PL_delaymagic & DM_UID) {
1083 if (PL_uid != PL_euid)
1084 DIE(aTHX_ "No setreuid available");
1085 (void)PerlProc_setuid(PL_uid);
1087 # endif /* HAS_SETREUID */
1088 #endif /* HAS_SETRESUID */
1089 PL_uid = PerlProc_getuid();
1090 PL_euid = PerlProc_geteuid();
1092 if (PL_delaymagic & DM_GID) {
1093 #ifdef HAS_SETRESGID
1094 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1096 # ifdef HAS_SETREGID
1097 (void)setregid(PL_gid,PL_egid);
1100 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1101 (void)setrgid(PL_gid);
1102 PL_delaymagic &= ~DM_RGID;
1104 # endif /* HAS_SETRGID */
1106 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1107 (void)setegid(PL_gid);
1108 PL_delaymagic &= ~DM_EGID;
1110 # endif /* HAS_SETEGID */
1111 if (PL_delaymagic & DM_GID) {
1112 if (PL_gid != PL_egid)
1113 DIE(aTHX_ "No setregid available");
1114 (void)PerlProc_setgid(PL_gid);
1116 # endif /* HAS_SETREGID */
1117 #endif /* HAS_SETRESGID */
1118 PL_gid = PerlProc_getgid();
1119 PL_egid = PerlProc_getegid();
1121 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1126 if (gimme == G_VOID)
1127 SP = firstrelem - 1;
1128 else if (gimme == G_SCALAR) {
1131 SETi(lastrelem - firstrelem + 1);
1137 SP = firstrelem + (lastlelem - firstlelem);
1138 lelem = firstlelem + (relem - firstrelem);
1140 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1148 register PMOP *pm = cPMOP;
1149 SV *rv = sv_newmortal();
1150 SV *sv = newSVrv(rv, "Regexp");
1151 if (pm->op_pmdynflags & PMdf_TAINTED)
1153 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1160 register PMOP *pm = cPMOP;
1166 I32 r_flags = REXEC_CHECKED;
1167 char *truebase; /* Start of string */
1168 register REGEXP *rx = PM_GETRE(pm);
1173 I32 oldsave = PL_savestack_ix;
1174 I32 update_minmatch = 1;
1175 I32 had_zerolen = 0;
1177 if (PL_op->op_flags & OPf_STACKED)
1184 PUTBACK; /* EVAL blocks need stack_sp. */
1185 s = SvPV(TARG, len);
1188 DIE(aTHX_ "panic: pp_match");
1189 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1190 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1193 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1195 /* PMdf_USED is set after a ?? matches once */
1196 if (pm->op_pmdynflags & PMdf_USED) {
1198 if (gimme == G_ARRAY)
1203 /* empty pattern special-cased to use last successful pattern if possible */
1204 if (!rx->prelen && PL_curpm) {
1209 if (rx->minlen > (I32)len)
1214 /* XXXX What part of this is needed with true \G-support? */
1215 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1217 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1218 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1219 if (mg && mg->mg_len >= 0) {
1220 if (!(rx->reganch & ROPT_GPOS_SEEN))
1221 rx->endp[0] = rx->startp[0] = mg->mg_len;
1222 else if (rx->reganch & ROPT_ANCH_GPOS) {
1223 r_flags |= REXEC_IGNOREPOS;
1224 rx->endp[0] = rx->startp[0] = mg->mg_len;
1226 minmatch = (mg->mg_flags & MGf_MINMATCH);
1227 update_minmatch = 0;
1231 if ((!global && rx->nparens)
1232 || SvTEMP(TARG) || PL_sawampersand)
1233 r_flags |= REXEC_COPY_STR;
1235 r_flags |= REXEC_SCREAM;
1237 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1238 SAVEINT(PL_multiline);
1239 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1243 if (global && rx->startp[0] != -1) {
1244 t = s = rx->endp[0] + truebase;
1245 if ((s + rx->minlen) > strend)
1247 if (update_minmatch++)
1248 minmatch = had_zerolen;
1250 if (rx->reganch & RE_USE_INTUIT &&
1251 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1252 PL_bostr = truebase;
1253 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1257 if ( (rx->reganch & ROPT_CHECK_ALL)
1259 && ((rx->reganch & ROPT_NOSCAN)
1260 || !((rx->reganch & RE_INTUIT_TAIL)
1261 && (r_flags & REXEC_SCREAM)))
1262 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1265 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1268 if (dynpm->op_pmflags & PMf_ONCE)
1269 dynpm->op_pmdynflags |= PMdf_USED;
1278 RX_MATCH_TAINTED_on(rx);
1279 TAINT_IF(RX_MATCH_TAINTED(rx));
1280 if (gimme == G_ARRAY) {
1281 I32 nparens, i, len;
1283 nparens = rx->nparens;
1284 if (global && !nparens)
1288 SPAGAIN; /* EVAL blocks could move the stack. */
1289 EXTEND(SP, nparens + i);
1290 EXTEND_MORTAL(nparens + i);
1291 for (i = !i; i <= nparens; i++) {
1292 PUSHs(sv_newmortal());
1294 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1295 len = rx->endp[i] - rx->startp[i];
1296 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1297 len < 0 || len > strend - s)
1298 DIE(aTHX_ "panic: pp_match start/end pointers");
1299 s = rx->startp[i] + truebase;
1300 sv_setpvn(*SP, s, len);
1301 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1306 if (dynpm->op_pmflags & PMf_CONTINUE) {
1308 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1309 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1311 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1312 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1314 if (rx->startp[0] != -1) {
1315 mg->mg_len = rx->endp[0];
1316 if (rx->startp[0] == rx->endp[0])
1317 mg->mg_flags |= MGf_MINMATCH;
1319 mg->mg_flags &= ~MGf_MINMATCH;
1322 had_zerolen = (rx->startp[0] != -1
1323 && rx->startp[0] == rx->endp[0]);
1324 PUTBACK; /* EVAL blocks may use stack */
1325 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1330 LEAVE_SCOPE(oldsave);
1336 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1337 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1339 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1340 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1342 if (rx->startp[0] != -1) {
1343 mg->mg_len = rx->endp[0];
1344 if (rx->startp[0] == rx->endp[0])
1345 mg->mg_flags |= MGf_MINMATCH;
1347 mg->mg_flags &= ~MGf_MINMATCH;
1350 LEAVE_SCOPE(oldsave);
1354 yup: /* Confirmed by INTUIT */
1356 RX_MATCH_TAINTED_on(rx);
1357 TAINT_IF(RX_MATCH_TAINTED(rx));
1359 if (dynpm->op_pmflags & PMf_ONCE)
1360 dynpm->op_pmdynflags |= PMdf_USED;
1361 if (RX_MATCH_COPIED(rx))
1362 Safefree(rx->subbeg);
1363 RX_MATCH_COPIED_off(rx);
1364 rx->subbeg = Nullch;
1366 rx->subbeg = truebase;
1367 rx->startp[0] = s - truebase;
1368 if (RX_MATCH_UTF8(rx)) {
1369 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1370 rx->endp[0] = t - truebase;
1373 rx->endp[0] = s - truebase + rx->minlen;
1375 rx->sublen = strend - truebase;
1378 if (PL_sawampersand) {
1380 #ifdef PERL_COPY_ON_WRITE
1381 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1383 PerlIO_printf(Perl_debug_log,
1384 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1385 (int) SvTYPE(TARG), truebase, t,
1388 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1389 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1390 assert (SvPOKp(rx->saved_copy));
1395 rx->subbeg = savepvn(t, strend - t);
1396 #ifdef PERL_COPY_ON_WRITE
1397 rx->saved_copy = Nullsv;
1400 rx->sublen = strend - t;
1401 RX_MATCH_COPIED_on(rx);
1402 off = rx->startp[0] = s - t;
1403 rx->endp[0] = off + rx->minlen;
1405 else { /* startp/endp are used by @- @+. */
1406 rx->startp[0] = s - truebase;
1407 rx->endp[0] = s - truebase + rx->minlen;
1409 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1410 LEAVE_SCOPE(oldsave);
1415 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1416 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1417 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1422 LEAVE_SCOPE(oldsave);
1423 if (gimme == G_ARRAY)
1429 Perl_do_readline(pTHX)
1431 dSP; dTARGETSTACKED;
1436 register IO *io = GvIO(PL_last_in_gv);
1437 register I32 type = PL_op->op_type;
1438 I32 gimme = GIMME_V;
1441 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1443 XPUSHs(SvTIED_obj((SV*)io, mg));
1446 call_method("READLINE", gimme);
1449 if (gimme == G_SCALAR) {
1451 SvSetSV_nosteal(TARG, result);
1460 if (IoFLAGS(io) & IOf_ARGV) {
1461 if (IoFLAGS(io) & IOf_START) {
1463 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1464 IoFLAGS(io) &= ~IOf_START;
1465 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1466 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1467 SvSETMAGIC(GvSV(PL_last_in_gv));
1472 fp = nextargv(PL_last_in_gv);
1473 if (!fp) { /* Note: fp != IoIFP(io) */
1474 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1477 else if (type == OP_GLOB)
1478 fp = Perl_start_glob(aTHX_ POPs, io);
1480 else if (type == OP_GLOB)
1482 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1483 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1487 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1488 && (!io || !(IoFLAGS(io) & IOf_START))) {
1489 if (type == OP_GLOB)
1490 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1491 "glob failed (can't start child: %s)",
1494 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1496 if (gimme == G_SCALAR) {
1497 /* undef TARG, and push that undefined value */
1498 if (type != OP_RCATLINE) {
1499 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1500 (void)SvOK_off(TARG);
1507 if (gimme == G_SCALAR) {
1511 (void)SvUPGRADE(sv, SVt_PV);
1512 tmplen = SvLEN(sv); /* remember if already alloced */
1513 if (!tmplen && !SvREADONLY(sv))
1514 Sv_Grow(sv, 80); /* try short-buffering it */
1516 if (type == OP_RCATLINE && SvOK(sv)) {
1519 (void)SvPV_force(sv, n_a);
1525 sv = sv_2mortal(NEWSV(57, 80));
1529 /* This should not be marked tainted if the fp is marked clean */
1530 #define MAYBE_TAINT_LINE(io, sv) \
1531 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1536 /* delay EOF state for a snarfed empty file */
1537 #define SNARF_EOF(gimme,rs,io,sv) \
1538 (gimme != G_SCALAR || SvCUR(sv) \
1539 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1543 if (!sv_gets(sv, fp, offset)
1544 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1546 PerlIO_clearerr(fp);
1547 if (IoFLAGS(io) & IOf_ARGV) {
1548 fp = nextargv(PL_last_in_gv);
1551 (void)do_close(PL_last_in_gv, FALSE);
1553 else if (type == OP_GLOB) {
1554 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1555 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1556 "glob failed (child exited with status %d%s)",
1557 (int)(STATUS_CURRENT >> 8),
1558 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1561 if (gimme == G_SCALAR) {
1562 if (type != OP_RCATLINE) {
1563 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1564 (void)SvOK_off(TARG);
1569 MAYBE_TAINT_LINE(io, sv);
1572 MAYBE_TAINT_LINE(io, sv);
1574 IoFLAGS(io) |= IOf_NOLINE;
1578 if (type == OP_GLOB) {
1581 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1582 tmps = SvEND(sv) - 1;
1583 if (*tmps == *SvPVX(PL_rs)) {
1588 for (tmps = SvPVX(sv); *tmps; tmps++)
1589 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1590 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1592 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1593 (void)POPs; /* Unmatched wildcard? Chuck it... */
1596 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1597 U8 *s = (U8*)SvPVX(sv) + offset;
1598 STRLEN len = SvCUR(sv) - offset;
1601 if (ckWARN(WARN_UTF8) &&
1602 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1603 /* Emulate :encoding(utf8) warning in the same case. */
1604 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1605 "utf8 \"\\x%02X\" does not map to Unicode",
1606 f < (U8*)SvEND(sv) ? *f : 0);
1608 if (gimme == G_ARRAY) {
1609 if (SvLEN(sv) - SvCUR(sv) > 20) {
1610 SvLEN_set(sv, SvCUR(sv)+1);
1611 Renew(SvPVX(sv), SvLEN(sv), char);
1613 sv = sv_2mortal(NEWSV(58, 80));
1616 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1617 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1621 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1622 Renew(SvPVX(sv), SvLEN(sv), char);
1631 register PERL_CONTEXT *cx;
1632 I32 gimme = OP_GIMME(PL_op, -1);
1635 if (cxstack_ix >= 0)
1636 gimme = cxstack[cxstack_ix].blk_gimme;
1644 PUSHBLOCK(cx, CXt_BLOCK, SP);
1656 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1657 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1659 #ifdef PERL_COPY_ON_WRITE
1660 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1662 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1666 if (SvTYPE(hv) == SVt_PVHV) {
1667 if (PL_op->op_private & OPpLVAL_INTRO) {
1670 /* does the element we're localizing already exist? */
1672 /* can we determine whether it exists? */
1674 || mg_find((SV*)hv, PERL_MAGIC_env)
1675 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1676 /* Try to preserve the existenceness of a tied hash
1677 * element by using EXISTS and DELETE if possible.
1678 * Fallback to FETCH and STORE otherwise */
1679 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1680 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1681 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1683 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1686 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1687 svp = he ? &HeVAL(he) : 0;
1693 if (!svp || *svp == &PL_sv_undef) {
1698 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1700 lv = sv_newmortal();
1701 sv_upgrade(lv, SVt_PVLV);
1703 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1704 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1705 LvTARG(lv) = SvREFCNT_inc(hv);
1710 if (PL_op->op_private & OPpLVAL_INTRO) {
1711 if (HvNAME(hv) && isGV(*svp))
1712 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1716 char *key = SvPV(keysv, keylen);
1717 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1719 save_helem(hv, keysv, svp);
1722 else if (PL_op->op_private & OPpDEREF)
1723 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1725 sv = (svp ? *svp : &PL_sv_undef);
1726 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1727 * Pushing the magical RHS on to the stack is useless, since
1728 * that magic is soon destined to be misled by the local(),
1729 * and thus the later pp_sassign() will fail to mg_get() the
1730 * old value. This should also cure problems with delayed
1731 * mg_get()s. GSAR 98-07-03 */
1732 if (!lval && SvGMAGICAL(sv))
1733 sv = sv_mortalcopy(sv);
1741 register PERL_CONTEXT *cx;
1747 if (PL_op->op_flags & OPf_SPECIAL) {
1748 cx = &cxstack[cxstack_ix];
1749 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1754 gimme = OP_GIMME(PL_op, -1);
1756 if (cxstack_ix >= 0)
1757 gimme = cxstack[cxstack_ix].blk_gimme;
1763 if (gimme == G_VOID)
1765 else if (gimme == G_SCALAR) {
1768 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1771 *MARK = sv_mortalcopy(TOPs);
1774 *MARK = &PL_sv_undef;
1778 else if (gimme == G_ARRAY) {
1779 /* in case LEAVE wipes old return values */
1780 for (mark = newsp + 1; mark <= SP; mark++) {
1781 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1782 *mark = sv_mortalcopy(*mark);
1783 TAINT_NOT; /* Each item is independent */
1787 PL_curpm = newpm; /* Don't pop $1 et al till now */
1797 register PERL_CONTEXT *cx;
1803 cx = &cxstack[cxstack_ix];
1804 if (CxTYPE(cx) != CXt_LOOP)
1805 DIE(aTHX_ "panic: pp_iter");
1807 itersvp = CxITERVAR(cx);
1808 av = cx->blk_loop.iterary;
1809 if (SvTYPE(av) != SVt_PVAV) {
1810 /* iterate ($min .. $max) */
1811 if (cx->blk_loop.iterlval) {
1812 /* string increment */
1813 register SV* cur = cx->blk_loop.iterlval;
1815 char *max = SvPV((SV*)av, maxlen);
1816 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1817 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1818 /* safe to reuse old SV */
1819 sv_setsv(*itersvp, cur);
1823 /* we need a fresh SV every time so that loop body sees a
1824 * completely new SV for closures/references to work as
1826 SvREFCNT_dec(*itersvp);
1827 *itersvp = newSVsv(cur);
1829 if (strEQ(SvPVX(cur), max))
1830 sv_setiv(cur, 0); /* terminate next time */
1837 /* integer increment */
1838 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1841 /* don't risk potential race */
1842 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1843 /* safe to reuse old SV */
1844 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1848 /* we need a fresh SV every time so that loop body sees a
1849 * completely new SV for closures/references to work as they
1851 SvREFCNT_dec(*itersvp);
1852 *itersvp = newSViv(cx->blk_loop.iterix++);
1858 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1861 SvREFCNT_dec(*itersvp);
1863 if (SvMAGICAL(av) || AvREIFY(av)) {
1864 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1871 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1873 if (sv && SvREFCNT(sv) == 0) {
1876 "Use of freed value in iteration (perhaps you modified the iterated array within the loop?)");
1883 if (av != PL_curstack && sv == &PL_sv_undef) {
1884 SV *lv = cx->blk_loop.iterlval;
1885 if (lv && SvREFCNT(lv) > 1) {
1890 SvREFCNT_dec(LvTARG(lv));
1892 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1893 sv_upgrade(lv, SVt_PVLV);
1895 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1897 LvTARG(lv) = SvREFCNT_inc(av);
1898 LvTARGOFF(lv) = cx->blk_loop.iterix;
1899 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1903 *itersvp = SvREFCNT_inc(sv);
1910 register PMOP *pm = cPMOP;
1926 register REGEXP *rx = PM_GETRE(pm);
1928 int force_on_match = 0;
1929 I32 oldsave = PL_savestack_ix;
1931 bool doutf8 = FALSE;
1932 #ifdef PERL_COPY_ON_WRITE
1937 /* known replacement string? */
1938 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1939 if (PL_op->op_flags & OPf_STACKED)
1946 #ifdef PERL_COPY_ON_WRITE
1947 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1948 because they make integers such as 256 "false". */
1949 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1952 sv_force_normal_flags(TARG,0);
1955 #ifdef PERL_COPY_ON_WRITE
1959 || (SvTYPE(TARG) > SVt_PVLV
1960 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1961 DIE(aTHX_ PL_no_modify);
1964 s = SvPV(TARG, len);
1965 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1967 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1968 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1973 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1977 DIE(aTHX_ "panic: pp_subst");
1980 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
1981 maxiters = 2 * slen + 10; /* We can match twice at each
1982 position, once with zero-length,
1983 second time with non-zero. */
1985 if (!rx->prelen && PL_curpm) {
1989 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1990 ? REXEC_COPY_STR : 0;
1992 r_flags |= REXEC_SCREAM;
1993 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1994 SAVEINT(PL_multiline);
1995 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1998 if (rx->reganch & RE_USE_INTUIT) {
2000 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2004 /* How to do it in subst? */
2005 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2007 && ((rx->reganch & ROPT_NOSCAN)
2008 || !((rx->reganch & RE_INTUIT_TAIL)
2009 && (r_flags & REXEC_SCREAM))))
2014 /* only replace once? */
2015 once = !(rpm->op_pmflags & PMf_GLOBAL);
2017 /* known replacement string? */
2019 /* replacement needing upgrading? */
2020 if (DO_UTF8(TARG) && !doutf8) {
2021 nsv = sv_newmortal();
2024 sv_recode_to_utf8(nsv, PL_encoding);
2026 sv_utf8_upgrade(nsv);
2027 c = SvPV(nsv, clen);
2031 c = SvPV(dstr, clen);
2032 doutf8 = DO_UTF8(dstr);
2040 /* can do inplace substitution? */
2042 #ifdef PERL_COPY_ON_WRITE
2045 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2046 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2047 && (!doutf8 || SvUTF8(TARG))) {
2048 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2049 r_flags | REXEC_CHECKED))
2053 LEAVE_SCOPE(oldsave);
2056 #ifdef PERL_COPY_ON_WRITE
2057 if (SvIsCOW(TARG)) {
2058 assert (!force_on_match);
2062 if (force_on_match) {
2064 s = SvPV_force(TARG, len);
2069 SvSCREAM_off(TARG); /* disable possible screamer */
2071 rxtainted |= RX_MATCH_TAINTED(rx);
2072 m = orig + rx->startp[0];
2073 d = orig + rx->endp[0];
2075 if (m - s > strend - d) { /* faster to shorten from end */
2077 Copy(c, m, clen, char);
2082 Move(d, m, i, char);
2086 SvCUR_set(TARG, m - s);
2089 else if ((i = m - s)) { /* faster from front */
2097 Copy(c, m, clen, char);
2102 Copy(c, d, clen, char);
2107 TAINT_IF(rxtainted & 1);
2113 if (iters++ > maxiters)
2114 DIE(aTHX_ "Substitution loop");
2115 rxtainted |= RX_MATCH_TAINTED(rx);
2116 m = rx->startp[0] + orig;
2120 Move(s, d, i, char);
2124 Copy(c, d, clen, char);
2127 s = rx->endp[0] + orig;
2128 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2130 /* don't match same null twice */
2131 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2134 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2135 Move(s, d, i+1, char); /* include the NUL */
2137 TAINT_IF(rxtainted & 1);
2139 PUSHs(sv_2mortal(newSViv((I32)iters)));
2141 (void)SvPOK_only_UTF8(TARG);
2142 TAINT_IF(rxtainted);
2143 if (SvSMAGICAL(TARG)) {
2151 LEAVE_SCOPE(oldsave);
2155 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2156 r_flags | REXEC_CHECKED))
2158 if (force_on_match) {
2160 s = SvPV_force(TARG, len);
2163 #ifdef PERL_COPY_ON_WRITE
2166 rxtainted |= RX_MATCH_TAINTED(rx);
2167 dstr = NEWSV(25, len);
2168 sv_setpvn(dstr, m, s-m);
2173 register PERL_CONTEXT *cx;
2177 RETURNOP(cPMOP->op_pmreplroot);
2179 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2181 if (iters++ > maxiters)
2182 DIE(aTHX_ "Substitution loop");
2183 rxtainted |= RX_MATCH_TAINTED(rx);
2184 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2189 strend = s + (strend - m);
2191 m = rx->startp[0] + orig;
2192 if (doutf8 && !SvUTF8(dstr))
2193 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2195 sv_catpvn(dstr, s, m-s);
2196 s = rx->endp[0] + orig;
2198 sv_catpvn(dstr, c, clen);
2201 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2202 TARG, NULL, r_flags));
2203 if (doutf8 && !DO_UTF8(TARG))
2204 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2206 sv_catpvn(dstr, s, strend - s);
2208 #ifdef PERL_COPY_ON_WRITE
2209 /* The match may make the string COW. If so, brilliant, because that's
2210 just saved us one malloc, copy and free - the regexp has donated
2211 the old buffer, and we malloc an entirely new one, rather than the
2212 regexp malloc()ing a buffer and copying our original, only for
2213 us to throw it away here during the substitution. */
2214 if (SvIsCOW(TARG)) {
2215 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2219 (void)SvOOK_off(TARG);
2221 Safefree(SvPVX(TARG));
2223 SvPVX(TARG) = SvPVX(dstr);
2224 SvCUR_set(TARG, SvCUR(dstr));
2225 SvLEN_set(TARG, SvLEN(dstr));
2226 doutf8 |= DO_UTF8(dstr);
2230 TAINT_IF(rxtainted & 1);
2232 PUSHs(sv_2mortal(newSViv((I32)iters)));
2234 (void)SvPOK_only(TARG);
2237 TAINT_IF(rxtainted);
2240 LEAVE_SCOPE(oldsave);
2249 LEAVE_SCOPE(oldsave);
2258 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2259 ++*PL_markstack_ptr;
2260 LEAVE; /* exit inner scope */
2263 if (PL_stack_base + *PL_markstack_ptr > SP) {
2265 I32 gimme = GIMME_V;
2267 LEAVE; /* exit outer scope */
2268 (void)POPMARK; /* pop src */
2269 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2270 (void)POPMARK; /* pop dst */
2271 SP = PL_stack_base + POPMARK; /* pop original mark */
2272 if (gimme == G_SCALAR) {
2276 else if (gimme == G_ARRAY)
2283 ENTER; /* enter inner scope */
2286 src = PL_stack_base[*PL_markstack_ptr];
2290 RETURNOP(cLOGOP->op_other);
2301 register PERL_CONTEXT *cx;
2305 cxstack_ix++; /* temporarily protect top context */
2308 if (gimme == G_SCALAR) {
2311 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2313 *MARK = SvREFCNT_inc(TOPs);
2318 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2320 *MARK = sv_mortalcopy(sv);
2325 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2329 *MARK = &PL_sv_undef;
2333 else if (gimme == G_ARRAY) {
2334 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2335 if (!SvTEMP(*MARK)) {
2336 *MARK = sv_mortalcopy(*MARK);
2337 TAINT_NOT; /* Each item is independent */
2345 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2346 PL_curpm = newpm; /* ... and pop $1 et al */
2349 return pop_return();
2352 /* This duplicates the above code because the above code must not
2353 * get any slower by more conditions */
2361 register PERL_CONTEXT *cx;
2365 cxstack_ix++; /* temporarily protect top context */
2369 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2370 /* We are an argument to a function or grep().
2371 * This kind of lvalueness was legal before lvalue
2372 * subroutines too, so be backward compatible:
2373 * cannot report errors. */
2375 /* Scalar context *is* possible, on the LHS of -> only,
2376 * as in f()->meth(). But this is not an lvalue. */
2377 if (gimme == G_SCALAR)
2379 if (gimme == G_ARRAY) {
2380 if (!CvLVALUE(cx->blk_sub.cv))
2381 goto temporise_array;
2382 EXTEND_MORTAL(SP - newsp);
2383 for (mark = newsp + 1; mark <= SP; mark++) {
2386 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2387 *mark = sv_mortalcopy(*mark);
2389 /* Can be a localized value subject to deletion. */
2390 PL_tmps_stack[++PL_tmps_ix] = *mark;
2391 (void)SvREFCNT_inc(*mark);
2396 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2397 /* Here we go for robustness, not for speed, so we change all
2398 * the refcounts so the caller gets a live guy. Cannot set
2399 * TEMP, so sv_2mortal is out of question. */
2400 if (!CvLVALUE(cx->blk_sub.cv)) {
2406 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2408 if (gimme == G_SCALAR) {
2412 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2418 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2419 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2420 : "a readonly value" : "a temporary");
2422 else { /* Can be a localized value
2423 * subject to deletion. */
2424 PL_tmps_stack[++PL_tmps_ix] = *mark;
2425 (void)SvREFCNT_inc(*mark);
2428 else { /* Should not happen? */
2434 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2435 (MARK > SP ? "Empty array" : "Array"));
2439 else if (gimme == G_ARRAY) {
2440 EXTEND_MORTAL(SP - newsp);
2441 for (mark = newsp + 1; mark <= SP; mark++) {
2442 if (*mark != &PL_sv_undef
2443 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2444 /* Might be flattened array after $#array = */
2451 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2452 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2455 /* Can be a localized value subject to deletion. */
2456 PL_tmps_stack[++PL_tmps_ix] = *mark;
2457 (void)SvREFCNT_inc(*mark);
2463 if (gimme == G_SCALAR) {
2467 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2469 *MARK = SvREFCNT_inc(TOPs);
2474 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2476 *MARK = sv_mortalcopy(sv);
2481 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2485 *MARK = &PL_sv_undef;
2489 else if (gimme == G_ARRAY) {
2491 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2492 if (!SvTEMP(*MARK)) {
2493 *MARK = sv_mortalcopy(*MARK);
2494 TAINT_NOT; /* Each item is independent */
2503 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2504 PL_curpm = newpm; /* ... and pop $1 et al */
2507 return pop_return();
2512 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2514 SV *dbsv = GvSV(PL_DBsub);
2516 if (!PERLDB_SUB_NN) {
2520 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2521 || strEQ(GvNAME(gv), "END")
2522 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2523 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2524 && (gv = (GV*)*svp) ))) {
2525 /* Use GV from the stack as a fallback. */
2526 /* GV is potentially non-unique, or contain different CV. */
2527 SV *tmp = newRV((SV*)cv);
2528 sv_setsv(dbsv, tmp);
2532 gv_efullname3(dbsv, gv, Nullch);
2536 (void)SvUPGRADE(dbsv, SVt_PVIV);
2537 (void)SvIOK_on(dbsv);
2538 SAVEIV(SvIVX(dbsv));
2539 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2543 PL_curcopdb = PL_curcop;
2544 cv = GvCV(PL_DBsub);
2554 register PERL_CONTEXT *cx;
2556 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2559 DIE(aTHX_ "Not a CODE reference");
2560 switch (SvTYPE(sv)) {
2561 /* This is overwhelming the most common case: */
2563 if (!(cv = GvCVu((GV*)sv)))
2564 cv = sv_2cv(sv, &stash, &gv, FALSE);
2576 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2578 SP = PL_stack_base + POPMARK;
2581 if (SvGMAGICAL(sv)) {
2585 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2588 sym = SvPV(sv, n_a);
2590 DIE(aTHX_ PL_no_usym, "a subroutine");
2591 if (PL_op->op_private & HINT_STRICT_REFS)
2592 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2593 cv = get_cv(sym, TRUE);
2598 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2599 tryAMAGICunDEREF(to_cv);
2602 if (SvTYPE(cv) == SVt_PVCV)
2607 DIE(aTHX_ "Not a CODE reference");
2608 /* This is the second most common case: */
2618 if (!CvROOT(cv) && !CvXSUB(cv)) {
2623 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2624 if (CvASSERTION(cv) && PL_DBassertion)
2625 sv_setiv(PL_DBassertion, 1);
2627 cv = get_db_sub(&sv, cv);
2629 DIE(aTHX_ "No DBsub routine");
2632 if (!(CvXSUB(cv))) {
2633 /* This path taken at least 75% of the time */
2635 register I32 items = SP - MARK;
2636 AV* padlist = CvPADLIST(cv);
2637 push_return(PL_op->op_next);
2638 PUSHBLOCK(cx, CXt_SUB, MARK);
2641 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2642 * that eval'' ops within this sub know the correct lexical space.
2643 * Owing the speed considerations, we choose instead to search for
2644 * the cv using find_runcv() when calling doeval().
2646 if (CvDEPTH(cv) < 2)
2647 (void)SvREFCNT_inc(cv);
2649 PERL_STACK_OVERFLOW_CHECK();
2650 pad_push(padlist, CvDEPTH(cv), 1);
2652 PAD_SET_CUR(padlist, CvDEPTH(cv));
2659 DEBUG_S(PerlIO_printf(Perl_debug_log,
2660 "%p entersub preparing @_\n", thr));
2662 av = (AV*)PAD_SVl(0);
2664 /* @_ is normally not REAL--this should only ever
2665 * happen when DB::sub() calls things that modify @_ */
2670 cx->blk_sub.savearray = GvAV(PL_defgv);
2671 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2672 CX_CURPAD_SAVE(cx->blk_sub);
2673 cx->blk_sub.argarray = av;
2676 if (items > AvMAX(av) + 1) {
2678 if (AvARRAY(av) != ary) {
2679 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2680 SvPVX(av) = (char*)ary;
2682 if (items > AvMAX(av) + 1) {
2683 AvMAX(av) = items - 1;
2684 Renew(ary,items,SV*);
2686 SvPVX(av) = (char*)ary;
2689 Copy(MARK,AvARRAY(av),items,SV*);
2690 AvFILLp(av) = items - 1;
2698 /* warning must come *after* we fully set up the context
2699 * stuff so that __WARN__ handlers can safely dounwind()
2702 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2703 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2704 sub_crush_depth(cv);
2706 DEBUG_S(PerlIO_printf(Perl_debug_log,
2707 "%p entersub returning %p\n", thr, CvSTART(cv)));
2709 RETURNOP(CvSTART(cv));
2712 #ifdef PERL_XSUB_OLDSTYLE
2713 if (CvOLDSTYLE(cv)) {
2714 I32 (*fp3)(int,int,int);
2716 register I32 items = SP - MARK;
2717 /* We dont worry to copy from @_. */
2722 PL_stack_sp = mark + 1;
2723 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2724 items = (*fp3)(CvXSUBANY(cv).any_i32,
2725 MARK - PL_stack_base + 1,
2727 PL_stack_sp = PL_stack_base + items;
2730 #endif /* PERL_XSUB_OLDSTYLE */
2732 I32 markix = TOPMARK;
2737 /* Need to copy @_ to stack. Alternative may be to
2738 * switch stack to @_, and copy return values
2739 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2742 av = GvAV(PL_defgv);
2743 items = AvFILLp(av) + 1; /* @_ is not tieable */
2746 /* Mark is at the end of the stack. */
2748 Copy(AvARRAY(av), SP + 1, items, SV*);
2753 /* We assume first XSUB in &DB::sub is the called one. */
2755 SAVEVPTR(PL_curcop);
2756 PL_curcop = PL_curcopdb;
2759 /* Do we need to open block here? XXXX */
2760 (void)(*CvXSUB(cv))(aTHX_ cv);
2762 /* Enforce some sanity in scalar context. */
2763 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2764 if (markix > PL_stack_sp - PL_stack_base)
2765 *(PL_stack_base + markix) = &PL_sv_undef;
2767 *(PL_stack_base + markix) = *PL_stack_sp;
2768 PL_stack_sp = PL_stack_base + markix;
2775 assert (0); /* Cannot get here. */
2776 /* This is deliberately moved here as spaghetti code to keep it out of the
2783 /* anonymous or undef'd function leaves us no recourse */
2784 if (CvANON(cv) || !(gv = CvGV(cv)))
2785 DIE(aTHX_ "Undefined subroutine called");
2787 /* autoloaded stub? */
2788 if (cv != GvCV(gv)) {
2791 /* should call AUTOLOAD now? */
2794 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2801 sub_name = sv_newmortal();
2802 gv_efullname3(sub_name, gv, Nullch);
2803 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2807 DIE(aTHX_ "Not a CODE reference");
2813 Perl_sub_crush_depth(pTHX_ CV *cv)
2816 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2818 SV* tmpstr = sv_newmortal();
2819 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2820 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2830 IV elem = SvIV(elemsv);
2832 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2833 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2836 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2837 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2839 elem -= PL_curcop->cop_arybase;
2840 if (SvTYPE(av) != SVt_PVAV)
2842 svp = av_fetch(av, elem, lval && !defer);
2844 if (!svp || *svp == &PL_sv_undef) {
2847 DIE(aTHX_ PL_no_aelem, elem);
2848 lv = sv_newmortal();
2849 sv_upgrade(lv, SVt_PVLV);
2851 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2852 LvTARG(lv) = SvREFCNT_inc(av);
2853 LvTARGOFF(lv) = elem;
2858 if (PL_op->op_private & OPpLVAL_INTRO)
2859 save_aelem(av, elem, svp);
2860 else if (PL_op->op_private & OPpDEREF)
2861 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2863 sv = (svp ? *svp : &PL_sv_undef);
2864 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2865 sv = sv_mortalcopy(sv);
2871 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2877 Perl_croak(aTHX_ PL_no_modify);
2878 if (SvTYPE(sv) < SVt_RV)
2879 sv_upgrade(sv, SVt_RV);
2880 else if (SvTYPE(sv) >= SVt_PV) {
2881 (void)SvOOK_off(sv);
2882 Safefree(SvPVX(sv));
2883 SvLEN(sv) = SvCUR(sv) = 0;
2887 SvRV(sv) = NEWSV(355,0);
2890 SvRV(sv) = (SV*)newAV();
2893 SvRV(sv) = (SV*)newHV();
2908 if (SvTYPE(rsv) == SVt_PVCV) {
2914 SETs(method_common(sv, Null(U32*)));
2922 U32 hash = SvUVX(sv);
2924 XPUSHs(method_common(sv, &hash));
2929 S_method_common(pTHX_ SV* meth, U32* hashp)
2938 SV *packsv = Nullsv;
2941 name = SvPV(meth, namelen);
2942 sv = *(PL_stack_base + TOPMARK + 1);
2945 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2954 /* this isn't a reference */
2957 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2959 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2961 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2968 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2969 !(ob=(SV*)GvIO(iogv)))
2971 /* this isn't the name of a filehandle either */
2973 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2974 ? !isIDFIRST_utf8((U8*)packname)
2975 : !isIDFIRST(*packname)
2978 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2979 SvOK(sv) ? "without a package or object reference"
2980 : "on an undefined value");
2982 /* assume it's a package name */
2983 stash = gv_stashpvn(packname, packlen, FALSE);
2987 SV* ref = newSViv(PTR2IV(stash));
2988 hv_store(PL_stashcache, packname, packlen, ref, 0);
2992 /* it _is_ a filehandle name -- replace with a reference */
2993 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2996 /* if we got here, ob should be a reference or a glob */
2997 if (!ob || !(SvOBJECT(ob)
2998 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3001 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3005 stash = SvSTASH(ob);
3008 /* NOTE: stash may be null, hope hv_fetch_ent and
3009 gv_fetchmethod can cope (it seems they can) */
3011 /* shortcut for simple names */
3013 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3015 gv = (GV*)HeVAL(he);
3016 if (isGV(gv) && GvCV(gv) &&
3017 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3018 return (SV*)GvCV(gv);
3022 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3025 /* This code tries to figure out just what went wrong with
3026 gv_fetchmethod. It therefore needs to duplicate a lot of
3027 the internals of that function. We can't move it inside
3028 Perl_gv_fetchmethod_autoload(), however, since that would
3029 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3036 for (p = name; *p; p++) {
3038 sep = p, leaf = p + 1;
3039 else if (*p == ':' && *(p + 1) == ':')
3040 sep = p, leaf = p + 2;
3042 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3043 /* the method name is unqualified or starts with SUPER:: */
3044 packname = sep ? CopSTASHPV(PL_curcop) :
3045 stash ? HvNAME(stash) : packname;
3048 "Can't use anonymous symbol table for method lookup");
3050 packlen = strlen(packname);
3053 /* the method name is qualified */
3055 packlen = sep - name;
3058 /* we're relying on gv_fetchmethod not autovivifying the stash */
3059 if (gv_stashpvn(packname, packlen, FALSE)) {
3061 "Can't locate object method \"%s\" via package \"%.*s\"",
3062 leaf, (int)packlen, packname);
3066 "Can't locate object method \"%s\" via package \"%.*s\""
3067 " (perhaps you forgot to load \"%.*s\"?)",
3068 leaf, (int)packlen, packname, (int)packlen, packname);
3071 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;