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 = !DO_UTF8(right), rcopied = FALSE;
142 if (TARG == right && right != left) {
143 right = sv_2mortal(newSVpvn(rpv, rlen));
144 rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
149 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
150 lbyte = !DO_UTF8(left);
151 sv_setpvn(TARG, lpv, llen);
157 else { /* TARG == left */
158 if (SvGMAGICAL(left))
159 mg_get(left); /* or mg_get(left) may happen here */
162 lpv = SvPV_nomg(left, llen);
163 lbyte = !DO_UTF8(left);
168 #if defined(PERL_Y2KWARN)
169 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
170 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
171 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
173 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
174 "about to append an integer to '19'");
179 if (lbyte != rbyte) {
181 sv_utf8_upgrade_nomg(TARG);
184 right = sv_2mortal(newSVpvn(rpv, rlen));
185 sv_utf8_upgrade_nomg(right);
186 rpv = SvPV(right, rlen);
189 sv_catpvn_nomg(TARG, rpv, rlen);
200 if (PL_op->op_flags & OPf_MOD) {
201 if (PL_op->op_private & OPpLVAL_INTRO)
202 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
203 else if (PL_op->op_private & OPpDEREF) {
205 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
214 tryAMAGICunTARGET(iter, 0);
215 PL_last_in_gv = (GV*)(*PL_stack_sp--);
216 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
217 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
218 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
221 XPUSHs((SV*)PL_last_in_gv);
224 PL_last_in_gv = (GV*)(*PL_stack_sp--);
227 return do_readline();
232 dSP; tryAMAGICbinSET(eq,0);
233 #ifndef NV_PRESERVES_UV
234 if (SvROK(TOPs) && SvROK(TOPm1s)) {
236 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
240 #ifdef PERL_PRESERVE_IVUV
243 /* Unless the left argument is integer in range we are going
244 to have to use NV maths. Hence only attempt to coerce the
245 right argument if we know the left is integer. */
248 bool auvok = SvUOK(TOPm1s);
249 bool buvok = SvUOK(TOPs);
251 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
252 /* Casting IV to UV before comparison isn't going to matter
253 on 2s complement. On 1s complement or sign&magnitude
254 (if we have any of them) it could to make negative zero
255 differ from normal zero. As I understand it. (Need to
256 check - is negative zero implementation defined behaviour
258 UV buv = SvUVX(POPs);
259 UV auv = SvUVX(TOPs);
261 SETs(boolSV(auv == buv));
264 { /* ## Mixed IV,UV ## */
268 /* == is commutative so doesn't matter which is left or right */
270 /* top of stack (b) is the iv */
279 /* As uv is a UV, it's >0, so it cannot be == */
283 /* we know iv is >= 0 */
284 SETs(boolSV((UV)iv == SvUVX(uvp)));
292 SETs(boolSV(TOPn == value));
300 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
301 DIE(aTHX_ PL_no_modify);
302 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
303 && SvIVX(TOPs) != IV_MAX)
306 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
308 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
321 RETURNOP(cLOGOP->op_other);
327 /* Most of this is lifted straight from pp_defined */
332 if (!sv || !SvANY(sv)) {
334 RETURNOP(cLOGOP->op_other);
337 switch (SvTYPE(sv)) {
339 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
343 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
347 if (CvROOT(sv) || CvXSUB(sv))
358 RETURNOP(cLOGOP->op_other);
363 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
364 useleft = USE_LEFT(TOPm1s);
365 #ifdef PERL_PRESERVE_IVUV
366 /* We must see if we can perform the addition with integers if possible,
367 as the integer code detects overflow while the NV code doesn't.
368 If either argument hasn't had a numeric conversion yet attempt to get
369 the IV. It's important to do this now, rather than just assuming that
370 it's not IOK as a PV of "9223372036854775806" may not take well to NV
371 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
372 integer in case the second argument is IV=9223372036854775806
373 We can (now) rely on sv_2iv to do the right thing, only setting the
374 public IOK flag if the value in the NV (or PV) slot is truly integer.
376 A side effect is that this also aggressively prefers integer maths over
377 fp maths for integer values.
379 How to detect overflow?
381 C 99 section 6.2.6.1 says
383 The range of nonnegative values of a signed integer type is a subrange
384 of the corresponding unsigned integer type, and the representation of
385 the same value in each type is the same. A computation involving
386 unsigned operands can never overflow, because a result that cannot be
387 represented by the resulting unsigned integer type is reduced modulo
388 the number that is one greater than the largest value that can be
389 represented by the resulting type.
393 which I read as "unsigned ints wrap."
395 signed integer overflow seems to be classed as "exception condition"
397 If an exceptional condition occurs during the evaluation of an
398 expression (that is, if the result is not mathematically defined or not
399 in the range of representable values for its type), the behavior is
402 (6.5, the 5th paragraph)
404 I had assumed that on 2s complement machines signed arithmetic would
405 wrap, hence coded pp_add and pp_subtract on the assumption that
406 everything perl builds on would be happy. After much wailing and
407 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
408 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
409 unsigned code below is actually shorter than the old code. :-)
414 /* Unless the left argument is integer in range we are going to have to
415 use NV maths. Hence only attempt to coerce the right argument if
416 we know the left is integer. */
424 /* left operand is undef, treat as zero. + 0 is identity,
425 Could SETi or SETu right now, but space optimise by not adding
426 lots of code to speed up what is probably a rarish case. */
428 /* Left operand is defined, so is it IV? */
431 if ((auvok = SvUOK(TOPm1s)))
434 register IV aiv = SvIVX(TOPm1s);
437 auvok = 1; /* Now acting as a sign flag. */
438 } else { /* 2s complement assumption for IV_MIN */
446 bool result_good = 0;
449 bool buvok = SvUOK(TOPs);
454 register IV biv = SvIVX(TOPs);
461 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
462 else "IV" now, independent of how it came in.
463 if a, b represents positive, A, B negative, a maps to -A etc
468 all UV maths. negate result if A negative.
469 add if signs same, subtract if signs differ. */
475 /* Must get smaller */
481 /* result really should be -(auv-buv). as its negation
482 of true value, need to swap our result flag */
499 if (result <= (UV)IV_MIN)
502 /* result valid, but out of range for IV. */
507 } /* Overflow, drop through to NVs. */
514 /* left operand is undef, treat as zero. + 0.0 is identity. */
518 SETn( value + TOPn );
526 AV *av = PL_op->op_flags & OPf_SPECIAL ?
527 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
528 U32 lval = PL_op->op_flags & OPf_MOD;
529 SV** svp = av_fetch(av, PL_op->op_private, lval);
530 SV *sv = (svp ? *svp : &PL_sv_undef);
532 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
533 sv = sv_mortalcopy(sv);
542 do_join(TARG, *MARK, MARK, SP);
553 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
554 * will be enough to hold an OP*.
556 SV* sv = sv_newmortal();
557 sv_upgrade(sv, SVt_PVLV);
559 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
567 /* Oversized hot code. */
571 dSP; dMARK; dORIGMARK;
577 if (PL_op->op_flags & OPf_STACKED)
582 if (gv && (io = GvIO(gv))
583 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
586 if (MARK == ORIGMARK) {
587 /* If using default handle then we need to make space to
588 * pass object as 1st arg, so move other args up ...
592 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
596 *MARK = SvTIED_obj((SV*)io, mg);
599 call_method("PRINT", G_SCALAR);
607 if (!(io = GvIO(gv))) {
608 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
609 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
611 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
612 report_evil_fh(gv, io, PL_op->op_type);
613 SETERRNO(EBADF,RMS_IFI);
616 else if (!(fp = IoOFP(io))) {
617 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
619 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
620 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
621 report_evil_fh(gv, io, PL_op->op_type);
623 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
628 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
630 if (!do_print(*MARK, fp))
634 if (!do_print(PL_ofs_sv, fp)) { /* $, */
643 if (!do_print(*MARK, fp))
651 if (PL_ors_sv && SvOK(PL_ors_sv))
652 if (!do_print(PL_ors_sv, fp)) /* $\ */
655 if (IoFLAGS(io) & IOf_FLUSH)
656 if (PerlIO_flush(fp) == EOF)
677 tryAMAGICunDEREF(to_av);
680 if (SvTYPE(av) != SVt_PVAV)
681 DIE(aTHX_ "Not an ARRAY reference");
682 if (PL_op->op_flags & OPf_REF) {
687 if (GIMME == G_SCALAR)
688 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
692 else if (PL_op->op_flags & OPf_MOD
693 && PL_op->op_private & OPpLVAL_INTRO)
694 Perl_croak(aTHX_ PL_no_localize_ref);
697 if (SvTYPE(sv) == SVt_PVAV) {
699 if (PL_op->op_flags & OPf_REF) {
704 if (GIMME == G_SCALAR)
705 Perl_croak(aTHX_ "Can't return array to lvalue"
714 if (SvTYPE(sv) != SVt_PVGV) {
718 if (SvGMAGICAL(sv)) {
724 if (PL_op->op_flags & OPf_REF ||
725 PL_op->op_private & HINT_STRICT_REFS)
726 DIE(aTHX_ PL_no_usym, "an ARRAY");
727 if (ckWARN(WARN_UNINITIALIZED))
729 if (GIMME == G_ARRAY) {
736 if ((PL_op->op_flags & OPf_SPECIAL) &&
737 !(PL_op->op_flags & OPf_MOD))
739 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
741 && (!is_gv_magical(sym,len,0)
742 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
748 if (PL_op->op_private & HINT_STRICT_REFS)
749 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
750 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
757 if (PL_op->op_private & OPpLVAL_INTRO)
759 if (PL_op->op_flags & OPf_REF) {
764 if (GIMME == G_SCALAR)
765 Perl_croak(aTHX_ "Can't return array to lvalue"
773 if (GIMME == G_ARRAY) {
774 I32 maxarg = AvFILL(av) + 1;
775 (void)POPs; /* XXXX May be optimized away? */
777 if (SvRMAGICAL(av)) {
779 for (i=0; i < (U32)maxarg; i++) {
780 SV **svp = av_fetch(av, i, FALSE);
781 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
785 Copy(AvARRAY(av), SP+1, maxarg, SV*);
789 else if (GIMME_V == G_SCALAR) {
791 I32 maxarg = AvFILL(av) + 1;
805 tryAMAGICunDEREF(to_hv);
808 if (SvTYPE(hv) != SVt_PVHV)
809 DIE(aTHX_ "Not a HASH reference");
810 if (PL_op->op_flags & OPf_REF) {
815 if (gimme != G_ARRAY)
816 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
820 else if (PL_op->op_flags & OPf_MOD
821 && PL_op->op_private & OPpLVAL_INTRO)
822 Perl_croak(aTHX_ PL_no_localize_ref);
825 if (SvTYPE(sv) == SVt_PVHV) {
827 if (PL_op->op_flags & OPf_REF) {
832 if (gimme != G_ARRAY)
833 Perl_croak(aTHX_ "Can't return hash to lvalue"
842 if (SvTYPE(sv) != SVt_PVGV) {
846 if (SvGMAGICAL(sv)) {
852 if (PL_op->op_flags & OPf_REF ||
853 PL_op->op_private & HINT_STRICT_REFS)
854 DIE(aTHX_ PL_no_usym, "a HASH");
855 if (ckWARN(WARN_UNINITIALIZED))
857 if (gimme == G_ARRAY) {
864 if ((PL_op->op_flags & OPf_SPECIAL) &&
865 !(PL_op->op_flags & OPf_MOD))
867 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
869 && (!is_gv_magical(sym,len,0)
870 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
876 if (PL_op->op_private & HINT_STRICT_REFS)
877 DIE(aTHX_ PL_no_symref, sym, "a HASH");
878 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
885 if (PL_op->op_private & OPpLVAL_INTRO)
887 if (PL_op->op_flags & OPf_REF) {
892 if (gimme != G_ARRAY)
893 Perl_croak(aTHX_ "Can't return hash to lvalue"
901 if (gimme == G_ARRAY) { /* array wanted */
902 *PL_stack_sp = (SV*)hv;
905 else if (gimme == G_SCALAR) {
907 TARG = Perl_hv_scalar(aTHX_ hv);
914 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
920 if (ckWARN(WARN_MISC)) {
921 if (relem == firstrelem &&
923 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
924 SvTYPE(SvRV(*relem)) == SVt_PVHV))
926 Perl_warner(aTHX_ packWARN(WARN_MISC),
927 "Reference found where even-sized list expected");
930 Perl_warner(aTHX_ packWARN(WARN_MISC),
931 "Odd number of elements in hash assignment");
934 tmpstr = NEWSV(29,0);
935 didstore = hv_store_ent(hash,*relem,tmpstr,0);
936 if (SvMAGICAL(hash)) {
937 if (SvSMAGICAL(tmpstr))
949 SV **lastlelem = PL_stack_sp;
950 SV **lastrelem = PL_stack_base + POPMARK;
951 SV **firstrelem = PL_stack_base + POPMARK + 1;
952 SV **firstlelem = lastrelem + 1;
965 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
968 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
971 /* If there's a common identifier on both sides we have to take
972 * special care that assigning the identifier on the left doesn't
973 * clobber a value on the right that's used later in the list.
975 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
976 EXTEND_MORTAL(lastrelem - firstrelem + 1);
977 for (relem = firstrelem; relem <= lastrelem; relem++) {
980 TAINT_NOT; /* Each item is independent */
981 *relem = sv_mortalcopy(sv);
991 while (lelem <= lastlelem) {
992 TAINT_NOT; /* Each item stands on its own, taintwise. */
994 switch (SvTYPE(sv)) {
997 magic = SvMAGICAL(ary) != 0;
999 av_extend(ary, lastrelem - relem);
1001 while (relem <= lastrelem) { /* gobble up all the rest */
1005 sv_setsv(sv,*relem);
1007 didstore = av_store(ary,i++,sv);
1017 case SVt_PVHV: { /* normal hash */
1021 magic = SvMAGICAL(hash) != 0;
1023 firsthashrelem = relem;
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 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1036 /* key overwrites an existing entry */
1038 didstore = hv_store_ent(hash,sv,tmpstr,0);
1040 if (SvSMAGICAL(tmpstr))
1047 if (relem == lastrelem) {
1048 do_oddball(hash, relem, firstrelem);
1054 if (SvIMMORTAL(sv)) {
1055 if (relem <= lastrelem)
1059 if (relem <= lastrelem) {
1060 sv_setsv(sv, *relem);
1064 sv_setsv(sv, &PL_sv_undef);
1069 if (PL_delaymagic & ~DM_DELAY) {
1070 if (PL_delaymagic & DM_UID) {
1071 #ifdef HAS_SETRESUID
1072 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1073 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1076 # ifdef HAS_SETREUID
1077 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1078 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1081 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1082 (void)setruid(PL_uid);
1083 PL_delaymagic &= ~DM_RUID;
1085 # endif /* HAS_SETRUID */
1087 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1088 (void)seteuid(PL_euid);
1089 PL_delaymagic &= ~DM_EUID;
1091 # endif /* HAS_SETEUID */
1092 if (PL_delaymagic & DM_UID) {
1093 if (PL_uid != PL_euid)
1094 DIE(aTHX_ "No setreuid available");
1095 (void)PerlProc_setuid(PL_uid);
1097 # endif /* HAS_SETREUID */
1098 #endif /* HAS_SETRESUID */
1099 PL_uid = PerlProc_getuid();
1100 PL_euid = PerlProc_geteuid();
1102 if (PL_delaymagic & DM_GID) {
1103 #ifdef HAS_SETRESGID
1104 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1105 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1108 # ifdef HAS_SETREGID
1109 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1110 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1113 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1114 (void)setrgid(PL_gid);
1115 PL_delaymagic &= ~DM_RGID;
1117 # endif /* HAS_SETRGID */
1119 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1120 (void)setegid(PL_egid);
1121 PL_delaymagic &= ~DM_EGID;
1123 # endif /* HAS_SETEGID */
1124 if (PL_delaymagic & DM_GID) {
1125 if (PL_gid != PL_egid)
1126 DIE(aTHX_ "No setregid available");
1127 (void)PerlProc_setgid(PL_gid);
1129 # endif /* HAS_SETREGID */
1130 #endif /* HAS_SETRESGID */
1131 PL_gid = PerlProc_getgid();
1132 PL_egid = PerlProc_getegid();
1134 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1138 if (gimme == G_VOID)
1139 SP = firstrelem - 1;
1140 else if (gimme == G_SCALAR) {
1143 SETi(lastrelem - firstrelem + 1 - duplicates);
1150 /* Removes from the stack the entries which ended up as
1151 * duplicated keys in the hash (fix for [perl #24380]) */
1152 Move(firsthashrelem + duplicates,
1153 firsthashrelem, duplicates, SV**);
1154 lastrelem -= duplicates;
1159 SP = firstrelem + (lastlelem - firstlelem);
1160 lelem = firstlelem + (relem - firstrelem);
1162 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1170 register PMOP *pm = cPMOP;
1171 SV *rv = sv_newmortal();
1172 SV *sv = newSVrv(rv, "Regexp");
1173 if (pm->op_pmdynflags & PMdf_TAINTED)
1175 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1182 register PMOP *pm = cPMOP;
1188 I32 r_flags = REXEC_CHECKED;
1189 char *truebase; /* Start of string */
1190 register REGEXP *rx = PM_GETRE(pm);
1195 I32 oldsave = PL_savestack_ix;
1196 I32 update_minmatch = 1;
1197 I32 had_zerolen = 0;
1199 if (PL_op->op_flags & OPf_STACKED)
1201 else if (PL_op->op_private & OPpTARGET_MY)
1208 PUTBACK; /* EVAL blocks need stack_sp. */
1209 s = SvPV(TARG, len);
1212 DIE(aTHX_ "panic: pp_match");
1213 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1214 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1217 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1219 /* PMdf_USED is set after a ?? matches once */
1220 if (pm->op_pmdynflags & PMdf_USED) {
1222 if (gimme == G_ARRAY)
1227 /* empty pattern special-cased to use last successful pattern if possible */
1228 if (!rx->prelen && PL_curpm) {
1233 if (rx->minlen > (I32)len)
1238 /* XXXX What part of this is needed with true \G-support? */
1239 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1241 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1242 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1243 if (mg && mg->mg_len >= 0) {
1244 if (!(rx->reganch & ROPT_GPOS_SEEN))
1245 rx->endp[0] = rx->startp[0] = mg->mg_len;
1246 else if (rx->reganch & ROPT_ANCH_GPOS) {
1247 r_flags |= REXEC_IGNOREPOS;
1248 rx->endp[0] = rx->startp[0] = mg->mg_len;
1250 minmatch = (mg->mg_flags & MGf_MINMATCH);
1251 update_minmatch = 0;
1255 if ((!global && rx->nparens)
1256 || SvTEMP(TARG) || PL_sawampersand)
1257 r_flags |= REXEC_COPY_STR;
1259 r_flags |= REXEC_SCREAM;
1261 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1262 SAVEINT(PL_multiline);
1263 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1267 if (global && rx->startp[0] != -1) {
1268 t = s = rx->endp[0] + truebase;
1269 if ((s + rx->minlen) > strend)
1271 if (update_minmatch++)
1272 minmatch = had_zerolen;
1274 if (rx->reganch & RE_USE_INTUIT &&
1275 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1276 PL_bostr = truebase;
1277 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1281 if ( (rx->reganch & ROPT_CHECK_ALL)
1283 && ((rx->reganch & ROPT_NOSCAN)
1284 || !((rx->reganch & RE_INTUIT_TAIL)
1285 && (r_flags & REXEC_SCREAM)))
1286 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1289 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1292 if (dynpm->op_pmflags & PMf_ONCE)
1293 dynpm->op_pmdynflags |= PMdf_USED;
1302 RX_MATCH_TAINTED_on(rx);
1303 TAINT_IF(RX_MATCH_TAINTED(rx));
1304 if (gimme == G_ARRAY) {
1305 I32 nparens, i, len;
1307 nparens = rx->nparens;
1308 if (global && !nparens)
1312 SPAGAIN; /* EVAL blocks could move the stack. */
1313 EXTEND(SP, nparens + i);
1314 EXTEND_MORTAL(nparens + i);
1315 for (i = !i; i <= nparens; i++) {
1316 PUSHs(sv_newmortal());
1318 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1319 len = rx->endp[i] - rx->startp[i];
1320 s = rx->startp[i] + truebase;
1321 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1322 len < 0 || len > strend - s)
1323 DIE(aTHX_ "panic: pp_match start/end pointers");
1324 sv_setpvn(*SP, s, len);
1325 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1330 if (dynpm->op_pmflags & PMf_CONTINUE) {
1332 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1333 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1335 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1336 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1338 if (rx->startp[0] != -1) {
1339 mg->mg_len = rx->endp[0];
1340 if (rx->startp[0] == rx->endp[0])
1341 mg->mg_flags |= MGf_MINMATCH;
1343 mg->mg_flags &= ~MGf_MINMATCH;
1346 had_zerolen = (rx->startp[0] != -1
1347 && rx->startp[0] == rx->endp[0]);
1348 PUTBACK; /* EVAL blocks may use stack */
1349 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1354 LEAVE_SCOPE(oldsave);
1360 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1361 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1363 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1364 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1366 if (rx->startp[0] != -1) {
1367 mg->mg_len = rx->endp[0];
1368 if (rx->startp[0] == rx->endp[0])
1369 mg->mg_flags |= MGf_MINMATCH;
1371 mg->mg_flags &= ~MGf_MINMATCH;
1374 LEAVE_SCOPE(oldsave);
1378 yup: /* Confirmed by INTUIT */
1380 RX_MATCH_TAINTED_on(rx);
1381 TAINT_IF(RX_MATCH_TAINTED(rx));
1383 if (dynpm->op_pmflags & PMf_ONCE)
1384 dynpm->op_pmdynflags |= PMdf_USED;
1385 if (RX_MATCH_COPIED(rx))
1386 Safefree(rx->subbeg);
1387 RX_MATCH_COPIED_off(rx);
1388 rx->subbeg = Nullch;
1390 rx->subbeg = truebase;
1391 rx->startp[0] = s - truebase;
1392 if (RX_MATCH_UTF8(rx)) {
1393 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1394 rx->endp[0] = t - truebase;
1397 rx->endp[0] = s - truebase + rx->minlen;
1399 rx->sublen = strend - truebase;
1402 if (PL_sawampersand) {
1404 #ifdef PERL_COPY_ON_WRITE
1405 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1407 PerlIO_printf(Perl_debug_log,
1408 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1409 (int) SvTYPE(TARG), truebase, t,
1412 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1413 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1414 assert (SvPOKp(rx->saved_copy));
1419 rx->subbeg = savepvn(t, strend - t);
1420 #ifdef PERL_COPY_ON_WRITE
1421 rx->saved_copy = Nullsv;
1424 rx->sublen = strend - t;
1425 RX_MATCH_COPIED_on(rx);
1426 off = rx->startp[0] = s - t;
1427 rx->endp[0] = off + rx->minlen;
1429 else { /* startp/endp are used by @- @+. */
1430 rx->startp[0] = s - truebase;
1431 rx->endp[0] = s - truebase + rx->minlen;
1433 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1434 LEAVE_SCOPE(oldsave);
1439 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1440 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1441 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1446 LEAVE_SCOPE(oldsave);
1447 if (gimme == G_ARRAY)
1453 Perl_do_readline(pTHX)
1455 dSP; dTARGETSTACKED;
1460 register IO *io = GvIO(PL_last_in_gv);
1461 register I32 type = PL_op->op_type;
1462 I32 gimme = GIMME_V;
1465 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1467 XPUSHs(SvTIED_obj((SV*)io, mg));
1470 call_method("READLINE", gimme);
1473 if (gimme == G_SCALAR) {
1475 SvSetSV_nosteal(TARG, result);
1484 if (IoFLAGS(io) & IOf_ARGV) {
1485 if (IoFLAGS(io) & IOf_START) {
1487 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1488 IoFLAGS(io) &= ~IOf_START;
1489 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1490 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1491 SvSETMAGIC(GvSV(PL_last_in_gv));
1496 fp = nextargv(PL_last_in_gv);
1497 if (!fp) { /* Note: fp != IoIFP(io) */
1498 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1501 else if (type == OP_GLOB)
1502 fp = Perl_start_glob(aTHX_ POPs, io);
1504 else if (type == OP_GLOB)
1506 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1507 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1511 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1512 && (!io || !(IoFLAGS(io) & IOf_START))) {
1513 if (type == OP_GLOB)
1514 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1515 "glob failed (can't start child: %s)",
1518 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1520 if (gimme == G_SCALAR) {
1521 /* undef TARG, and push that undefined value */
1522 if (type != OP_RCATLINE) {
1523 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1524 (void)SvOK_off(TARG);
1531 if (gimme == G_SCALAR) {
1535 (void)SvUPGRADE(sv, SVt_PV);
1536 tmplen = SvLEN(sv); /* remember if already alloced */
1537 if (!tmplen && !SvREADONLY(sv))
1538 Sv_Grow(sv, 80); /* try short-buffering it */
1540 if (type == OP_RCATLINE && SvOK(sv)) {
1543 (void)SvPV_force(sv, n_a);
1549 sv = sv_2mortal(NEWSV(57, 80));
1553 /* This should not be marked tainted if the fp is marked clean */
1554 #define MAYBE_TAINT_LINE(io, sv) \
1555 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1560 /* delay EOF state for a snarfed empty file */
1561 #define SNARF_EOF(gimme,rs,io,sv) \
1562 (gimme != G_SCALAR || SvCUR(sv) \
1563 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1567 if (!sv_gets(sv, fp, offset)
1569 || SNARF_EOF(gimme, PL_rs, io, sv)
1570 || PerlIO_error(fp)))
1572 PerlIO_clearerr(fp);
1573 if (IoFLAGS(io) & IOf_ARGV) {
1574 fp = nextargv(PL_last_in_gv);
1577 (void)do_close(PL_last_in_gv, FALSE);
1579 else if (type == OP_GLOB) {
1580 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1581 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1582 "glob failed (child exited with status %d%s)",
1583 (int)(STATUS_CURRENT >> 8),
1584 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1587 if (gimme == G_SCALAR) {
1588 if (type != OP_RCATLINE) {
1589 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1590 (void)SvOK_off(TARG);
1595 MAYBE_TAINT_LINE(io, sv);
1598 MAYBE_TAINT_LINE(io, sv);
1600 IoFLAGS(io) |= IOf_NOLINE;
1604 if (type == OP_GLOB) {
1607 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1608 tmps = SvEND(sv) - 1;
1609 if (*tmps == *SvPVX(PL_rs)) {
1614 for (tmps = SvPVX(sv); *tmps; tmps++)
1615 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1616 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1618 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1619 (void)POPs; /* Unmatched wildcard? Chuck it... */
1622 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1623 U8 *s = (U8*)SvPVX(sv) + offset;
1624 STRLEN len = SvCUR(sv) - offset;
1627 if (ckWARN(WARN_UTF8) &&
1628 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1629 /* Emulate :encoding(utf8) warning in the same case. */
1630 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1631 "utf8 \"\\x%02X\" does not map to Unicode",
1632 f < (U8*)SvEND(sv) ? *f : 0);
1634 if (gimme == G_ARRAY) {
1635 if (SvLEN(sv) - SvCUR(sv) > 20) {
1636 SvLEN_set(sv, SvCUR(sv)+1);
1637 Renew(SvPVX(sv), SvLEN(sv), char);
1639 sv = sv_2mortal(NEWSV(58, 80));
1642 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1643 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1647 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1648 Renew(SvPVX(sv), SvLEN(sv), char);
1657 register PERL_CONTEXT *cx;
1658 I32 gimme = OP_GIMME(PL_op, -1);
1661 if (cxstack_ix >= 0)
1662 gimme = cxstack[cxstack_ix].blk_gimme;
1670 PUSHBLOCK(cx, CXt_BLOCK, SP);
1682 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1683 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1685 #ifdef PERL_COPY_ON_WRITE
1686 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1688 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1692 if (SvTYPE(hv) == SVt_PVHV) {
1693 if (PL_op->op_private & OPpLVAL_INTRO) {
1696 /* does the element we're localizing already exist? */
1698 /* can we determine whether it exists? */
1700 || mg_find((SV*)hv, PERL_MAGIC_env)
1701 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1702 /* Try to preserve the existenceness of a tied hash
1703 * element by using EXISTS and DELETE if possible.
1704 * Fallback to FETCH and STORE otherwise */
1705 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1706 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1707 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1709 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1712 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1713 svp = he ? &HeVAL(he) : 0;
1719 if (!svp || *svp == &PL_sv_undef) {
1724 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1726 lv = sv_newmortal();
1727 sv_upgrade(lv, SVt_PVLV);
1729 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1730 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1731 LvTARG(lv) = SvREFCNT_inc(hv);
1736 if (PL_op->op_private & OPpLVAL_INTRO) {
1737 if (HvNAME(hv) && isGV(*svp))
1738 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1742 char *key = SvPV(keysv, keylen);
1743 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1745 save_helem(hv, keysv, svp);
1748 else if (PL_op->op_private & OPpDEREF)
1749 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1751 sv = (svp ? *svp : &PL_sv_undef);
1752 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1753 * Pushing the magical RHS on to the stack is useless, since
1754 * that magic is soon destined to be misled by the local(),
1755 * and thus the later pp_sassign() will fail to mg_get() the
1756 * old value. This should also cure problems with delayed
1757 * mg_get()s. GSAR 98-07-03 */
1758 if (!lval && SvGMAGICAL(sv))
1759 sv = sv_mortalcopy(sv);
1767 register PERL_CONTEXT *cx;
1773 if (PL_op->op_flags & OPf_SPECIAL) {
1774 cx = &cxstack[cxstack_ix];
1775 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1780 gimme = OP_GIMME(PL_op, -1);
1782 if (cxstack_ix >= 0)
1783 gimme = cxstack[cxstack_ix].blk_gimme;
1789 if (gimme == G_VOID)
1791 else if (gimme == G_SCALAR) {
1794 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1797 *MARK = sv_mortalcopy(TOPs);
1800 *MARK = &PL_sv_undef;
1804 else if (gimme == G_ARRAY) {
1805 /* in case LEAVE wipes old return values */
1806 for (mark = newsp + 1; mark <= SP; mark++) {
1807 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1808 *mark = sv_mortalcopy(*mark);
1809 TAINT_NOT; /* Each item is independent */
1813 PL_curpm = newpm; /* Don't pop $1 et al till now */
1823 register PERL_CONTEXT *cx;
1829 cx = &cxstack[cxstack_ix];
1830 if (CxTYPE(cx) != CXt_LOOP)
1831 DIE(aTHX_ "panic: pp_iter");
1833 itersvp = CxITERVAR(cx);
1834 av = cx->blk_loop.iterary;
1835 if (SvTYPE(av) != SVt_PVAV) {
1836 /* iterate ($min .. $max) */
1837 if (cx->blk_loop.iterlval) {
1838 /* string increment */
1839 register SV* cur = cx->blk_loop.iterlval;
1841 char *max = SvPV((SV*)av, maxlen);
1842 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1843 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1844 /* safe to reuse old SV */
1845 sv_setsv(*itersvp, cur);
1849 /* we need a fresh SV every time so that loop body sees a
1850 * completely new SV for closures/references to work as
1852 SvREFCNT_dec(*itersvp);
1853 *itersvp = newSVsv(cur);
1855 if (strEQ(SvPVX(cur), max))
1856 sv_setiv(cur, 0); /* terminate next time */
1863 /* integer increment */
1864 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1867 /* don't risk potential race */
1868 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1869 /* safe to reuse old SV */
1870 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1874 /* we need a fresh SV every time so that loop body sees a
1875 * completely new SV for closures/references to work as they
1877 SvREFCNT_dec(*itersvp);
1878 *itersvp = newSViv(cx->blk_loop.iterix++);
1884 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1887 SvREFCNT_dec(*itersvp);
1889 if (SvMAGICAL(av) || AvREIFY(av)) {
1890 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1897 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1899 if (sv && SvREFCNT(sv) == 0) {
1901 Perl_croak(aTHX_ "Use of freed value in iteration");
1908 if (av != PL_curstack && sv == &PL_sv_undef) {
1909 SV *lv = cx->blk_loop.iterlval;
1910 if (lv && SvREFCNT(lv) > 1) {
1915 SvREFCNT_dec(LvTARG(lv));
1917 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1918 sv_upgrade(lv, SVt_PVLV);
1920 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1922 LvTARG(lv) = SvREFCNT_inc(av);
1923 LvTARGOFF(lv) = cx->blk_loop.iterix;
1924 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1928 *itersvp = SvREFCNT_inc(sv);
1935 register PMOP *pm = cPMOP;
1951 register REGEXP *rx = PM_GETRE(pm);
1953 int force_on_match = 0;
1954 I32 oldsave = PL_savestack_ix;
1956 bool doutf8 = FALSE;
1957 #ifdef PERL_COPY_ON_WRITE
1962 /* known replacement string? */
1963 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1964 if (PL_op->op_flags & OPf_STACKED)
1966 else if (PL_op->op_private & OPpTARGET_MY)
1973 #ifdef PERL_COPY_ON_WRITE
1974 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1975 because they make integers such as 256 "false". */
1976 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1979 sv_force_normal_flags(TARG,0);
1982 #ifdef PERL_COPY_ON_WRITE
1986 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1987 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1988 DIE(aTHX_ PL_no_modify);
1991 s = SvPV(TARG, len);
1992 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1994 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1995 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2000 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2004 DIE(aTHX_ "panic: pp_subst");
2007 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2008 maxiters = 2 * slen + 10; /* We can match twice at each
2009 position, once with zero-length,
2010 second time with non-zero. */
2012 if (!rx->prelen && PL_curpm) {
2016 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2017 ? REXEC_COPY_STR : 0;
2019 r_flags |= REXEC_SCREAM;
2020 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
2021 SAVEINT(PL_multiline);
2022 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2025 if (rx->reganch & RE_USE_INTUIT) {
2027 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2031 /* How to do it in subst? */
2032 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2034 && ((rx->reganch & ROPT_NOSCAN)
2035 || !((rx->reganch & RE_INTUIT_TAIL)
2036 && (r_flags & REXEC_SCREAM))))
2041 /* only replace once? */
2042 once = !(rpm->op_pmflags & PMf_GLOBAL);
2044 /* known replacement string? */
2046 /* replacement needing upgrading? */
2047 if (DO_UTF8(TARG) && !doutf8) {
2048 nsv = sv_newmortal();
2051 sv_recode_to_utf8(nsv, PL_encoding);
2053 sv_utf8_upgrade(nsv);
2054 c = SvPV(nsv, clen);
2058 c = SvPV(dstr, clen);
2059 doutf8 = DO_UTF8(dstr);
2067 /* can do inplace substitution? */
2069 #ifdef PERL_COPY_ON_WRITE
2072 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2073 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2074 && (!doutf8 || SvUTF8(TARG))) {
2075 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2076 r_flags | REXEC_CHECKED))
2080 LEAVE_SCOPE(oldsave);
2083 #ifdef PERL_COPY_ON_WRITE
2084 if (SvIsCOW(TARG)) {
2085 assert (!force_on_match);
2089 if (force_on_match) {
2091 s = SvPV_force(TARG, len);
2096 SvSCREAM_off(TARG); /* disable possible screamer */
2098 rxtainted |= RX_MATCH_TAINTED(rx);
2099 m = orig + rx->startp[0];
2100 d = orig + rx->endp[0];
2102 if (m - s > strend - d) { /* faster to shorten from end */
2104 Copy(c, m, clen, char);
2109 Move(d, m, i, char);
2113 SvCUR_set(TARG, m - s);
2116 else if ((i = m - s)) { /* faster from front */
2124 Copy(c, m, clen, char);
2129 Copy(c, d, clen, char);
2134 TAINT_IF(rxtainted & 1);
2140 if (iters++ > maxiters)
2141 DIE(aTHX_ "Substitution loop");
2142 rxtainted |= RX_MATCH_TAINTED(rx);
2143 m = rx->startp[0] + orig;
2147 Move(s, d, i, char);
2151 Copy(c, d, clen, char);
2154 s = rx->endp[0] + orig;
2155 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2157 /* don't match same null twice */
2158 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2161 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2162 Move(s, d, i+1, char); /* include the NUL */
2164 TAINT_IF(rxtainted & 1);
2166 PUSHs(sv_2mortal(newSViv((I32)iters)));
2168 (void)SvPOK_only_UTF8(TARG);
2169 TAINT_IF(rxtainted);
2170 if (SvSMAGICAL(TARG)) {
2178 LEAVE_SCOPE(oldsave);
2182 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2183 r_flags | REXEC_CHECKED))
2185 if (force_on_match) {
2187 s = SvPV_force(TARG, len);
2190 #ifdef PERL_COPY_ON_WRITE
2193 rxtainted |= RX_MATCH_TAINTED(rx);
2194 dstr = NEWSV(25, len);
2195 sv_setpvn(dstr, m, s-m);
2200 register PERL_CONTEXT *cx;
2204 RETURNOP(cPMOP->op_pmreplroot);
2206 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2208 if (iters++ > maxiters)
2209 DIE(aTHX_ "Substitution loop");
2210 rxtainted |= RX_MATCH_TAINTED(rx);
2211 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2216 strend = s + (strend - m);
2218 m = rx->startp[0] + orig;
2219 if (doutf8 && !SvUTF8(dstr))
2220 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2222 sv_catpvn(dstr, s, m-s);
2223 s = rx->endp[0] + orig;
2225 sv_catpvn(dstr, c, clen);
2228 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2229 TARG, NULL, r_flags));
2230 if (doutf8 && !DO_UTF8(TARG))
2231 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2233 sv_catpvn(dstr, s, strend - s);
2235 #ifdef PERL_COPY_ON_WRITE
2236 /* The match may make the string COW. If so, brilliant, because that's
2237 just saved us one malloc, copy and free - the regexp has donated
2238 the old buffer, and we malloc an entirely new one, rather than the
2239 regexp malloc()ing a buffer and copying our original, only for
2240 us to throw it away here during the substitution. */
2241 if (SvIsCOW(TARG)) {
2242 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2246 (void)SvOOK_off(TARG);
2248 Safefree(SvPVX(TARG));
2250 SvPVX(TARG) = SvPVX(dstr);
2251 SvCUR_set(TARG, SvCUR(dstr));
2252 SvLEN_set(TARG, SvLEN(dstr));
2253 doutf8 |= DO_UTF8(dstr);
2257 TAINT_IF(rxtainted & 1);
2259 PUSHs(sv_2mortal(newSViv((I32)iters)));
2261 (void)SvPOK_only(TARG);
2264 TAINT_IF(rxtainted);
2267 LEAVE_SCOPE(oldsave);
2276 LEAVE_SCOPE(oldsave);
2285 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2286 ++*PL_markstack_ptr;
2287 LEAVE; /* exit inner scope */
2290 if (PL_stack_base + *PL_markstack_ptr > SP) {
2292 I32 gimme = GIMME_V;
2294 LEAVE; /* exit outer scope */
2295 (void)POPMARK; /* pop src */
2296 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2297 (void)POPMARK; /* pop dst */
2298 SP = PL_stack_base + POPMARK; /* pop original mark */
2299 if (gimme == G_SCALAR) {
2300 if (PL_op->op_private & OPpGREP_LEX) {
2301 SV* sv = sv_newmortal();
2302 sv_setiv(sv, items);
2310 else if (gimme == G_ARRAY)
2317 ENTER; /* enter inner scope */
2320 src = PL_stack_base[*PL_markstack_ptr];
2322 if (PL_op->op_private & OPpGREP_LEX)
2323 PAD_SVl(PL_op->op_targ) = src;
2327 RETURNOP(cLOGOP->op_other);
2338 register PERL_CONTEXT *cx;
2342 cxstack_ix++; /* temporarily protect top context */
2345 if (gimme == G_SCALAR) {
2348 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2350 *MARK = SvREFCNT_inc(TOPs);
2355 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2357 *MARK = sv_mortalcopy(sv);
2362 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2366 *MARK = &PL_sv_undef;
2370 else if (gimme == G_ARRAY) {
2371 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2372 if (!SvTEMP(*MARK)) {
2373 *MARK = sv_mortalcopy(*MARK);
2374 TAINT_NOT; /* Each item is independent */
2382 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2383 PL_curpm = newpm; /* ... and pop $1 et al */
2386 return pop_return();
2389 /* This duplicates the above code because the above code must not
2390 * get any slower by more conditions */
2398 register PERL_CONTEXT *cx;
2402 cxstack_ix++; /* temporarily protect top context */
2406 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2407 /* We are an argument to a function or grep().
2408 * This kind of lvalueness was legal before lvalue
2409 * subroutines too, so be backward compatible:
2410 * cannot report errors. */
2412 /* Scalar context *is* possible, on the LHS of -> only,
2413 * as in f()->meth(). But this is not an lvalue. */
2414 if (gimme == G_SCALAR)
2416 if (gimme == G_ARRAY) {
2417 if (!CvLVALUE(cx->blk_sub.cv))
2418 goto temporise_array;
2419 EXTEND_MORTAL(SP - newsp);
2420 for (mark = newsp + 1; mark <= SP; mark++) {
2423 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2424 *mark = sv_mortalcopy(*mark);
2426 /* Can be a localized value subject to deletion. */
2427 PL_tmps_stack[++PL_tmps_ix] = *mark;
2428 (void)SvREFCNT_inc(*mark);
2433 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2434 /* Here we go for robustness, not for speed, so we change all
2435 * the refcounts so the caller gets a live guy. Cannot set
2436 * TEMP, so sv_2mortal is out of question. */
2437 if (!CvLVALUE(cx->blk_sub.cv)) {
2443 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2445 if (gimme == G_SCALAR) {
2449 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2455 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2456 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2457 : "a readonly value" : "a temporary");
2459 else { /* Can be a localized value
2460 * subject to deletion. */
2461 PL_tmps_stack[++PL_tmps_ix] = *mark;
2462 (void)SvREFCNT_inc(*mark);
2465 else { /* Should not happen? */
2471 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2472 (MARK > SP ? "Empty array" : "Array"));
2476 else if (gimme == G_ARRAY) {
2477 EXTEND_MORTAL(SP - newsp);
2478 for (mark = newsp + 1; mark <= SP; mark++) {
2479 if (*mark != &PL_sv_undef
2480 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2481 /* Might be flattened array after $#array = */
2488 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2489 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2492 /* Can be a localized value subject to deletion. */
2493 PL_tmps_stack[++PL_tmps_ix] = *mark;
2494 (void)SvREFCNT_inc(*mark);
2500 if (gimme == G_SCALAR) {
2504 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2506 *MARK = SvREFCNT_inc(TOPs);
2511 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2513 *MARK = sv_mortalcopy(sv);
2518 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2522 *MARK = &PL_sv_undef;
2526 else if (gimme == G_ARRAY) {
2528 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2529 if (!SvTEMP(*MARK)) {
2530 *MARK = sv_mortalcopy(*MARK);
2531 TAINT_NOT; /* Each item is independent */
2540 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2541 PL_curpm = newpm; /* ... and pop $1 et al */
2544 return pop_return();
2549 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2551 SV *dbsv = GvSV(PL_DBsub);
2553 if (!PERLDB_SUB_NN) {
2557 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2558 || strEQ(GvNAME(gv), "END")
2559 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2560 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2561 && (gv = (GV*)*svp) ))) {
2562 /* Use GV from the stack as a fallback. */
2563 /* GV is potentially non-unique, or contain different CV. */
2564 SV *tmp = newRV((SV*)cv);
2565 sv_setsv(dbsv, tmp);
2569 gv_efullname3(dbsv, gv, Nullch);
2573 (void)SvUPGRADE(dbsv, SVt_PVIV);
2574 (void)SvIOK_on(dbsv);
2575 SAVEIV(SvIVX(dbsv));
2576 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2580 PL_curcopdb = PL_curcop;
2581 cv = GvCV(PL_DBsub);
2591 register PERL_CONTEXT *cx;
2593 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2596 DIE(aTHX_ "Not a CODE reference");
2597 switch (SvTYPE(sv)) {
2598 /* This is overwhelming the most common case: */
2600 if (!(cv = GvCVu((GV*)sv)))
2601 cv = sv_2cv(sv, &stash, &gv, FALSE);
2613 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2615 SP = PL_stack_base + POPMARK;
2618 if (SvGMAGICAL(sv)) {
2622 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2625 sym = SvPV(sv, n_a);
2627 DIE(aTHX_ PL_no_usym, "a subroutine");
2628 if (PL_op->op_private & HINT_STRICT_REFS)
2629 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2630 cv = get_cv(sym, TRUE);
2635 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2636 tryAMAGICunDEREF(to_cv);
2639 if (SvTYPE(cv) == SVt_PVCV)
2644 DIE(aTHX_ "Not a CODE reference");
2645 /* This is the second most common case: */
2655 if (!CvROOT(cv) && !CvXSUB(cv)) {
2660 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2661 if (CvASSERTION(cv) && PL_DBassertion)
2662 sv_setiv(PL_DBassertion, 1);
2664 cv = get_db_sub(&sv, cv);
2666 DIE(aTHX_ "No DBsub routine");
2669 if (!(CvXSUB(cv))) {
2670 /* This path taken at least 75% of the time */
2672 register I32 items = SP - MARK;
2673 AV* padlist = CvPADLIST(cv);
2674 push_return(PL_op->op_next);
2675 PUSHBLOCK(cx, CXt_SUB, MARK);
2678 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2679 * that eval'' ops within this sub know the correct lexical space.
2680 * Owing the speed considerations, we choose instead to search for
2681 * the cv using find_runcv() when calling doeval().
2683 if (CvDEPTH(cv) >= 2) {
2684 PERL_STACK_OVERFLOW_CHECK();
2685 pad_push(padlist, CvDEPTH(cv), 1);
2687 PAD_SET_CUR(padlist, CvDEPTH(cv));
2694 DEBUG_S(PerlIO_printf(Perl_debug_log,
2695 "%p entersub preparing @_\n", thr));
2697 av = (AV*)PAD_SVl(0);
2699 /* @_ is normally not REAL--this should only ever
2700 * happen when DB::sub() calls things that modify @_ */
2705 cx->blk_sub.savearray = GvAV(PL_defgv);
2706 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2707 CX_CURPAD_SAVE(cx->blk_sub);
2708 cx->blk_sub.argarray = av;
2711 if (items > AvMAX(av) + 1) {
2713 if (AvARRAY(av) != ary) {
2714 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2715 SvPVX(av) = (char*)ary;
2717 if (items > AvMAX(av) + 1) {
2718 AvMAX(av) = items - 1;
2719 Renew(ary,items,SV*);
2721 SvPVX(av) = (char*)ary;
2724 Copy(MARK,AvARRAY(av),items,SV*);
2725 AvFILLp(av) = items - 1;
2733 /* warning must come *after* we fully set up the context
2734 * stuff so that __WARN__ handlers can safely dounwind()
2737 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2738 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2739 sub_crush_depth(cv);
2741 DEBUG_S(PerlIO_printf(Perl_debug_log,
2742 "%p entersub returning %p\n", thr, CvSTART(cv)));
2744 RETURNOP(CvSTART(cv));
2747 #ifdef PERL_XSUB_OLDSTYLE
2748 if (CvOLDSTYLE(cv)) {
2749 I32 (*fp3)(int,int,int);
2751 register I32 items = SP - MARK;
2752 /* We dont worry to copy from @_. */
2757 PL_stack_sp = mark + 1;
2758 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2759 items = (*fp3)(CvXSUBANY(cv).any_i32,
2760 MARK - PL_stack_base + 1,
2762 PL_stack_sp = PL_stack_base + items;
2765 #endif /* PERL_XSUB_OLDSTYLE */
2767 I32 markix = TOPMARK;
2772 /* Need to copy @_ to stack. Alternative may be to
2773 * switch stack to @_, and copy return values
2774 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2777 av = GvAV(PL_defgv);
2778 items = AvFILLp(av) + 1; /* @_ is not tieable */
2781 /* Mark is at the end of the stack. */
2783 Copy(AvARRAY(av), SP + 1, items, SV*);
2788 /* We assume first XSUB in &DB::sub is the called one. */
2790 SAVEVPTR(PL_curcop);
2791 PL_curcop = PL_curcopdb;
2794 /* Do we need to open block here? XXXX */
2795 (void)(*CvXSUB(cv))(aTHX_ cv);
2797 /* Enforce some sanity in scalar context. */
2798 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2799 if (markix > PL_stack_sp - PL_stack_base)
2800 *(PL_stack_base + markix) = &PL_sv_undef;
2802 *(PL_stack_base + markix) = *PL_stack_sp;
2803 PL_stack_sp = PL_stack_base + markix;
2810 assert (0); /* Cannot get here. */
2811 /* This is deliberately moved here as spaghetti code to keep it out of the
2818 /* anonymous or undef'd function leaves us no recourse */
2819 if (CvANON(cv) || !(gv = CvGV(cv)))
2820 DIE(aTHX_ "Undefined subroutine called");
2822 /* autoloaded stub? */
2823 if (cv != GvCV(gv)) {
2826 /* should call AUTOLOAD now? */
2829 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2836 sub_name = sv_newmortal();
2837 gv_efullname3(sub_name, gv, Nullch);
2838 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2842 DIE(aTHX_ "Not a CODE reference");
2848 Perl_sub_crush_depth(pTHX_ CV *cv)
2851 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2853 SV* tmpstr = sv_newmortal();
2854 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2855 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2865 IV elem = SvIV(elemsv);
2867 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2868 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2871 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2872 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2874 elem -= PL_curcop->cop_arybase;
2875 if (SvTYPE(av) != SVt_PVAV)
2877 svp = av_fetch(av, elem, lval && !defer);
2879 if (!svp || *svp == &PL_sv_undef) {
2882 DIE(aTHX_ PL_no_aelem, elem);
2883 lv = sv_newmortal();
2884 sv_upgrade(lv, SVt_PVLV);
2886 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2887 LvTARG(lv) = SvREFCNT_inc(av);
2888 LvTARGOFF(lv) = elem;
2893 if (PL_op->op_private & OPpLVAL_INTRO)
2894 save_aelem(av, elem, svp);
2895 else if (PL_op->op_private & OPpDEREF)
2896 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2898 sv = (svp ? *svp : &PL_sv_undef);
2899 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2900 sv = sv_mortalcopy(sv);
2906 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2912 Perl_croak(aTHX_ PL_no_modify);
2913 if (SvTYPE(sv) < SVt_RV)
2914 sv_upgrade(sv, SVt_RV);
2915 else if (SvTYPE(sv) >= SVt_PV) {
2916 (void)SvOOK_off(sv);
2917 Safefree(SvPVX(sv));
2918 SvLEN(sv) = SvCUR(sv) = 0;
2922 SvRV(sv) = NEWSV(355,0);
2925 SvRV(sv) = (SV*)newAV();
2928 SvRV(sv) = (SV*)newHV();
2943 if (SvTYPE(rsv) == SVt_PVCV) {
2949 SETs(method_common(sv, Null(U32*)));
2957 U32 hash = SvUVX(sv);
2959 XPUSHs(method_common(sv, &hash));
2964 S_method_common(pTHX_ SV* meth, U32* hashp)
2973 SV *packsv = Nullsv;
2976 name = SvPV(meth, namelen);
2977 sv = *(PL_stack_base + TOPMARK + 1);
2980 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2989 /* this isn't a reference */
2992 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2994 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2996 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3003 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3004 !(ob=(SV*)GvIO(iogv)))
3006 /* this isn't the name of a filehandle either */
3008 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3009 ? !isIDFIRST_utf8((U8*)packname)
3010 : !isIDFIRST(*packname)
3013 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3014 SvOK(sv) ? "without a package or object reference"
3015 : "on an undefined value");
3017 /* assume it's a package name */
3018 stash = gv_stashpvn(packname, packlen, FALSE);
3022 SV* ref = newSViv(PTR2IV(stash));
3023 hv_store(PL_stashcache, packname, packlen, ref, 0);
3027 /* it _is_ a filehandle name -- replace with a reference */
3028 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3031 /* if we got here, ob should be a reference or a glob */
3032 if (!ob || !(SvOBJECT(ob)
3033 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3036 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3040 stash = SvSTASH(ob);
3043 /* NOTE: stash may be null, hope hv_fetch_ent and
3044 gv_fetchmethod can cope (it seems they can) */
3046 /* shortcut for simple names */
3048 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3050 gv = (GV*)HeVAL(he);
3051 if (isGV(gv) && GvCV(gv) &&
3052 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3053 return (SV*)GvCV(gv);
3057 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3060 /* This code tries to figure out just what went wrong with
3061 gv_fetchmethod. It therefore needs to duplicate a lot of
3062 the internals of that function. We can't move it inside
3063 Perl_gv_fetchmethod_autoload(), however, since that would
3064 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3071 for (p = name; *p; p++) {
3073 sep = p, leaf = p + 1;
3074 else if (*p == ':' && *(p + 1) == ':')
3075 sep = p, leaf = p + 2;
3077 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3078 /* the method name is unqualified or starts with SUPER:: */
3079 packname = sep ? CopSTASHPV(PL_curcop) :
3080 stash ? HvNAME(stash) : packname;
3083 "Can't use anonymous symbol table for method lookup");
3085 packlen = strlen(packname);
3088 /* the method name is qualified */
3090 packlen = sep - name;
3093 /* we're relying on gv_fetchmethod not autovivifying the stash */
3094 if (gv_stashpvn(packname, packlen, FALSE)) {
3096 "Can't locate object method \"%s\" via package \"%.*s\"",
3097 leaf, (int)packlen, packname);
3101 "Can't locate object method \"%s\" via package \"%.*s\""
3102 " (perhaps you forgot to load \"%.*s\"?)",
3103 leaf, (int)packlen, packname, (int)packlen, packname);
3106 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;