3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
20 #define PERL_IN_PP_HOT_C
34 PL_curcop = (COP*)PL_op;
35 TAINT_NOT; /* Each statement is presumed innocent */
36 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
45 if (PL_op->op_private & OPpLVAL_INTRO)
46 PUSHs(save_scalar(cGVOP_gv));
48 PUSHs(GvSV(cGVOP_gv));
59 PL_curcop = (COP*)PL_op;
65 PUSHMARK(PL_stack_sp);
80 XPUSHs((SV*)cGVOP_gv);
91 RETURNOP(cLOGOP->op_other);
99 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
101 temp = left; left = right; right = temp;
103 if (PL_tainting && PL_tainted && !SvTAINTED(left))
105 SvSetMagicSV(right, left);
114 RETURNOP(cLOGOP->op_other);
116 RETURNOP(cLOGOP->op_next);
122 TAINT_NOT; /* Each statement is presumed innocent */
123 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
125 oldsave = PL_scopestack[PL_scopestack_ix - 1];
126 LEAVE_SCOPE(oldsave);
132 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
139 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
140 bool rbyte = !SvUTF8(right), rcopied = FALSE;
142 if (TARG == right && right != left) {
143 right = sv_2mortal(newSVpvn(rpv, rlen));
144 rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
149 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
150 lbyte = !SvUTF8(left);
151 sv_setpvn(TARG, lpv, llen);
157 else { /* TARG == left */
158 if (SvGMAGICAL(left))
159 mg_get(left); /* or mg_get(left) may happen here */
162 lpv = SvPV_nomg(left, llen);
163 lbyte = !SvUTF8(left);
166 #if defined(PERL_Y2KWARN)
167 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
168 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
169 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
171 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
172 "about to append an integer to '19'");
177 if (lbyte != rbyte) {
179 sv_utf8_upgrade_nomg(TARG);
182 right = sv_2mortal(newSVpvn(rpv, rlen));
183 sv_utf8_upgrade_nomg(right);
184 rpv = SvPV(right, rlen);
187 sv_catpvn_nomg(TARG, rpv, rlen);
198 if (PL_op->op_flags & OPf_MOD) {
199 if (PL_op->op_private & OPpLVAL_INTRO)
200 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
201 else if (PL_op->op_private & OPpDEREF) {
203 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
212 tryAMAGICunTARGET(iter, 0);
213 PL_last_in_gv = (GV*)(*PL_stack_sp--);
214 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
215 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
216 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
219 XPUSHs((SV*)PL_last_in_gv);
222 PL_last_in_gv = (GV*)(*PL_stack_sp--);
225 return do_readline();
230 dSP; tryAMAGICbinSET(eq,0);
231 #ifndef NV_PRESERVES_UV
232 if (SvROK(TOPs) && SvROK(TOPm1s)) {
234 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
238 #ifdef PERL_PRESERVE_IVUV
241 /* Unless the left argument is integer in range we are going
242 to have to use NV maths. Hence only attempt to coerce the
243 right argument if we know the left is integer. */
246 bool auvok = SvUOK(TOPm1s);
247 bool buvok = SvUOK(TOPs);
249 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
250 /* Casting IV to UV before comparison isn't going to matter
251 on 2s complement. On 1s complement or sign&magnitude
252 (if we have any of them) it could to make negative zero
253 differ from normal zero. As I understand it. (Need to
254 check - is negative zero implementation defined behaviour
256 UV buv = SvUVX(POPs);
257 UV auv = SvUVX(TOPs);
259 SETs(boolSV(auv == buv));
262 { /* ## Mixed IV,UV ## */
266 /* == is commutative so doesn't matter which is left or right */
268 /* top of stack (b) is the iv */
277 /* As uv is a UV, it's >0, so it cannot be == */
281 /* we know iv is >= 0 */
282 SETs(boolSV((UV)iv == SvUVX(uvp)));
290 SETs(boolSV(TOPn == value));
298 if (SvTYPE(TOPs) >= SVt_PVGV && 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 = PL_op->op_flags & OPf_SPECIAL ?
525 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
526 U32 lval = PL_op->op_flags & OPf_MOD;
527 SV** svp = av_fetch(av, PL_op->op_private, lval);
528 SV *sv = (svp ? *svp : &PL_sv_undef);
530 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
531 sv = sv_mortalcopy(sv);
540 do_join(TARG, *MARK, MARK, SP);
551 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
552 * will be enough to hold an OP*.
554 SV* sv = sv_newmortal();
555 sv_upgrade(sv, SVt_PVLV);
557 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
565 /* Oversized hot code. */
569 dSP; dMARK; dORIGMARK;
575 if (PL_op->op_flags & OPf_STACKED)
580 if (gv && (io = GvIO(gv))
581 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
584 if (MARK == ORIGMARK) {
585 /* If using default handle then we need to make space to
586 * pass object as 1st arg, so move other args up ...
590 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
594 *MARK = SvTIED_obj((SV*)io, mg);
597 call_method("PRINT", G_SCALAR);
605 if (!(io = GvIO(gv))) {
606 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
607 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
609 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
610 report_evil_fh(gv, io, PL_op->op_type);
611 SETERRNO(EBADF,RMS_IFI);
614 else if (!(fp = IoOFP(io))) {
615 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
617 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
618 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
619 report_evil_fh(gv, io, PL_op->op_type);
621 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
626 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
628 if (!do_print(*MARK, fp))
632 if (!do_print(PL_ofs_sv, fp)) { /* $, */
641 if (!do_print(*MARK, fp))
649 if (PL_ors_sv && SvOK(PL_ors_sv))
650 if (!do_print(PL_ors_sv, fp)) /* $\ */
653 if (IoFLAGS(io) & IOf_FLUSH)
654 if (PerlIO_flush(fp) == EOF)
675 tryAMAGICunDEREF(to_av);
678 if (SvTYPE(av) != SVt_PVAV)
679 DIE(aTHX_ "Not an ARRAY reference");
680 if (PL_op->op_flags & OPf_REF) {
685 if (GIMME == G_SCALAR)
686 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
690 else if (PL_op->op_flags & OPf_MOD
691 && PL_op->op_private & OPpLVAL_INTRO)
692 Perl_croak(aTHX_ PL_no_localize_ref);
695 if (SvTYPE(sv) == SVt_PVAV) {
697 if (PL_op->op_flags & OPf_REF) {
702 if (GIMME == G_SCALAR)
703 Perl_croak(aTHX_ "Can't return array to lvalue"
712 if (SvTYPE(sv) != SVt_PVGV) {
716 if (SvGMAGICAL(sv)) {
722 if (PL_op->op_flags & OPf_REF ||
723 PL_op->op_private & HINT_STRICT_REFS)
724 DIE(aTHX_ PL_no_usym, "an ARRAY");
725 if (ckWARN(WARN_UNINITIALIZED))
727 if (GIMME == G_ARRAY) {
734 if ((PL_op->op_flags & OPf_SPECIAL) &&
735 !(PL_op->op_flags & OPf_MOD))
737 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
739 && (!is_gv_magical(sym,len,0)
740 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
746 if (PL_op->op_private & HINT_STRICT_REFS)
747 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
748 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
755 if (PL_op->op_private & OPpLVAL_INTRO)
757 if (PL_op->op_flags & OPf_REF) {
762 if (GIMME == G_SCALAR)
763 Perl_croak(aTHX_ "Can't return array to lvalue"
771 if (GIMME == G_ARRAY) {
772 I32 maxarg = AvFILL(av) + 1;
773 (void)POPs; /* XXXX May be optimized away? */
775 if (SvRMAGICAL(av)) {
777 for (i=0; i < (U32)maxarg; i++) {
778 SV **svp = av_fetch(av, i, FALSE);
779 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
783 Copy(AvARRAY(av), SP+1, maxarg, SV*);
787 else if (GIMME_V == G_SCALAR) {
789 I32 maxarg = AvFILL(av) + 1;
803 tryAMAGICunDEREF(to_hv);
806 if (SvTYPE(hv) != SVt_PVHV)
807 DIE(aTHX_ "Not a HASH reference");
808 if (PL_op->op_flags & OPf_REF) {
813 if (gimme != G_ARRAY)
814 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
818 else if (PL_op->op_flags & OPf_MOD
819 && PL_op->op_private & OPpLVAL_INTRO)
820 Perl_croak(aTHX_ PL_no_localize_ref);
823 if (SvTYPE(sv) == SVt_PVHV) {
825 if (PL_op->op_flags & OPf_REF) {
830 if (gimme != G_ARRAY)
831 Perl_croak(aTHX_ "Can't return hash to lvalue"
840 if (SvTYPE(sv) != SVt_PVGV) {
844 if (SvGMAGICAL(sv)) {
850 if (PL_op->op_flags & OPf_REF ||
851 PL_op->op_private & HINT_STRICT_REFS)
852 DIE(aTHX_ PL_no_usym, "a HASH");
853 if (ckWARN(WARN_UNINITIALIZED))
855 if (gimme == G_ARRAY) {
862 if ((PL_op->op_flags & OPf_SPECIAL) &&
863 !(PL_op->op_flags & OPf_MOD))
865 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
867 && (!is_gv_magical(sym,len,0)
868 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
874 if (PL_op->op_private & HINT_STRICT_REFS)
875 DIE(aTHX_ PL_no_symref, sym, "a HASH");
876 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
883 if (PL_op->op_private & OPpLVAL_INTRO)
885 if (PL_op->op_flags & OPf_REF) {
890 if (gimme != G_ARRAY)
891 Perl_croak(aTHX_ "Can't return hash to lvalue"
899 if (gimme == G_ARRAY) { /* array wanted */
900 *PL_stack_sp = (SV*)hv;
903 else if (gimme == G_SCALAR) {
905 TARG = Perl_hv_scalar(aTHX_ hv);
912 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
918 if (ckWARN(WARN_MISC)) {
919 if (relem == firstrelem &&
921 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
922 SvTYPE(SvRV(*relem)) == SVt_PVHV))
924 Perl_warner(aTHX_ packWARN(WARN_MISC),
925 "Reference found where even-sized list expected");
928 Perl_warner(aTHX_ packWARN(WARN_MISC),
929 "Odd number of elements in hash assignment");
932 tmpstr = NEWSV(29,0);
933 didstore = hv_store_ent(hash,*relem,tmpstr,0);
934 if (SvMAGICAL(hash)) {
935 if (SvSMAGICAL(tmpstr))
947 SV **lastlelem = PL_stack_sp;
948 SV **lastrelem = PL_stack_base + POPMARK;
949 SV **firstrelem = PL_stack_base + POPMARK + 1;
950 SV **firstlelem = lastrelem + 1;
963 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
966 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
969 /* If there's a common identifier on both sides we have to take
970 * special care that assigning the identifier on the left doesn't
971 * clobber a value on the right that's used later in the list.
973 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
974 EXTEND_MORTAL(lastrelem - firstrelem + 1);
975 for (relem = firstrelem; relem <= lastrelem; relem++) {
978 TAINT_NOT; /* Each item is independent */
979 *relem = sv_mortalcopy(sv);
989 while (lelem <= lastlelem) {
990 TAINT_NOT; /* Each item stands on its own, taintwise. */
992 switch (SvTYPE(sv)) {
995 magic = SvMAGICAL(ary) != 0;
997 av_extend(ary, lastrelem - relem);
999 while (relem <= lastrelem) { /* gobble up all the rest */
1003 sv_setsv(sv,*relem);
1005 didstore = av_store(ary,i++,sv);
1015 case SVt_PVHV: { /* normal hash */
1019 magic = SvMAGICAL(hash) != 0;
1021 firsthashrelem = relem;
1023 while (relem < lastrelem) { /* gobble up all the rest */
1028 sv = &PL_sv_no, relem++;
1029 tmpstr = NEWSV(29,0);
1031 sv_setsv(tmpstr,*relem); /* value */
1032 *(relem++) = tmpstr;
1033 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1034 /* key overwrites an existing entry */
1036 didstore = hv_store_ent(hash,sv,tmpstr,0);
1038 if (SvSMAGICAL(tmpstr))
1045 if (relem == lastrelem) {
1046 do_oddball(hash, relem, firstrelem);
1052 if (SvIMMORTAL(sv)) {
1053 if (relem <= lastrelem)
1057 if (relem <= lastrelem) {
1058 sv_setsv(sv, *relem);
1062 sv_setsv(sv, &PL_sv_undef);
1067 if (PL_delaymagic & ~DM_DELAY) {
1068 if (PL_delaymagic & DM_UID) {
1069 #ifdef HAS_SETRESUID
1070 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1071 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1074 # ifdef HAS_SETREUID
1075 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1076 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1079 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1080 (void)setruid(PL_uid);
1081 PL_delaymagic &= ~DM_RUID;
1083 # endif /* HAS_SETRUID */
1085 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1086 (void)seteuid(PL_euid);
1087 PL_delaymagic &= ~DM_EUID;
1089 # endif /* HAS_SETEUID */
1090 if (PL_delaymagic & DM_UID) {
1091 if (PL_uid != PL_euid)
1092 DIE(aTHX_ "No setreuid available");
1093 (void)PerlProc_setuid(PL_uid);
1095 # endif /* HAS_SETREUID */
1096 #endif /* HAS_SETRESUID */
1097 PL_uid = PerlProc_getuid();
1098 PL_euid = PerlProc_geteuid();
1100 if (PL_delaymagic & DM_GID) {
1101 #ifdef HAS_SETRESGID
1102 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1103 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1106 # ifdef HAS_SETREGID
1107 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1108 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1111 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1112 (void)setrgid(PL_gid);
1113 PL_delaymagic &= ~DM_RGID;
1115 # endif /* HAS_SETRGID */
1117 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1118 (void)setegid(PL_egid);
1119 PL_delaymagic &= ~DM_EGID;
1121 # endif /* HAS_SETEGID */
1122 if (PL_delaymagic & DM_GID) {
1123 if (PL_gid != PL_egid)
1124 DIE(aTHX_ "No setregid available");
1125 (void)PerlProc_setgid(PL_gid);
1127 # endif /* HAS_SETREGID */
1128 #endif /* HAS_SETRESGID */
1129 PL_gid = PerlProc_getgid();
1130 PL_egid = PerlProc_getegid();
1132 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1136 if (gimme == G_VOID)
1137 SP = firstrelem - 1;
1138 else if (gimme == G_SCALAR) {
1141 SETi(lastrelem - firstrelem + 1 - duplicates);
1148 /* Removes from the stack the entries which ended up as
1149 * duplicated keys in the hash (fix for [perl #24380]) */
1150 Move(firsthashrelem + duplicates,
1151 firsthashrelem, duplicates, SV**);
1152 lastrelem -= duplicates;
1157 SP = firstrelem + (lastlelem - firstlelem);
1158 lelem = firstlelem + (relem - firstrelem);
1160 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1168 register PMOP *pm = cPMOP;
1169 SV *rv = sv_newmortal();
1170 SV *sv = newSVrv(rv, "Regexp");
1171 if (pm->op_pmdynflags & PMdf_TAINTED)
1173 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1180 register PMOP *pm = cPMOP;
1186 I32 r_flags = REXEC_CHECKED;
1187 char *truebase; /* Start of string */
1188 register REGEXP *rx = PM_GETRE(pm);
1193 I32 oldsave = PL_savestack_ix;
1194 I32 update_minmatch = 1;
1195 I32 had_zerolen = 0;
1197 if (PL_op->op_flags & OPf_STACKED)
1199 else if (PL_op->op_private & OPpTARGET_MY)
1206 PUTBACK; /* EVAL blocks need stack_sp. */
1207 s = SvPV(TARG, len);
1210 DIE(aTHX_ "panic: pp_match");
1211 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1212 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1215 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1217 /* PMdf_USED is set after a ?? matches once */
1218 if (pm->op_pmdynflags & PMdf_USED) {
1220 if (gimme == G_ARRAY)
1225 /* empty pattern special-cased to use last successful pattern if possible */
1226 if (!rx->prelen && PL_curpm) {
1231 if (rx->minlen > (I32)len)
1236 /* XXXX What part of this is needed with true \G-support? */
1237 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1239 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1240 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1241 if (mg && mg->mg_len >= 0) {
1242 if (!(rx->reganch & ROPT_GPOS_SEEN))
1243 rx->endp[0] = rx->startp[0] = mg->mg_len;
1244 else if (rx->reganch & ROPT_ANCH_GPOS) {
1245 r_flags |= REXEC_IGNOREPOS;
1246 rx->endp[0] = rx->startp[0] = mg->mg_len;
1248 minmatch = (mg->mg_flags & MGf_MINMATCH);
1249 update_minmatch = 0;
1253 if ((!global && rx->nparens)
1254 || SvTEMP(TARG) || PL_sawampersand)
1255 r_flags |= REXEC_COPY_STR;
1257 r_flags |= REXEC_SCREAM;
1259 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1260 SAVEINT(PL_multiline);
1261 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1265 if (global && rx->startp[0] != -1) {
1266 t = s = rx->endp[0] + truebase;
1267 if ((s + rx->minlen) > strend)
1269 if (update_minmatch++)
1270 minmatch = had_zerolen;
1272 if (rx->reganch & RE_USE_INTUIT &&
1273 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1274 PL_bostr = truebase;
1275 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1279 if ( (rx->reganch & ROPT_CHECK_ALL)
1281 && ((rx->reganch & ROPT_NOSCAN)
1282 || !((rx->reganch & RE_INTUIT_TAIL)
1283 && (r_flags & REXEC_SCREAM)))
1284 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1287 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1290 if (dynpm->op_pmflags & PMf_ONCE)
1291 dynpm->op_pmdynflags |= PMdf_USED;
1300 RX_MATCH_TAINTED_on(rx);
1301 TAINT_IF(RX_MATCH_TAINTED(rx));
1302 if (gimme == G_ARRAY) {
1303 I32 nparens, i, len;
1305 nparens = rx->nparens;
1306 if (global && !nparens)
1310 SPAGAIN; /* EVAL blocks could move the stack. */
1311 EXTEND(SP, nparens + i);
1312 EXTEND_MORTAL(nparens + i);
1313 for (i = !i; i <= nparens; i++) {
1314 PUSHs(sv_newmortal());
1316 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1317 len = rx->endp[i] - rx->startp[i];
1318 s = rx->startp[i] + truebase;
1319 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1320 len < 0 || len > strend - s)
1321 DIE(aTHX_ "panic: pp_match start/end pointers");
1322 sv_setpvn(*SP, s, len);
1323 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1328 if (dynpm->op_pmflags & PMf_CONTINUE) {
1330 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1331 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1333 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1334 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1336 if (rx->startp[0] != -1) {
1337 mg->mg_len = rx->endp[0];
1338 if (rx->startp[0] == rx->endp[0])
1339 mg->mg_flags |= MGf_MINMATCH;
1341 mg->mg_flags &= ~MGf_MINMATCH;
1344 had_zerolen = (rx->startp[0] != -1
1345 && rx->startp[0] == rx->endp[0]);
1346 PUTBACK; /* EVAL blocks may use stack */
1347 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1352 LEAVE_SCOPE(oldsave);
1358 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1359 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1361 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1362 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1364 if (rx->startp[0] != -1) {
1365 mg->mg_len = rx->endp[0];
1366 if (rx->startp[0] == rx->endp[0])
1367 mg->mg_flags |= MGf_MINMATCH;
1369 mg->mg_flags &= ~MGf_MINMATCH;
1372 LEAVE_SCOPE(oldsave);
1376 yup: /* Confirmed by INTUIT */
1378 RX_MATCH_TAINTED_on(rx);
1379 TAINT_IF(RX_MATCH_TAINTED(rx));
1381 if (dynpm->op_pmflags & PMf_ONCE)
1382 dynpm->op_pmdynflags |= PMdf_USED;
1383 if (RX_MATCH_COPIED(rx))
1384 Safefree(rx->subbeg);
1385 RX_MATCH_COPIED_off(rx);
1386 rx->subbeg = Nullch;
1388 rx->subbeg = truebase;
1389 rx->startp[0] = s - truebase;
1390 if (RX_MATCH_UTF8(rx)) {
1391 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1392 rx->endp[0] = t - truebase;
1395 rx->endp[0] = s - truebase + rx->minlen;
1397 rx->sublen = strend - truebase;
1400 if (PL_sawampersand) {
1402 #ifdef PERL_COPY_ON_WRITE
1403 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1405 PerlIO_printf(Perl_debug_log,
1406 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1407 (int) SvTYPE(TARG), truebase, t,
1410 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1411 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1412 assert (SvPOKp(rx->saved_copy));
1417 rx->subbeg = savepvn(t, strend - t);
1418 #ifdef PERL_COPY_ON_WRITE
1419 rx->saved_copy = Nullsv;
1422 rx->sublen = strend - t;
1423 RX_MATCH_COPIED_on(rx);
1424 off = rx->startp[0] = s - t;
1425 rx->endp[0] = off + rx->minlen;
1427 else { /* startp/endp are used by @- @+. */
1428 rx->startp[0] = s - truebase;
1429 rx->endp[0] = s - truebase + rx->minlen;
1431 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1432 LEAVE_SCOPE(oldsave);
1437 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1438 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1439 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1444 LEAVE_SCOPE(oldsave);
1445 if (gimme == G_ARRAY)
1451 Perl_do_readline(pTHX)
1453 dSP; dTARGETSTACKED;
1458 register IO *io = GvIO(PL_last_in_gv);
1459 register I32 type = PL_op->op_type;
1460 I32 gimme = GIMME_V;
1463 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1465 XPUSHs(SvTIED_obj((SV*)io, mg));
1468 call_method("READLINE", gimme);
1471 if (gimme == G_SCALAR) {
1473 SvSetSV_nosteal(TARG, result);
1482 if (IoFLAGS(io) & IOf_ARGV) {
1483 if (IoFLAGS(io) & IOf_START) {
1485 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1486 IoFLAGS(io) &= ~IOf_START;
1487 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1488 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1489 SvSETMAGIC(GvSV(PL_last_in_gv));
1494 fp = nextargv(PL_last_in_gv);
1495 if (!fp) { /* Note: fp != IoIFP(io) */
1496 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1499 else if (type == OP_GLOB)
1500 fp = Perl_start_glob(aTHX_ POPs, io);
1502 else if (type == OP_GLOB)
1504 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1505 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1509 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1510 && (!io || !(IoFLAGS(io) & IOf_START))) {
1511 if (type == OP_GLOB)
1512 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1513 "glob failed (can't start child: %s)",
1516 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1518 if (gimme == G_SCALAR) {
1519 /* undef TARG, and push that undefined value */
1520 if (type != OP_RCATLINE) {
1521 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1522 (void)SvOK_off(TARG);
1529 if (gimme == G_SCALAR) {
1533 (void)SvUPGRADE(sv, SVt_PV);
1534 tmplen = SvLEN(sv); /* remember if already alloced */
1535 if (!tmplen && !SvREADONLY(sv))
1536 Sv_Grow(sv, 80); /* try short-buffering it */
1538 if (type == OP_RCATLINE && SvOK(sv)) {
1541 (void)SvPV_force(sv, n_a);
1547 sv = sv_2mortal(NEWSV(57, 80));
1551 /* This should not be marked tainted if the fp is marked clean */
1552 #define MAYBE_TAINT_LINE(io, sv) \
1553 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1558 /* delay EOF state for a snarfed empty file */
1559 #define SNARF_EOF(gimme,rs,io,sv) \
1560 (gimme != G_SCALAR || SvCUR(sv) \
1561 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1565 if (!sv_gets(sv, fp, offset)
1567 || SNARF_EOF(gimme, PL_rs, io, sv)
1568 || PerlIO_error(fp)))
1570 PerlIO_clearerr(fp);
1571 if (IoFLAGS(io) & IOf_ARGV) {
1572 fp = nextargv(PL_last_in_gv);
1575 (void)do_close(PL_last_in_gv, FALSE);
1577 else if (type == OP_GLOB) {
1578 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1579 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1580 "glob failed (child exited with status %d%s)",
1581 (int)(STATUS_CURRENT >> 8),
1582 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1585 if (gimme == G_SCALAR) {
1586 if (type != OP_RCATLINE) {
1587 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1588 (void)SvOK_off(TARG);
1593 MAYBE_TAINT_LINE(io, sv);
1596 MAYBE_TAINT_LINE(io, sv);
1598 IoFLAGS(io) |= IOf_NOLINE;
1602 if (type == OP_GLOB) {
1605 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1606 tmps = SvEND(sv) - 1;
1607 if (*tmps == *SvPVX(PL_rs)) {
1612 for (tmps = SvPVX(sv); *tmps; tmps++)
1613 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1614 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1616 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1617 (void)POPs; /* Unmatched wildcard? Chuck it... */
1620 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1621 U8 *s = (U8*)SvPVX(sv) + offset;
1622 STRLEN len = SvCUR(sv) - offset;
1625 if (ckWARN(WARN_UTF8) &&
1626 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1627 /* Emulate :encoding(utf8) warning in the same case. */
1628 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1629 "utf8 \"\\x%02X\" does not map to Unicode",
1630 f < (U8*)SvEND(sv) ? *f : 0);
1632 if (gimme == G_ARRAY) {
1633 if (SvLEN(sv) - SvCUR(sv) > 20) {
1634 SvLEN_set(sv, SvCUR(sv)+1);
1635 Renew(SvPVX(sv), SvLEN(sv), char);
1637 sv = sv_2mortal(NEWSV(58, 80));
1640 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1641 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1645 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1646 Renew(SvPVX(sv), SvLEN(sv), char);
1655 register PERL_CONTEXT *cx;
1656 I32 gimme = OP_GIMME(PL_op, -1);
1659 if (cxstack_ix >= 0)
1660 gimme = cxstack[cxstack_ix].blk_gimme;
1668 PUSHBLOCK(cx, CXt_BLOCK, SP);
1680 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1681 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1683 #ifdef PERL_COPY_ON_WRITE
1684 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1686 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1690 if (SvTYPE(hv) == SVt_PVHV) {
1691 if (PL_op->op_private & OPpLVAL_INTRO) {
1694 /* does the element we're localizing already exist? */
1696 /* can we determine whether it exists? */
1698 || mg_find((SV*)hv, PERL_MAGIC_env)
1699 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1700 /* Try to preserve the existenceness of a tied hash
1701 * element by using EXISTS and DELETE if possible.
1702 * Fallback to FETCH and STORE otherwise */
1703 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1704 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1705 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1707 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1710 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1711 svp = he ? &HeVAL(he) : 0;
1717 if (!svp || *svp == &PL_sv_undef) {
1722 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1724 lv = sv_newmortal();
1725 sv_upgrade(lv, SVt_PVLV);
1727 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1728 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1729 LvTARG(lv) = SvREFCNT_inc(hv);
1734 if (PL_op->op_private & OPpLVAL_INTRO) {
1735 if (HvNAME(hv) && isGV(*svp))
1736 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1740 char *key = SvPV(keysv, keylen);
1741 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1743 save_helem(hv, keysv, svp);
1746 else if (PL_op->op_private & OPpDEREF)
1747 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1749 sv = (svp ? *svp : &PL_sv_undef);
1750 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1751 * Pushing the magical RHS on to the stack is useless, since
1752 * that magic is soon destined to be misled by the local(),
1753 * and thus the later pp_sassign() will fail to mg_get() the
1754 * old value. This should also cure problems with delayed
1755 * mg_get()s. GSAR 98-07-03 */
1756 if (!lval && SvGMAGICAL(sv))
1757 sv = sv_mortalcopy(sv);
1765 register PERL_CONTEXT *cx;
1771 if (PL_op->op_flags & OPf_SPECIAL) {
1772 cx = &cxstack[cxstack_ix];
1773 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1778 gimme = OP_GIMME(PL_op, -1);
1780 if (cxstack_ix >= 0)
1781 gimme = cxstack[cxstack_ix].blk_gimme;
1787 if (gimme == G_VOID)
1789 else if (gimme == G_SCALAR) {
1792 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1795 *MARK = sv_mortalcopy(TOPs);
1798 *MARK = &PL_sv_undef;
1802 else if (gimme == G_ARRAY) {
1803 /* in case LEAVE wipes old return values */
1804 for (mark = newsp + 1; mark <= SP; mark++) {
1805 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1806 *mark = sv_mortalcopy(*mark);
1807 TAINT_NOT; /* Each item is independent */
1811 PL_curpm = newpm; /* Don't pop $1 et al till now */
1821 register PERL_CONTEXT *cx;
1827 cx = &cxstack[cxstack_ix];
1828 if (CxTYPE(cx) != CXt_LOOP)
1829 DIE(aTHX_ "panic: pp_iter");
1831 itersvp = CxITERVAR(cx);
1832 av = cx->blk_loop.iterary;
1833 if (SvTYPE(av) != SVt_PVAV) {
1834 /* iterate ($min .. $max) */
1835 if (cx->blk_loop.iterlval) {
1836 /* string increment */
1837 register SV* cur = cx->blk_loop.iterlval;
1839 char *max = SvPV((SV*)av, maxlen);
1840 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1841 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1842 /* safe to reuse old SV */
1843 sv_setsv(*itersvp, cur);
1847 /* we need a fresh SV every time so that loop body sees a
1848 * completely new SV for closures/references to work as
1850 SvREFCNT_dec(*itersvp);
1851 *itersvp = newSVsv(cur);
1853 if (strEQ(SvPVX(cur), max))
1854 sv_setiv(cur, 0); /* terminate next time */
1861 /* integer increment */
1862 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1865 /* don't risk potential race */
1866 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1867 /* safe to reuse old SV */
1868 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1872 /* we need a fresh SV every time so that loop body sees a
1873 * completely new SV for closures/references to work as they
1875 SvREFCNT_dec(*itersvp);
1876 *itersvp = newSViv(cx->blk_loop.iterix++);
1882 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1885 SvREFCNT_dec(*itersvp);
1887 if (SvMAGICAL(av) || AvREIFY(av)) {
1888 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1895 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1897 if (sv && SvREFCNT(sv) == 0) {
1899 Perl_croak(aTHX_ "Use of freed value in iteration");
1906 if (av != PL_curstack && sv == &PL_sv_undef) {
1907 SV *lv = cx->blk_loop.iterlval;
1908 if (lv && SvREFCNT(lv) > 1) {
1913 SvREFCNT_dec(LvTARG(lv));
1915 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1916 sv_upgrade(lv, SVt_PVLV);
1918 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1920 LvTARG(lv) = SvREFCNT_inc(av);
1921 LvTARGOFF(lv) = cx->blk_loop.iterix;
1922 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1926 *itersvp = SvREFCNT_inc(sv);
1933 register PMOP *pm = cPMOP;
1949 register REGEXP *rx = PM_GETRE(pm);
1951 int force_on_match = 0;
1952 I32 oldsave = PL_savestack_ix;
1954 bool doutf8 = FALSE;
1955 #ifdef PERL_COPY_ON_WRITE
1960 /* known replacement string? */
1961 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1962 if (PL_op->op_flags & OPf_STACKED)
1964 else if (PL_op->op_private & OPpTARGET_MY)
1971 #ifdef PERL_COPY_ON_WRITE
1972 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1973 because they make integers such as 256 "false". */
1974 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1977 sv_force_normal_flags(TARG,0);
1980 #ifdef PERL_COPY_ON_WRITE
1984 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1985 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1986 DIE(aTHX_ PL_no_modify);
1989 s = SvPV(TARG, len);
1990 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1992 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1993 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1998 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2002 DIE(aTHX_ "panic: pp_subst");
2005 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2006 maxiters = 2 * slen + 10; /* We can match twice at each
2007 position, once with zero-length,
2008 second time with non-zero. */
2010 if (!rx->prelen && PL_curpm) {
2014 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2015 ? REXEC_COPY_STR : 0;
2017 r_flags |= REXEC_SCREAM;
2018 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
2019 SAVEINT(PL_multiline);
2020 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2023 if (rx->reganch & RE_USE_INTUIT) {
2025 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2029 /* How to do it in subst? */
2030 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2032 && ((rx->reganch & ROPT_NOSCAN)
2033 || !((rx->reganch & RE_INTUIT_TAIL)
2034 && (r_flags & REXEC_SCREAM))))
2039 /* only replace once? */
2040 once = !(rpm->op_pmflags & PMf_GLOBAL);
2042 /* known replacement string? */
2044 /* replacement needing upgrading? */
2045 if (DO_UTF8(TARG) && !doutf8) {
2046 nsv = sv_newmortal();
2049 sv_recode_to_utf8(nsv, PL_encoding);
2051 sv_utf8_upgrade(nsv);
2052 c = SvPV(nsv, clen);
2056 c = SvPV(dstr, clen);
2057 doutf8 = DO_UTF8(dstr);
2065 /* can do inplace substitution? */
2067 #ifdef PERL_COPY_ON_WRITE
2070 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2071 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2072 && (!doutf8 || SvUTF8(TARG))) {
2073 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2074 r_flags | REXEC_CHECKED))
2078 LEAVE_SCOPE(oldsave);
2081 #ifdef PERL_COPY_ON_WRITE
2082 if (SvIsCOW(TARG)) {
2083 assert (!force_on_match);
2087 if (force_on_match) {
2089 s = SvPV_force(TARG, len);
2094 SvSCREAM_off(TARG); /* disable possible screamer */
2096 rxtainted |= RX_MATCH_TAINTED(rx);
2097 m = orig + rx->startp[0];
2098 d = orig + rx->endp[0];
2100 if (m - s > strend - d) { /* faster to shorten from end */
2102 Copy(c, m, clen, char);
2107 Move(d, m, i, char);
2111 SvCUR_set(TARG, m - s);
2114 else if ((i = m - s)) { /* faster from front */
2122 Copy(c, m, clen, char);
2127 Copy(c, d, clen, char);
2132 TAINT_IF(rxtainted & 1);
2138 if (iters++ > maxiters)
2139 DIE(aTHX_ "Substitution loop");
2140 rxtainted |= RX_MATCH_TAINTED(rx);
2141 m = rx->startp[0] + orig;
2145 Move(s, d, i, char);
2149 Copy(c, d, clen, char);
2152 s = rx->endp[0] + orig;
2153 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2155 /* don't match same null twice */
2156 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2159 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2160 Move(s, d, i+1, char); /* include the NUL */
2162 TAINT_IF(rxtainted & 1);
2164 PUSHs(sv_2mortal(newSViv((I32)iters)));
2166 (void)SvPOK_only_UTF8(TARG);
2167 TAINT_IF(rxtainted);
2168 if (SvSMAGICAL(TARG)) {
2176 LEAVE_SCOPE(oldsave);
2180 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2181 r_flags | REXEC_CHECKED))
2183 if (force_on_match) {
2185 s = SvPV_force(TARG, len);
2188 #ifdef PERL_COPY_ON_WRITE
2191 rxtainted |= RX_MATCH_TAINTED(rx);
2192 dstr = NEWSV(25, len);
2193 sv_setpvn(dstr, m, s-m);
2198 register PERL_CONTEXT *cx;
2202 RETURNOP(cPMOP->op_pmreplroot);
2204 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2206 if (iters++ > maxiters)
2207 DIE(aTHX_ "Substitution loop");
2208 rxtainted |= RX_MATCH_TAINTED(rx);
2209 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2214 strend = s + (strend - m);
2216 m = rx->startp[0] + orig;
2217 if (doutf8 && !SvUTF8(dstr))
2218 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2220 sv_catpvn(dstr, s, m-s);
2221 s = rx->endp[0] + orig;
2223 sv_catpvn(dstr, c, clen);
2226 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2227 TARG, NULL, r_flags));
2228 if (doutf8 && !DO_UTF8(TARG))
2229 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2231 sv_catpvn(dstr, s, strend - s);
2233 #ifdef PERL_COPY_ON_WRITE
2234 /* The match may make the string COW. If so, brilliant, because that's
2235 just saved us one malloc, copy and free - the regexp has donated
2236 the old buffer, and we malloc an entirely new one, rather than the
2237 regexp malloc()ing a buffer and copying our original, only for
2238 us to throw it away here during the substitution. */
2239 if (SvIsCOW(TARG)) {
2240 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2244 (void)SvOOK_off(TARG);
2246 Safefree(SvPVX(TARG));
2248 SvPVX(TARG) = SvPVX(dstr);
2249 SvCUR_set(TARG, SvCUR(dstr));
2250 SvLEN_set(TARG, SvLEN(dstr));
2251 doutf8 |= DO_UTF8(dstr);
2255 TAINT_IF(rxtainted & 1);
2257 PUSHs(sv_2mortal(newSViv((I32)iters)));
2259 (void)SvPOK_only(TARG);
2262 TAINT_IF(rxtainted);
2265 LEAVE_SCOPE(oldsave);
2274 LEAVE_SCOPE(oldsave);
2283 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2284 ++*PL_markstack_ptr;
2285 LEAVE; /* exit inner scope */
2288 if (PL_stack_base + *PL_markstack_ptr > SP) {
2290 I32 gimme = GIMME_V;
2292 LEAVE; /* exit outer scope */
2293 (void)POPMARK; /* pop src */
2294 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2295 (void)POPMARK; /* pop dst */
2296 SP = PL_stack_base + POPMARK; /* pop original mark */
2297 if (gimme == G_SCALAR) {
2298 if (PL_op->op_private & OPpGREP_LEX) {
2299 SV* sv = sv_newmortal();
2300 sv_setiv(sv, items);
2308 else if (gimme == G_ARRAY)
2315 ENTER; /* enter inner scope */
2318 src = PL_stack_base[*PL_markstack_ptr];
2320 if (PL_op->op_private & OPpGREP_LEX)
2321 PAD_SVl(PL_op->op_targ) = src;
2325 RETURNOP(cLOGOP->op_other);
2336 register PERL_CONTEXT *cx;
2340 cxstack_ix++; /* temporarily protect top context */
2343 if (gimme == G_SCALAR) {
2346 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2348 *MARK = SvREFCNT_inc(TOPs);
2353 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2355 *MARK = sv_mortalcopy(sv);
2360 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2364 *MARK = &PL_sv_undef;
2368 else if (gimme == G_ARRAY) {
2369 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2370 if (!SvTEMP(*MARK)) {
2371 *MARK = sv_mortalcopy(*MARK);
2372 TAINT_NOT; /* Each item is independent */
2380 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2381 PL_curpm = newpm; /* ... and pop $1 et al */
2384 return pop_return();
2387 /* This duplicates the above code because the above code must not
2388 * get any slower by more conditions */
2396 register PERL_CONTEXT *cx;
2400 cxstack_ix++; /* temporarily protect top context */
2404 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2405 /* We are an argument to a function or grep().
2406 * This kind of lvalueness was legal before lvalue
2407 * subroutines too, so be backward compatible:
2408 * cannot report errors. */
2410 /* Scalar context *is* possible, on the LHS of -> only,
2411 * as in f()->meth(). But this is not an lvalue. */
2412 if (gimme == G_SCALAR)
2414 if (gimme == G_ARRAY) {
2415 if (!CvLVALUE(cx->blk_sub.cv))
2416 goto temporise_array;
2417 EXTEND_MORTAL(SP - newsp);
2418 for (mark = newsp + 1; mark <= SP; mark++) {
2421 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2422 *mark = sv_mortalcopy(*mark);
2424 /* Can be a localized value subject to deletion. */
2425 PL_tmps_stack[++PL_tmps_ix] = *mark;
2426 (void)SvREFCNT_inc(*mark);
2431 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2432 /* Here we go for robustness, not for speed, so we change all
2433 * the refcounts so the caller gets a live guy. Cannot set
2434 * TEMP, so sv_2mortal is out of question. */
2435 if (!CvLVALUE(cx->blk_sub.cv)) {
2441 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2443 if (gimme == G_SCALAR) {
2447 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2453 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2454 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2455 : "a readonly value" : "a temporary");
2457 else { /* Can be a localized value
2458 * subject to deletion. */
2459 PL_tmps_stack[++PL_tmps_ix] = *mark;
2460 (void)SvREFCNT_inc(*mark);
2463 else { /* Should not happen? */
2469 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2470 (MARK > SP ? "Empty array" : "Array"));
2474 else if (gimme == G_ARRAY) {
2475 EXTEND_MORTAL(SP - newsp);
2476 for (mark = newsp + 1; mark <= SP; mark++) {
2477 if (*mark != &PL_sv_undef
2478 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2479 /* Might be flattened array after $#array = */
2486 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2487 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2490 /* Can be a localized value subject to deletion. */
2491 PL_tmps_stack[++PL_tmps_ix] = *mark;
2492 (void)SvREFCNT_inc(*mark);
2498 if (gimme == G_SCALAR) {
2502 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2504 *MARK = SvREFCNT_inc(TOPs);
2509 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2511 *MARK = sv_mortalcopy(sv);
2516 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2520 *MARK = &PL_sv_undef;
2524 else if (gimme == G_ARRAY) {
2526 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2527 if (!SvTEMP(*MARK)) {
2528 *MARK = sv_mortalcopy(*MARK);
2529 TAINT_NOT; /* Each item is independent */
2538 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2539 PL_curpm = newpm; /* ... and pop $1 et al */
2542 return pop_return();
2547 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2549 SV *dbsv = GvSV(PL_DBsub);
2551 if (!PERLDB_SUB_NN) {
2555 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2556 || strEQ(GvNAME(gv), "END")
2557 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2558 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2559 && (gv = (GV*)*svp) ))) {
2560 /* Use GV from the stack as a fallback. */
2561 /* GV is potentially non-unique, or contain different CV. */
2562 SV *tmp = newRV((SV*)cv);
2563 sv_setsv(dbsv, tmp);
2567 gv_efullname3(dbsv, gv, Nullch);
2571 (void)SvUPGRADE(dbsv, SVt_PVIV);
2572 (void)SvIOK_on(dbsv);
2573 SAVEIV(SvIVX(dbsv));
2574 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2578 PL_curcopdb = PL_curcop;
2579 cv = GvCV(PL_DBsub);
2589 register PERL_CONTEXT *cx;
2591 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2594 DIE(aTHX_ "Not a CODE reference");
2595 switch (SvTYPE(sv)) {
2596 /* This is overwhelming the most common case: */
2598 if (!(cv = GvCVu((GV*)sv)))
2599 cv = sv_2cv(sv, &stash, &gv, FALSE);
2611 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2613 SP = PL_stack_base + POPMARK;
2616 if (SvGMAGICAL(sv)) {
2620 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2623 sym = SvPV(sv, n_a);
2625 DIE(aTHX_ PL_no_usym, "a subroutine");
2626 if (PL_op->op_private & HINT_STRICT_REFS)
2627 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2628 cv = get_cv(sym, TRUE);
2633 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2634 tryAMAGICunDEREF(to_cv);
2637 if (SvTYPE(cv) == SVt_PVCV)
2642 DIE(aTHX_ "Not a CODE reference");
2643 /* This is the second most common case: */
2653 if (!CvROOT(cv) && !CvXSUB(cv)) {
2658 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2659 if (CvASSERTION(cv) && PL_DBassertion)
2660 sv_setiv(PL_DBassertion, 1);
2662 cv = get_db_sub(&sv, cv);
2664 DIE(aTHX_ "No DBsub routine");
2667 if (!(CvXSUB(cv))) {
2668 /* This path taken at least 75% of the time */
2670 register I32 items = SP - MARK;
2671 AV* padlist = CvPADLIST(cv);
2672 push_return(PL_op->op_next);
2673 PUSHBLOCK(cx, CXt_SUB, MARK);
2676 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2677 * that eval'' ops within this sub know the correct lexical space.
2678 * Owing the speed considerations, we choose instead to search for
2679 * the cv using find_runcv() when calling doeval().
2681 if (CvDEPTH(cv) >= 2) {
2682 PERL_STACK_OVERFLOW_CHECK();
2683 pad_push(padlist, CvDEPTH(cv), 1);
2685 PAD_SET_CUR(padlist, CvDEPTH(cv));
2692 DEBUG_S(PerlIO_printf(Perl_debug_log,
2693 "%p entersub preparing @_\n", thr));
2695 av = (AV*)PAD_SVl(0);
2697 /* @_ is normally not REAL--this should only ever
2698 * happen when DB::sub() calls things that modify @_ */
2703 cx->blk_sub.savearray = GvAV(PL_defgv);
2704 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2705 CX_CURPAD_SAVE(cx->blk_sub);
2706 cx->blk_sub.argarray = av;
2709 if (items > AvMAX(av) + 1) {
2711 if (AvARRAY(av) != ary) {
2712 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2713 SvPVX(av) = (char*)ary;
2715 if (items > AvMAX(av) + 1) {
2716 AvMAX(av) = items - 1;
2717 Renew(ary,items,SV*);
2719 SvPVX(av) = (char*)ary;
2722 Copy(MARK,AvARRAY(av),items,SV*);
2723 AvFILLp(av) = items - 1;
2731 /* warning must come *after* we fully set up the context
2732 * stuff so that __WARN__ handlers can safely dounwind()
2735 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2736 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2737 sub_crush_depth(cv);
2739 DEBUG_S(PerlIO_printf(Perl_debug_log,
2740 "%p entersub returning %p\n", thr, CvSTART(cv)));
2742 RETURNOP(CvSTART(cv));
2745 #ifdef PERL_XSUB_OLDSTYLE
2746 if (CvOLDSTYLE(cv)) {
2747 I32 (*fp3)(int,int,int);
2749 register I32 items = SP - MARK;
2750 /* We dont worry to copy from @_. */
2755 PL_stack_sp = mark + 1;
2756 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2757 items = (*fp3)(CvXSUBANY(cv).any_i32,
2758 MARK - PL_stack_base + 1,
2760 PL_stack_sp = PL_stack_base + items;
2763 #endif /* PERL_XSUB_OLDSTYLE */
2765 I32 markix = TOPMARK;
2770 /* Need to copy @_ to stack. Alternative may be to
2771 * switch stack to @_, and copy return values
2772 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2775 av = GvAV(PL_defgv);
2776 items = AvFILLp(av) + 1; /* @_ is not tieable */
2779 /* Mark is at the end of the stack. */
2781 Copy(AvARRAY(av), SP + 1, items, SV*);
2786 /* We assume first XSUB in &DB::sub is the called one. */
2788 SAVEVPTR(PL_curcop);
2789 PL_curcop = PL_curcopdb;
2792 /* Do we need to open block here? XXXX */
2793 (void)(*CvXSUB(cv))(aTHX_ cv);
2795 /* Enforce some sanity in scalar context. */
2796 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2797 if (markix > PL_stack_sp - PL_stack_base)
2798 *(PL_stack_base + markix) = &PL_sv_undef;
2800 *(PL_stack_base + markix) = *PL_stack_sp;
2801 PL_stack_sp = PL_stack_base + markix;
2808 assert (0); /* Cannot get here. */
2809 /* This is deliberately moved here as spaghetti code to keep it out of the
2816 /* anonymous or undef'd function leaves us no recourse */
2817 if (CvANON(cv) || !(gv = CvGV(cv)))
2818 DIE(aTHX_ "Undefined subroutine called");
2820 /* autoloaded stub? */
2821 if (cv != GvCV(gv)) {
2824 /* should call AUTOLOAD now? */
2827 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2834 sub_name = sv_newmortal();
2835 gv_efullname3(sub_name, gv, Nullch);
2836 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2840 DIE(aTHX_ "Not a CODE reference");
2846 Perl_sub_crush_depth(pTHX_ CV *cv)
2849 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2851 SV* tmpstr = sv_newmortal();
2852 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2853 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2863 IV elem = SvIV(elemsv);
2865 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2866 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2869 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2870 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2872 elem -= PL_curcop->cop_arybase;
2873 if (SvTYPE(av) != SVt_PVAV)
2875 svp = av_fetch(av, elem, lval && !defer);
2877 if (!svp || *svp == &PL_sv_undef) {
2880 DIE(aTHX_ PL_no_aelem, elem);
2881 lv = sv_newmortal();
2882 sv_upgrade(lv, SVt_PVLV);
2884 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2885 LvTARG(lv) = SvREFCNT_inc(av);
2886 LvTARGOFF(lv) = elem;
2891 if (PL_op->op_private & OPpLVAL_INTRO)
2892 save_aelem(av, elem, svp);
2893 else if (PL_op->op_private & OPpDEREF)
2894 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2896 sv = (svp ? *svp : &PL_sv_undef);
2897 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2898 sv = sv_mortalcopy(sv);
2904 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2910 Perl_croak(aTHX_ PL_no_modify);
2911 if (SvTYPE(sv) < SVt_RV)
2912 sv_upgrade(sv, SVt_RV);
2913 else if (SvTYPE(sv) >= SVt_PV) {
2914 (void)SvOOK_off(sv);
2915 Safefree(SvPVX(sv));
2916 SvLEN(sv) = SvCUR(sv) = 0;
2920 SvRV(sv) = NEWSV(355,0);
2923 SvRV(sv) = (SV*)newAV();
2926 SvRV(sv) = (SV*)newHV();
2941 if (SvTYPE(rsv) == SVt_PVCV) {
2947 SETs(method_common(sv, Null(U32*)));
2955 U32 hash = SvUVX(sv);
2957 XPUSHs(method_common(sv, &hash));
2962 S_method_common(pTHX_ SV* meth, U32* hashp)
2971 SV *packsv = Nullsv;
2974 name = SvPV(meth, namelen);
2975 sv = *(PL_stack_base + TOPMARK + 1);
2978 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2987 /* this isn't a reference */
2990 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2992 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2994 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3001 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3002 !(ob=(SV*)GvIO(iogv)))
3004 /* this isn't the name of a filehandle either */
3006 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3007 ? !isIDFIRST_utf8((U8*)packname)
3008 : !isIDFIRST(*packname)
3011 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3012 SvOK(sv) ? "without a package or object reference"
3013 : "on an undefined value");
3015 /* assume it's a package name */
3016 stash = gv_stashpvn(packname, packlen, FALSE);
3020 SV* ref = newSViv(PTR2IV(stash));
3021 hv_store(PL_stashcache, packname, packlen, ref, 0);
3025 /* it _is_ a filehandle name -- replace with a reference */
3026 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3029 /* if we got here, ob should be a reference or a glob */
3030 if (!ob || !(SvOBJECT(ob)
3031 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3034 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3038 stash = SvSTASH(ob);
3041 /* NOTE: stash may be null, hope hv_fetch_ent and
3042 gv_fetchmethod can cope (it seems they can) */
3044 /* shortcut for simple names */
3046 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3048 gv = (GV*)HeVAL(he);
3049 if (isGV(gv) && GvCV(gv) &&
3050 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3051 return (SV*)GvCV(gv);
3055 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3058 /* This code tries to figure out just what went wrong with
3059 gv_fetchmethod. It therefore needs to duplicate a lot of
3060 the internals of that function. We can't move it inside
3061 Perl_gv_fetchmethod_autoload(), however, since that would
3062 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3069 for (p = name; *p; p++) {
3071 sep = p, leaf = p + 1;
3072 else if (*p == ':' && *(p + 1) == ':')
3073 sep = p, leaf = p + 2;
3075 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3076 /* the method name is unqualified or starts with SUPER:: */
3077 packname = sep ? CopSTASHPV(PL_curcop) :
3078 stash ? HvNAME(stash) : packname;
3081 "Can't use anonymous symbol table for method lookup");
3083 packlen = strlen(packname);
3086 /* the method name is qualified */
3088 packlen = sep - name;
3091 /* we're relying on gv_fetchmethod not autovivifying the stash */
3092 if (gv_stashpvn(packname, packlen, FALSE)) {
3094 "Can't locate object method \"%s\" via package \"%.*s\"",
3095 leaf, (int)packlen, packname);
3099 "Can't locate object method \"%s\" via package \"%.*s\""
3100 " (perhaps you forgot to load \"%.*s\"?)",
3101 leaf, (int)packlen, packname, (int)packlen, packname);
3104 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;