3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
19 /* This file contains 'hot' pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * By 'hot', we mean common ops whose execution speed is critical.
26 * By gathering them together into a single file, we encourage
27 * CPU cache hits on hot code. Also it could be taken as a warning not to
28 * change any code in this file unless you're sure it won't affect
33 #define PERL_IN_PP_HOT_C
47 PL_curcop = (COP*)PL_op;
48 TAINT_NOT; /* Each statement is presumed innocent */
49 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
58 if (PL_op->op_private & OPpLVAL_INTRO)
59 PUSHs(save_scalar(cGVOP_gv));
61 PUSHs(GvSV(cGVOP_gv));
72 PL_curcop = (COP*)PL_op;
78 PUSHMARK(PL_stack_sp);
93 XPUSHs((SV*)cGVOP_gv);
104 RETURNOP(cLOGOP->op_other);
112 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
114 temp = left; left = right; right = temp;
116 if (PL_tainting && PL_tainted && !SvTAINTED(left))
118 SvSetMagicSV(right, left);
127 RETURNOP(cLOGOP->op_other);
129 RETURNOP(cLOGOP->op_next);
135 TAINT_NOT; /* Each statement is presumed innocent */
136 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
138 oldsave = PL_scopestack[PL_scopestack_ix - 1];
139 LEAVE_SCOPE(oldsave);
145 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
152 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
153 bool rbyte = !DO_UTF8(right), rcopied = FALSE;
155 if (TARG == right && right != left) {
156 right = sv_2mortal(newSVpvn(rpv, rlen));
157 rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
162 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
163 lbyte = !DO_UTF8(left);
164 sv_setpvn(TARG, lpv, llen);
170 else { /* TARG == left */
171 if (SvGMAGICAL(left))
172 mg_get(left); /* or mg_get(left) may happen here */
175 lpv = SvPV_nomg(left, llen);
176 lbyte = !DO_UTF8(left);
181 #if defined(PERL_Y2KWARN)
182 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
183 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
184 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
186 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
187 "about to append an integer to '19'");
192 if (lbyte != rbyte) {
194 sv_utf8_upgrade_nomg(TARG);
197 right = sv_2mortal(newSVpvn(rpv, rlen));
198 sv_utf8_upgrade_nomg(right);
199 rpv = SvPV(right, rlen);
202 sv_catpvn_nomg(TARG, rpv, rlen);
213 if (PL_op->op_flags & OPf_MOD) {
214 if (PL_op->op_private & OPpLVAL_INTRO)
215 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
216 if (PL_op->op_private & OPpDEREF) {
218 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
227 tryAMAGICunTARGET(iter, 0);
228 PL_last_in_gv = (GV*)(*PL_stack_sp--);
229 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
230 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
231 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
234 XPUSHs((SV*)PL_last_in_gv);
237 PL_last_in_gv = (GV*)(*PL_stack_sp--);
240 return do_readline();
245 dSP; tryAMAGICbinSET(eq,0);
246 #ifndef NV_PRESERVES_UV
247 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
249 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
253 #ifdef PERL_PRESERVE_IVUV
256 /* Unless the left argument is integer in range we are going
257 to have to use NV maths. Hence only attempt to coerce the
258 right argument if we know the left is integer. */
261 bool auvok = SvUOK(TOPm1s);
262 bool buvok = SvUOK(TOPs);
264 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
265 /* Casting IV to UV before comparison isn't going to matter
266 on 2s complement. On 1s complement or sign&magnitude
267 (if we have any of them) it could to make negative zero
268 differ from normal zero. As I understand it. (Need to
269 check - is negative zero implementation defined behaviour
271 UV buv = SvUVX(POPs);
272 UV auv = SvUVX(TOPs);
274 SETs(boolSV(auv == buv));
277 { /* ## Mixed IV,UV ## */
281 /* == is commutative so doesn't matter which is left or right */
283 /* top of stack (b) is the iv */
292 /* As uv is a UV, it's >0, so it cannot be == */
296 /* we know iv is >= 0 */
297 SETs(boolSV((UV)iv == SvUVX(uvp)));
305 SETs(boolSV(TOPn == value));
313 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
314 DIE(aTHX_ PL_no_modify);
315 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
316 && SvIVX(TOPs) != IV_MAX)
319 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
321 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
334 RETURNOP(cLOGOP->op_other);
340 /* Most of this is lifted straight from pp_defined */
345 if (!sv || !SvANY(sv)) {
347 RETURNOP(cLOGOP->op_other);
350 switch (SvTYPE(sv)) {
352 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
356 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
360 if (CvROOT(sv) || CvXSUB(sv))
371 RETURNOP(cLOGOP->op_other);
376 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
377 useleft = USE_LEFT(TOPm1s);
378 #ifdef PERL_PRESERVE_IVUV
379 /* We must see if we can perform the addition with integers if possible,
380 as the integer code detects overflow while the NV code doesn't.
381 If either argument hasn't had a numeric conversion yet attempt to get
382 the IV. It's important to do this now, rather than just assuming that
383 it's not IOK as a PV of "9223372036854775806" may not take well to NV
384 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
385 integer in case the second argument is IV=9223372036854775806
386 We can (now) rely on sv_2iv to do the right thing, only setting the
387 public IOK flag if the value in the NV (or PV) slot is truly integer.
389 A side effect is that this also aggressively prefers integer maths over
390 fp maths for integer values.
392 How to detect overflow?
394 C 99 section 6.2.6.1 says
396 The range of nonnegative values of a signed integer type is a subrange
397 of the corresponding unsigned integer type, and the representation of
398 the same value in each type is the same. A computation involving
399 unsigned operands can never overflow, because a result that cannot be
400 represented by the resulting unsigned integer type is reduced modulo
401 the number that is one greater than the largest value that can be
402 represented by the resulting type.
406 which I read as "unsigned ints wrap."
408 signed integer overflow seems to be classed as "exception condition"
410 If an exceptional condition occurs during the evaluation of an
411 expression (that is, if the result is not mathematically defined or not
412 in the range of representable values for its type), the behavior is
415 (6.5, the 5th paragraph)
417 I had assumed that on 2s complement machines signed arithmetic would
418 wrap, hence coded pp_add and pp_subtract on the assumption that
419 everything perl builds on would be happy. After much wailing and
420 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
421 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
422 unsigned code below is actually shorter than the old code. :-)
427 /* Unless the left argument is integer in range we are going to have to
428 use NV maths. Hence only attempt to coerce the right argument if
429 we know the left is integer. */
437 /* left operand is undef, treat as zero. + 0 is identity,
438 Could SETi or SETu right now, but space optimise by not adding
439 lots of code to speed up what is probably a rarish case. */
441 /* Left operand is defined, so is it IV? */
444 if ((auvok = SvUOK(TOPm1s)))
447 register IV aiv = SvIVX(TOPm1s);
450 auvok = 1; /* Now acting as a sign flag. */
451 } else { /* 2s complement assumption for IV_MIN */
459 bool result_good = 0;
462 bool buvok = SvUOK(TOPs);
467 register IV biv = SvIVX(TOPs);
474 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
475 else "IV" now, independent of how it came in.
476 if a, b represents positive, A, B negative, a maps to -A etc
481 all UV maths. negate result if A negative.
482 add if signs same, subtract if signs differ. */
488 /* Must get smaller */
494 /* result really should be -(auv-buv). as its negation
495 of true value, need to swap our result flag */
512 if (result <= (UV)IV_MIN)
515 /* result valid, but out of range for IV. */
520 } /* Overflow, drop through to NVs. */
527 /* left operand is undef, treat as zero. + 0.0 is identity. */
531 SETn( value + TOPn );
539 AV *av = PL_op->op_flags & OPf_SPECIAL ?
540 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
541 U32 lval = PL_op->op_flags & OPf_MOD;
542 SV** svp = av_fetch(av, PL_op->op_private, lval);
543 SV *sv = (svp ? *svp : &PL_sv_undef);
545 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
546 sv = sv_mortalcopy(sv);
555 do_join(TARG, *MARK, MARK, SP);
566 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
567 * will be enough to hold an OP*.
569 SV* sv = sv_newmortal();
570 sv_upgrade(sv, SVt_PVLV);
572 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
580 /* Oversized hot code. */
584 dSP; dMARK; dORIGMARK;
590 if (PL_op->op_flags & OPf_STACKED)
595 if (gv && (io = GvIO(gv))
596 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
599 if (MARK == ORIGMARK) {
600 /* If using default handle then we need to make space to
601 * pass object as 1st arg, so move other args up ...
605 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
609 *MARK = SvTIED_obj((SV*)io, mg);
612 call_method("PRINT", G_SCALAR);
620 if (!(io = GvIO(gv))) {
621 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
622 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
624 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
625 report_evil_fh(gv, io, PL_op->op_type);
626 SETERRNO(EBADF,RMS_IFI);
629 else if (!(fp = IoOFP(io))) {
630 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
632 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
633 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
634 report_evil_fh(gv, io, PL_op->op_type);
636 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
641 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
643 if (!do_print(*MARK, fp))
647 if (!do_print(PL_ofs_sv, fp)) { /* $, */
656 if (!do_print(*MARK, fp))
664 if (PL_ors_sv && SvOK(PL_ors_sv))
665 if (!do_print(PL_ors_sv, fp)) /* $\ */
668 if (IoFLAGS(io) & IOf_FLUSH)
669 if (PerlIO_flush(fp) == EOF)
690 tryAMAGICunDEREF(to_av);
693 if (SvTYPE(av) != SVt_PVAV)
694 DIE(aTHX_ "Not an ARRAY reference");
695 if (PL_op->op_flags & OPf_REF) {
700 if (GIMME == G_SCALAR)
701 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
705 else if (PL_op->op_flags & OPf_MOD
706 && PL_op->op_private & OPpLVAL_INTRO)
707 Perl_croak(aTHX_ PL_no_localize_ref);
710 if (SvTYPE(sv) == SVt_PVAV) {
712 if (PL_op->op_flags & OPf_REF) {
717 if (GIMME == G_SCALAR)
718 Perl_croak(aTHX_ "Can't return array to lvalue"
727 if (SvTYPE(sv) != SVt_PVGV) {
731 if (SvGMAGICAL(sv)) {
737 if (PL_op->op_flags & OPf_REF ||
738 PL_op->op_private & HINT_STRICT_REFS)
739 DIE(aTHX_ PL_no_usym, "an ARRAY");
740 if (ckWARN(WARN_UNINITIALIZED))
742 if (GIMME == G_ARRAY) {
749 if ((PL_op->op_flags & OPf_SPECIAL) &&
750 !(PL_op->op_flags & OPf_MOD))
752 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
754 && (!is_gv_magical(sym,len,0)
755 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
761 if (PL_op->op_private & HINT_STRICT_REFS)
762 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
763 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
770 if (PL_op->op_private & OPpLVAL_INTRO)
772 if (PL_op->op_flags & OPf_REF) {
777 if (GIMME == G_SCALAR)
778 Perl_croak(aTHX_ "Can't return array to lvalue"
786 if (GIMME == G_ARRAY) {
787 I32 maxarg = AvFILL(av) + 1;
788 (void)POPs; /* XXXX May be optimized away? */
790 if (SvRMAGICAL(av)) {
792 for (i=0; i < (U32)maxarg; i++) {
793 SV **svp = av_fetch(av, i, FALSE);
794 /* See note in pp_helem, and bug id #27839 */
796 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
801 Copy(AvARRAY(av), SP+1, maxarg, SV*);
805 else if (GIMME_V == G_SCALAR) {
807 I32 maxarg = AvFILL(av) + 1;
821 tryAMAGICunDEREF(to_hv);
824 if (SvTYPE(hv) != SVt_PVHV)
825 DIE(aTHX_ "Not a HASH reference");
826 if (PL_op->op_flags & OPf_REF) {
831 if (gimme != G_ARRAY)
832 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
836 else if (PL_op->op_flags & OPf_MOD
837 && PL_op->op_private & OPpLVAL_INTRO)
838 Perl_croak(aTHX_ PL_no_localize_ref);
841 if (SvTYPE(sv) == SVt_PVHV) {
843 if (PL_op->op_flags & OPf_REF) {
848 if (gimme != G_ARRAY)
849 Perl_croak(aTHX_ "Can't return hash to lvalue"
858 if (SvTYPE(sv) != SVt_PVGV) {
862 if (SvGMAGICAL(sv)) {
868 if (PL_op->op_flags & OPf_REF ||
869 PL_op->op_private & HINT_STRICT_REFS)
870 DIE(aTHX_ PL_no_usym, "a HASH");
871 if (ckWARN(WARN_UNINITIALIZED))
873 if (gimme == G_ARRAY) {
880 if ((PL_op->op_flags & OPf_SPECIAL) &&
881 !(PL_op->op_flags & OPf_MOD))
883 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
885 && (!is_gv_magical(sym,len,0)
886 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
892 if (PL_op->op_private & HINT_STRICT_REFS)
893 DIE(aTHX_ PL_no_symref, sym, "a HASH");
894 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
901 if (PL_op->op_private & OPpLVAL_INTRO)
903 if (PL_op->op_flags & OPf_REF) {
908 if (gimme != G_ARRAY)
909 Perl_croak(aTHX_ "Can't return hash to lvalue"
917 if (gimme == G_ARRAY) { /* array wanted */
918 *PL_stack_sp = (SV*)hv;
921 else if (gimme == G_SCALAR) {
923 TARG = Perl_hv_scalar(aTHX_ hv);
930 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
936 if (ckWARN(WARN_MISC)) {
937 if (relem == firstrelem &&
939 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
940 SvTYPE(SvRV(*relem)) == SVt_PVHV))
942 Perl_warner(aTHX_ packWARN(WARN_MISC),
943 "Reference found where even-sized list expected");
946 Perl_warner(aTHX_ packWARN(WARN_MISC),
947 "Odd number of elements in hash assignment");
950 tmpstr = NEWSV(29,0);
951 didstore = hv_store_ent(hash,*relem,tmpstr,0);
952 if (SvMAGICAL(hash)) {
953 if (SvSMAGICAL(tmpstr))
965 SV **lastlelem = PL_stack_sp;
966 SV **lastrelem = PL_stack_base + POPMARK;
967 SV **firstrelem = PL_stack_base + POPMARK + 1;
968 SV **firstlelem = lastrelem + 1;
981 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
984 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
987 /* If there's a common identifier on both sides we have to take
988 * special care that assigning the identifier on the left doesn't
989 * clobber a value on the right that's used later in the list.
991 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
992 EXTEND_MORTAL(lastrelem - firstrelem + 1);
993 for (relem = firstrelem; relem <= lastrelem; relem++) {
996 TAINT_NOT; /* Each item is independent */
997 *relem = sv_mortalcopy(sv);
1007 while (lelem <= lastlelem) {
1008 TAINT_NOT; /* Each item stands on its own, taintwise. */
1010 switch (SvTYPE(sv)) {
1013 magic = SvMAGICAL(ary) != 0;
1015 av_extend(ary, lastrelem - relem);
1017 while (relem <= lastrelem) { /* gobble up all the rest */
1021 sv_setsv(sv,*relem);
1023 didstore = av_store(ary,i++,sv);
1033 case SVt_PVHV: { /* normal hash */
1037 magic = SvMAGICAL(hash) != 0;
1039 firsthashrelem = relem;
1041 while (relem < lastrelem) { /* gobble up all the rest */
1046 sv = &PL_sv_no, relem++;
1047 tmpstr = NEWSV(29,0);
1049 sv_setsv(tmpstr,*relem); /* value */
1050 *(relem++) = tmpstr;
1051 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1052 /* key overwrites an existing entry */
1054 didstore = hv_store_ent(hash,sv,tmpstr,0);
1056 if (SvSMAGICAL(tmpstr))
1063 if (relem == lastrelem) {
1064 do_oddball(hash, relem, firstrelem);
1070 if (SvIMMORTAL(sv)) {
1071 if (relem <= lastrelem)
1075 if (relem <= lastrelem) {
1076 sv_setsv(sv, *relem);
1080 sv_setsv(sv, &PL_sv_undef);
1085 if (PL_delaymagic & ~DM_DELAY) {
1086 if (PL_delaymagic & DM_UID) {
1087 #ifdef HAS_SETRESUID
1088 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1089 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1092 # ifdef HAS_SETREUID
1093 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1094 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1097 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1098 (void)setruid(PL_uid);
1099 PL_delaymagic &= ~DM_RUID;
1101 # endif /* HAS_SETRUID */
1103 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1104 (void)seteuid(PL_euid);
1105 PL_delaymagic &= ~DM_EUID;
1107 # endif /* HAS_SETEUID */
1108 if (PL_delaymagic & DM_UID) {
1109 if (PL_uid != PL_euid)
1110 DIE(aTHX_ "No setreuid available");
1111 (void)PerlProc_setuid(PL_uid);
1113 # endif /* HAS_SETREUID */
1114 #endif /* HAS_SETRESUID */
1115 PL_uid = PerlProc_getuid();
1116 PL_euid = PerlProc_geteuid();
1118 if (PL_delaymagic & DM_GID) {
1119 #ifdef HAS_SETRESGID
1120 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1121 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1124 # ifdef HAS_SETREGID
1125 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1126 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1129 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1130 (void)setrgid(PL_gid);
1131 PL_delaymagic &= ~DM_RGID;
1133 # endif /* HAS_SETRGID */
1135 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1136 (void)setegid(PL_egid);
1137 PL_delaymagic &= ~DM_EGID;
1139 # endif /* HAS_SETEGID */
1140 if (PL_delaymagic & DM_GID) {
1141 if (PL_gid != PL_egid)
1142 DIE(aTHX_ "No setregid available");
1143 (void)PerlProc_setgid(PL_gid);
1145 # endif /* HAS_SETREGID */
1146 #endif /* HAS_SETRESGID */
1147 PL_gid = PerlProc_getgid();
1148 PL_egid = PerlProc_getegid();
1150 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1154 if (gimme == G_VOID)
1155 SP = firstrelem - 1;
1156 else if (gimme == G_SCALAR) {
1159 SETi(lastrelem - firstrelem + 1 - duplicates);
1166 /* Removes from the stack the entries which ended up as
1167 * duplicated keys in the hash (fix for [perl #24380]) */
1168 Move(firsthashrelem + duplicates,
1169 firsthashrelem, duplicates, SV**);
1170 lastrelem -= duplicates;
1175 SP = firstrelem + (lastlelem - firstlelem);
1176 lelem = firstlelem + (relem - firstrelem);
1178 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1186 register PMOP *pm = cPMOP;
1187 SV *rv = sv_newmortal();
1188 SV *sv = newSVrv(rv, "Regexp");
1189 if (pm->op_pmdynflags & PMdf_TAINTED)
1191 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1198 register PMOP *pm = cPMOP;
1204 I32 r_flags = REXEC_CHECKED;
1205 char *truebase; /* Start of string */
1206 register REGEXP *rx = PM_GETRE(pm);
1211 I32 oldsave = PL_savestack_ix;
1212 I32 update_minmatch = 1;
1213 I32 had_zerolen = 0;
1215 if (PL_op->op_flags & OPf_STACKED)
1217 else if (PL_op->op_private & OPpTARGET_MY)
1224 PUTBACK; /* EVAL blocks need stack_sp. */
1225 s = SvPV(TARG, len);
1228 DIE(aTHX_ "panic: pp_match");
1229 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1230 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1233 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1235 /* PMdf_USED is set after a ?? matches once */
1236 if (pm->op_pmdynflags & PMdf_USED) {
1238 if (gimme == G_ARRAY)
1243 /* empty pattern special-cased to use last successful pattern if possible */
1244 if (!rx->prelen && PL_curpm) {
1249 if (rx->minlen > (I32)len)
1254 /* XXXX What part of this is needed with true \G-support? */
1255 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1257 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1258 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1259 if (mg && mg->mg_len >= 0) {
1260 if (!(rx->reganch & ROPT_GPOS_SEEN))
1261 rx->endp[0] = rx->startp[0] = mg->mg_len;
1262 else if (rx->reganch & ROPT_ANCH_GPOS) {
1263 r_flags |= REXEC_IGNOREPOS;
1264 rx->endp[0] = rx->startp[0] = mg->mg_len;
1266 minmatch = (mg->mg_flags & MGf_MINMATCH);
1267 update_minmatch = 0;
1271 if ((!global && rx->nparens)
1272 || SvTEMP(TARG) || PL_sawampersand)
1273 r_flags |= REXEC_COPY_STR;
1275 r_flags |= REXEC_SCREAM;
1278 if (global && rx->startp[0] != -1) {
1279 t = s = rx->endp[0] + truebase;
1280 if ((s + rx->minlen) > strend)
1282 if (update_minmatch++)
1283 minmatch = had_zerolen;
1285 if (rx->reganch & RE_USE_INTUIT &&
1286 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1287 PL_bostr = truebase;
1288 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1292 if ( (rx->reganch & ROPT_CHECK_ALL)
1294 && ((rx->reganch & ROPT_NOSCAN)
1295 || !((rx->reganch & RE_INTUIT_TAIL)
1296 && (r_flags & REXEC_SCREAM)))
1297 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1300 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1303 if (dynpm->op_pmflags & PMf_ONCE)
1304 dynpm->op_pmdynflags |= PMdf_USED;
1313 RX_MATCH_TAINTED_on(rx);
1314 TAINT_IF(RX_MATCH_TAINTED(rx));
1315 if (gimme == G_ARRAY) {
1316 I32 nparens, i, len;
1318 nparens = rx->nparens;
1319 if (global && !nparens)
1323 SPAGAIN; /* EVAL blocks could move the stack. */
1324 EXTEND(SP, nparens + i);
1325 EXTEND_MORTAL(nparens + i);
1326 for (i = !i; i <= nparens; i++) {
1327 PUSHs(sv_newmortal());
1329 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1330 len = rx->endp[i] - rx->startp[i];
1331 s = rx->startp[i] + truebase;
1332 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1333 len < 0 || len > strend - s)
1334 DIE(aTHX_ "panic: pp_match start/end pointers");
1335 sv_setpvn(*SP, s, len);
1336 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1341 if (dynpm->op_pmflags & PMf_CONTINUE) {
1343 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1344 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1346 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1347 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1349 if (rx->startp[0] != -1) {
1350 mg->mg_len = rx->endp[0];
1351 if (rx->startp[0] == rx->endp[0])
1352 mg->mg_flags |= MGf_MINMATCH;
1354 mg->mg_flags &= ~MGf_MINMATCH;
1357 had_zerolen = (rx->startp[0] != -1
1358 && rx->startp[0] == rx->endp[0]);
1359 PUTBACK; /* EVAL blocks may use stack */
1360 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1365 LEAVE_SCOPE(oldsave);
1371 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1372 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1374 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1375 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1377 if (rx->startp[0] != -1) {
1378 mg->mg_len = rx->endp[0];
1379 if (rx->startp[0] == rx->endp[0])
1380 mg->mg_flags |= MGf_MINMATCH;
1382 mg->mg_flags &= ~MGf_MINMATCH;
1385 LEAVE_SCOPE(oldsave);
1389 yup: /* Confirmed by INTUIT */
1391 RX_MATCH_TAINTED_on(rx);
1392 TAINT_IF(RX_MATCH_TAINTED(rx));
1394 if (dynpm->op_pmflags & PMf_ONCE)
1395 dynpm->op_pmdynflags |= PMdf_USED;
1396 if (RX_MATCH_COPIED(rx))
1397 Safefree(rx->subbeg);
1398 RX_MATCH_COPIED_off(rx);
1399 rx->subbeg = Nullch;
1401 rx->subbeg = truebase;
1402 rx->startp[0] = s - truebase;
1403 if (RX_MATCH_UTF8(rx)) {
1404 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1405 rx->endp[0] = t - truebase;
1408 rx->endp[0] = s - truebase + rx->minlen;
1410 rx->sublen = strend - truebase;
1413 if (PL_sawampersand) {
1415 #ifdef PERL_COPY_ON_WRITE
1416 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1418 PerlIO_printf(Perl_debug_log,
1419 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1420 (int) SvTYPE(TARG), truebase, t,
1423 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1424 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1425 assert (SvPOKp(rx->saved_copy));
1430 rx->subbeg = savepvn(t, strend - t);
1431 #ifdef PERL_COPY_ON_WRITE
1432 rx->saved_copy = Nullsv;
1435 rx->sublen = strend - t;
1436 RX_MATCH_COPIED_on(rx);
1437 off = rx->startp[0] = s - t;
1438 rx->endp[0] = off + rx->minlen;
1440 else { /* startp/endp are used by @- @+. */
1441 rx->startp[0] = s - truebase;
1442 rx->endp[0] = s - truebase + rx->minlen;
1444 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1445 LEAVE_SCOPE(oldsave);
1450 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1451 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1452 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1457 LEAVE_SCOPE(oldsave);
1458 if (gimme == G_ARRAY)
1464 Perl_do_readline(pTHX)
1466 dSP; dTARGETSTACKED;
1471 register IO *io = GvIO(PL_last_in_gv);
1472 register I32 type = PL_op->op_type;
1473 I32 gimme = GIMME_V;
1476 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1478 XPUSHs(SvTIED_obj((SV*)io, mg));
1481 call_method("READLINE", gimme);
1484 if (gimme == G_SCALAR) {
1486 SvSetSV_nosteal(TARG, result);
1495 if (IoFLAGS(io) & IOf_ARGV) {
1496 if (IoFLAGS(io) & IOf_START) {
1498 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1499 IoFLAGS(io) &= ~IOf_START;
1500 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1501 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1502 SvSETMAGIC(GvSV(PL_last_in_gv));
1507 fp = nextargv(PL_last_in_gv);
1508 if (!fp) { /* Note: fp != IoIFP(io) */
1509 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1512 else if (type == OP_GLOB)
1513 fp = Perl_start_glob(aTHX_ POPs, io);
1515 else if (type == OP_GLOB)
1517 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1518 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1522 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1523 && (!io || !(IoFLAGS(io) & IOf_START))) {
1524 if (type == OP_GLOB)
1525 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1526 "glob failed (can't start child: %s)",
1529 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1531 if (gimme == G_SCALAR) {
1532 /* undef TARG, and push that undefined value */
1533 if (type != OP_RCATLINE) {
1534 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1542 if (gimme == G_SCALAR) {
1546 (void)SvUPGRADE(sv, SVt_PV);
1547 tmplen = SvLEN(sv); /* remember if already alloced */
1548 if (!tmplen && !SvREADONLY(sv))
1549 Sv_Grow(sv, 80); /* try short-buffering it */
1551 if (type == OP_RCATLINE && SvOK(sv)) {
1554 (void)SvPV_force(sv, n_a);
1560 sv = sv_2mortal(NEWSV(57, 80));
1564 /* This should not be marked tainted if the fp is marked clean */
1565 #define MAYBE_TAINT_LINE(io, sv) \
1566 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1571 /* delay EOF state for a snarfed empty file */
1572 #define SNARF_EOF(gimme,rs,io,sv) \
1573 (gimme != G_SCALAR || SvCUR(sv) \
1574 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1578 if (!sv_gets(sv, fp, offset)
1580 || SNARF_EOF(gimme, PL_rs, io, sv)
1581 || PerlIO_error(fp)))
1583 PerlIO_clearerr(fp);
1584 if (IoFLAGS(io) & IOf_ARGV) {
1585 fp = nextargv(PL_last_in_gv);
1588 (void)do_close(PL_last_in_gv, FALSE);
1590 else if (type == OP_GLOB) {
1591 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1592 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1593 "glob failed (child exited with status %d%s)",
1594 (int)(STATUS_CURRENT >> 8),
1595 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1598 if (gimme == G_SCALAR) {
1599 if (type != OP_RCATLINE) {
1600 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1606 MAYBE_TAINT_LINE(io, sv);
1609 MAYBE_TAINT_LINE(io, sv);
1611 IoFLAGS(io) |= IOf_NOLINE;
1615 if (type == OP_GLOB) {
1618 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1619 tmps = SvEND(sv) - 1;
1620 if (*tmps == *SvPVX(PL_rs)) {
1625 for (tmps = SvPVX(sv); *tmps; tmps++)
1626 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1627 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1629 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1630 (void)POPs; /* Unmatched wildcard? Chuck it... */
1633 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1634 U8 *s = (U8*)SvPVX(sv) + offset;
1635 STRLEN len = SvCUR(sv) - offset;
1638 if (ckWARN(WARN_UTF8) &&
1639 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1640 /* Emulate :encoding(utf8) warning in the same case. */
1641 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1642 "utf8 \"\\x%02X\" does not map to Unicode",
1643 f < (U8*)SvEND(sv) ? *f : 0);
1645 if (gimme == G_ARRAY) {
1646 if (SvLEN(sv) - SvCUR(sv) > 20) {
1647 SvLEN_set(sv, SvCUR(sv)+1);
1648 Renew(SvPVX(sv), SvLEN(sv), char);
1650 sv = sv_2mortal(NEWSV(58, 80));
1653 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1654 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1658 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1659 Renew(SvPVX(sv), SvLEN(sv), char);
1668 register PERL_CONTEXT *cx;
1669 I32 gimme = OP_GIMME(PL_op, -1);
1672 if (cxstack_ix >= 0)
1673 gimme = cxstack[cxstack_ix].blk_gimme;
1681 PUSHBLOCK(cx, CXt_BLOCK, SP);
1693 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1694 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1696 #ifdef PERL_COPY_ON_WRITE
1697 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1699 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1703 if (SvTYPE(hv) == SVt_PVHV) {
1704 if (PL_op->op_private & OPpLVAL_INTRO) {
1707 /* does the element we're localizing already exist? */
1709 /* can we determine whether it exists? */
1711 || mg_find((SV*)hv, PERL_MAGIC_env)
1712 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1713 /* Try to preserve the existenceness of a tied hash
1714 * element by using EXISTS and DELETE if possible.
1715 * Fallback to FETCH and STORE otherwise */
1716 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1717 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1718 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1720 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1723 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1724 svp = he ? &HeVAL(he) : 0;
1730 if (!svp || *svp == &PL_sv_undef) {
1735 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1737 lv = sv_newmortal();
1738 sv_upgrade(lv, SVt_PVLV);
1740 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1741 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1742 LvTARG(lv) = SvREFCNT_inc(hv);
1747 if (PL_op->op_private & OPpLVAL_INTRO) {
1748 if (HvNAME(hv) && isGV(*svp))
1749 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1753 char *key = SvPV(keysv, keylen);
1754 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1756 save_helem(hv, keysv, svp);
1759 else if (PL_op->op_private & OPpDEREF)
1760 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1762 sv = (svp ? *svp : &PL_sv_undef);
1763 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1764 * Pushing the magical RHS on to the stack is useless, since
1765 * that magic is soon destined to be misled by the local(),
1766 * and thus the later pp_sassign() will fail to mg_get() the
1767 * old value. This should also cure problems with delayed
1768 * mg_get()s. GSAR 98-07-03 */
1769 if (!lval && SvGMAGICAL(sv))
1770 sv = sv_mortalcopy(sv);
1778 register PERL_CONTEXT *cx;
1784 if (PL_op->op_flags & OPf_SPECIAL) {
1785 cx = &cxstack[cxstack_ix];
1786 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1791 gimme = OP_GIMME(PL_op, -1);
1793 if (cxstack_ix >= 0)
1794 gimme = cxstack[cxstack_ix].blk_gimme;
1800 if (gimme == G_VOID)
1802 else if (gimme == G_SCALAR) {
1805 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1808 *MARK = sv_mortalcopy(TOPs);
1811 *MARK = &PL_sv_undef;
1815 else if (gimme == G_ARRAY) {
1816 /* in case LEAVE wipes old return values */
1817 for (mark = newsp + 1; mark <= SP; mark++) {
1818 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1819 *mark = sv_mortalcopy(*mark);
1820 TAINT_NOT; /* Each item is independent */
1824 PL_curpm = newpm; /* Don't pop $1 et al till now */
1834 register PERL_CONTEXT *cx;
1840 cx = &cxstack[cxstack_ix];
1841 if (CxTYPE(cx) != CXt_LOOP)
1842 DIE(aTHX_ "panic: pp_iter");
1844 itersvp = CxITERVAR(cx);
1845 av = cx->blk_loop.iterary;
1846 if (SvTYPE(av) != SVt_PVAV) {
1847 /* iterate ($min .. $max) */
1848 if (cx->blk_loop.iterlval) {
1849 /* string increment */
1850 register SV* cur = cx->blk_loop.iterlval;
1852 char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1853 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1854 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1855 /* safe to reuse old SV */
1856 sv_setsv(*itersvp, cur);
1860 /* we need a fresh SV every time so that loop body sees a
1861 * completely new SV for closures/references to work as
1864 *itersvp = newSVsv(cur);
1865 SvREFCNT_dec(oldsv);
1867 if (strEQ(SvPVX(cur), max))
1868 sv_setiv(cur, 0); /* terminate next time */
1875 /* integer increment */
1876 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1879 /* don't risk potential race */
1880 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1881 /* safe to reuse old SV */
1882 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1886 /* we need a fresh SV every time so that loop body sees a
1887 * completely new SV for closures/references to work as they
1890 *itersvp = newSViv(cx->blk_loop.iterix++);
1891 SvREFCNT_dec(oldsv);
1897 if (PL_op->op_private & OPpITER_REVERSED) {
1898 /* In reverse, use itermax as the min :-) */
1899 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1902 if (SvMAGICAL(av) || AvREIFY(av)) {
1903 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1910 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1914 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1918 if (SvMAGICAL(av) || AvREIFY(av)) {
1919 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1926 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1930 if (sv && SvREFCNT(sv) == 0) {
1932 Perl_croak(aTHX_ "Use of freed value in iteration");
1939 if (av != PL_curstack && sv == &PL_sv_undef) {
1940 SV *lv = cx->blk_loop.iterlval;
1941 if (lv && SvREFCNT(lv) > 1) {
1946 SvREFCNT_dec(LvTARG(lv));
1948 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1949 sv_upgrade(lv, SVt_PVLV);
1951 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1953 LvTARG(lv) = SvREFCNT_inc(av);
1954 LvTARGOFF(lv) = cx->blk_loop.iterix;
1955 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1960 *itersvp = SvREFCNT_inc(sv);
1961 SvREFCNT_dec(oldsv);
1969 register PMOP *pm = cPMOP;
1985 register REGEXP *rx = PM_GETRE(pm);
1987 int force_on_match = 0;
1988 I32 oldsave = PL_savestack_ix;
1990 bool doutf8 = FALSE;
1991 #ifdef PERL_COPY_ON_WRITE
1996 /* known replacement string? */
1997 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1998 if (PL_op->op_flags & OPf_STACKED)
2000 else if (PL_op->op_private & OPpTARGET_MY)
2007 #ifdef PERL_COPY_ON_WRITE
2008 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2009 because they make integers such as 256 "false". */
2010 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2013 sv_force_normal_flags(TARG,0);
2016 #ifdef PERL_COPY_ON_WRITE
2020 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2021 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2022 DIE(aTHX_ PL_no_modify);
2025 s = SvPV(TARG, len);
2026 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2028 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2029 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2034 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2038 DIE(aTHX_ "panic: pp_subst");
2041 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2042 maxiters = 2 * slen + 10; /* We can match twice at each
2043 position, once with zero-length,
2044 second time with non-zero. */
2046 if (!rx->prelen && PL_curpm) {
2050 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2051 ? REXEC_COPY_STR : 0;
2053 r_flags |= REXEC_SCREAM;
2056 if (rx->reganch & RE_USE_INTUIT) {
2058 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2062 /* How to do it in subst? */
2063 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2065 && ((rx->reganch & ROPT_NOSCAN)
2066 || !((rx->reganch & RE_INTUIT_TAIL)
2067 && (r_flags & REXEC_SCREAM))))
2072 /* only replace once? */
2073 once = !(rpm->op_pmflags & PMf_GLOBAL);
2075 /* known replacement string? */
2077 /* replacement needing upgrading? */
2078 if (DO_UTF8(TARG) && !doutf8) {
2079 nsv = sv_newmortal();
2082 sv_recode_to_utf8(nsv, PL_encoding);
2084 sv_utf8_upgrade(nsv);
2085 c = SvPV(nsv, clen);
2089 c = SvPV(dstr, clen);
2090 doutf8 = DO_UTF8(dstr);
2098 /* can do inplace substitution? */
2100 #ifdef PERL_COPY_ON_WRITE
2103 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2104 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2105 && (!doutf8 || SvUTF8(TARG))) {
2106 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2107 r_flags | REXEC_CHECKED))
2111 LEAVE_SCOPE(oldsave);
2114 #ifdef PERL_COPY_ON_WRITE
2115 if (SvIsCOW(TARG)) {
2116 assert (!force_on_match);
2120 if (force_on_match) {
2122 s = SvPV_force(TARG, len);
2127 SvSCREAM_off(TARG); /* disable possible screamer */
2129 rxtainted |= RX_MATCH_TAINTED(rx);
2130 m = orig + rx->startp[0];
2131 d = orig + rx->endp[0];
2133 if (m - s > strend - d) { /* faster to shorten from end */
2135 Copy(c, m, clen, char);
2140 Move(d, m, i, char);
2144 SvCUR_set(TARG, m - s);
2147 else if ((i = m - s)) { /* faster from front */
2155 Copy(c, m, clen, char);
2160 Copy(c, d, clen, char);
2165 TAINT_IF(rxtainted & 1);
2171 if (iters++ > maxiters)
2172 DIE(aTHX_ "Substitution loop");
2173 rxtainted |= RX_MATCH_TAINTED(rx);
2174 m = rx->startp[0] + orig;
2178 Move(s, d, i, char);
2182 Copy(c, d, clen, char);
2185 s = rx->endp[0] + orig;
2186 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2188 /* don't match same null twice */
2189 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2192 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2193 Move(s, d, i+1, char); /* include the NUL */
2195 TAINT_IF(rxtainted & 1);
2197 PUSHs(sv_2mortal(newSViv((I32)iters)));
2199 (void)SvPOK_only_UTF8(TARG);
2200 TAINT_IF(rxtainted);
2201 if (SvSMAGICAL(TARG)) {
2209 LEAVE_SCOPE(oldsave);
2213 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2214 r_flags | REXEC_CHECKED))
2216 if (force_on_match) {
2218 s = SvPV_force(TARG, len);
2221 #ifdef PERL_COPY_ON_WRITE
2224 rxtainted |= RX_MATCH_TAINTED(rx);
2225 dstr = NEWSV(25, len);
2226 sv_setpvn(dstr, m, s-m);
2231 register PERL_CONTEXT *cx;
2235 RETURNOP(cPMOP->op_pmreplroot);
2237 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2239 if (iters++ > maxiters)
2240 DIE(aTHX_ "Substitution loop");
2241 rxtainted |= RX_MATCH_TAINTED(rx);
2242 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2247 strend = s + (strend - m);
2249 m = rx->startp[0] + orig;
2250 if (doutf8 && !SvUTF8(dstr))
2251 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2253 sv_catpvn(dstr, s, m-s);
2254 s = rx->endp[0] + orig;
2256 sv_catpvn(dstr, c, clen);
2259 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2260 TARG, NULL, r_flags));
2261 if (doutf8 && !DO_UTF8(TARG))
2262 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2264 sv_catpvn(dstr, s, strend - s);
2266 #ifdef PERL_COPY_ON_WRITE
2267 /* The match may make the string COW. If so, brilliant, because that's
2268 just saved us one malloc, copy and free - the regexp has donated
2269 the old buffer, and we malloc an entirely new one, rather than the
2270 regexp malloc()ing a buffer and copying our original, only for
2271 us to throw it away here during the substitution. */
2272 if (SvIsCOW(TARG)) {
2273 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2279 Safefree(SvPVX(TARG));
2281 SvPVX(TARG) = SvPVX(dstr);
2282 SvCUR_set(TARG, SvCUR(dstr));
2283 SvLEN_set(TARG, SvLEN(dstr));
2284 doutf8 |= DO_UTF8(dstr);
2288 TAINT_IF(rxtainted & 1);
2290 PUSHs(sv_2mortal(newSViv((I32)iters)));
2292 (void)SvPOK_only(TARG);
2295 TAINT_IF(rxtainted);
2298 LEAVE_SCOPE(oldsave);
2307 LEAVE_SCOPE(oldsave);
2316 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2317 ++*PL_markstack_ptr;
2318 LEAVE; /* exit inner scope */
2321 if (PL_stack_base + *PL_markstack_ptr > SP) {
2323 I32 gimme = GIMME_V;
2325 LEAVE; /* exit outer scope */
2326 (void)POPMARK; /* pop src */
2327 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2328 (void)POPMARK; /* pop dst */
2329 SP = PL_stack_base + POPMARK; /* pop original mark */
2330 if (gimme == G_SCALAR) {
2331 if (PL_op->op_private & OPpGREP_LEX) {
2332 SV* sv = sv_newmortal();
2333 sv_setiv(sv, items);
2341 else if (gimme == G_ARRAY)
2348 ENTER; /* enter inner scope */
2351 src = PL_stack_base[*PL_markstack_ptr];
2353 if (PL_op->op_private & OPpGREP_LEX)
2354 PAD_SVl(PL_op->op_targ) = src;
2358 RETURNOP(cLOGOP->op_other);
2369 register PERL_CONTEXT *cx;
2373 cxstack_ix++; /* temporarily protect top context */
2376 if (gimme == G_SCALAR) {
2379 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2381 *MARK = SvREFCNT_inc(TOPs);
2386 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2388 *MARK = sv_mortalcopy(sv);
2393 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2397 *MARK = &PL_sv_undef;
2401 else if (gimme == G_ARRAY) {
2402 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2403 if (!SvTEMP(*MARK)) {
2404 *MARK = sv_mortalcopy(*MARK);
2405 TAINT_NOT; /* Each item is independent */
2413 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2414 PL_curpm = newpm; /* ... and pop $1 et al */
2417 return cx->blk_sub.retop;
2420 /* This duplicates the above code because the above code must not
2421 * get any slower by more conditions */
2429 register PERL_CONTEXT *cx;
2433 cxstack_ix++; /* temporarily protect top context */
2437 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2438 /* We are an argument to a function or grep().
2439 * This kind of lvalueness was legal before lvalue
2440 * subroutines too, so be backward compatible:
2441 * cannot report errors. */
2443 /* Scalar context *is* possible, on the LHS of -> only,
2444 * as in f()->meth(). But this is not an lvalue. */
2445 if (gimme == G_SCALAR)
2447 if (gimme == G_ARRAY) {
2448 if (!CvLVALUE(cx->blk_sub.cv))
2449 goto temporise_array;
2450 EXTEND_MORTAL(SP - newsp);
2451 for (mark = newsp + 1; mark <= SP; mark++) {
2454 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2455 *mark = sv_mortalcopy(*mark);
2457 /* Can be a localized value subject to deletion. */
2458 PL_tmps_stack[++PL_tmps_ix] = *mark;
2459 (void)SvREFCNT_inc(*mark);
2464 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2465 /* Here we go for robustness, not for speed, so we change all
2466 * the refcounts so the caller gets a live guy. Cannot set
2467 * TEMP, so sv_2mortal is out of question. */
2468 if (!CvLVALUE(cx->blk_sub.cv)) {
2474 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2476 if (gimme == G_SCALAR) {
2480 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2486 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2487 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2488 : "a readonly value" : "a temporary");
2490 else { /* Can be a localized value
2491 * subject to deletion. */
2492 PL_tmps_stack[++PL_tmps_ix] = *mark;
2493 (void)SvREFCNT_inc(*mark);
2496 else { /* Should not happen? */
2502 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2503 (MARK > SP ? "Empty array" : "Array"));
2507 else if (gimme == G_ARRAY) {
2508 EXTEND_MORTAL(SP - newsp);
2509 for (mark = newsp + 1; mark <= SP; mark++) {
2510 if (*mark != &PL_sv_undef
2511 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2512 /* Might be flattened array after $#array = */
2519 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2520 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2523 /* Can be a localized value subject to deletion. */
2524 PL_tmps_stack[++PL_tmps_ix] = *mark;
2525 (void)SvREFCNT_inc(*mark);
2531 if (gimme == G_SCALAR) {
2535 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2537 *MARK = SvREFCNT_inc(TOPs);
2542 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2544 *MARK = sv_mortalcopy(sv);
2549 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2553 *MARK = &PL_sv_undef;
2557 else if (gimme == G_ARRAY) {
2559 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2560 if (!SvTEMP(*MARK)) {
2561 *MARK = sv_mortalcopy(*MARK);
2562 TAINT_NOT; /* Each item is independent */
2571 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2572 PL_curpm = newpm; /* ... and pop $1 et al */
2575 return cx->blk_sub.retop;
2580 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2582 SV *dbsv = GvSV(PL_DBsub);
2584 if (!PERLDB_SUB_NN) {
2588 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2589 || strEQ(GvNAME(gv), "END")
2590 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2591 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2592 && (gv = (GV*)*svp) ))) {
2593 /* Use GV from the stack as a fallback. */
2594 /* GV is potentially non-unique, or contain different CV. */
2595 SV *tmp = newRV((SV*)cv);
2596 sv_setsv(dbsv, tmp);
2600 gv_efullname3(dbsv, gv, Nullch);
2604 (void)SvUPGRADE(dbsv, SVt_PVIV);
2605 (void)SvIOK_on(dbsv);
2606 SAVEIV(SvIVX(dbsv));
2607 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2611 PL_curcopdb = PL_curcop;
2612 cv = GvCV(PL_DBsub);
2622 register PERL_CONTEXT *cx;
2624 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2627 DIE(aTHX_ "Not a CODE reference");
2628 switch (SvTYPE(sv)) {
2629 /* This is overwhelming the most common case: */
2631 if (!(cv = GvCVu((GV*)sv)))
2632 cv = sv_2cv(sv, &stash, &gv, FALSE);
2644 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2646 SP = PL_stack_base + POPMARK;
2649 if (SvGMAGICAL(sv)) {
2653 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2656 sym = SvPV(sv, n_a);
2658 DIE(aTHX_ PL_no_usym, "a subroutine");
2659 if (PL_op->op_private & HINT_STRICT_REFS)
2660 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2661 cv = get_cv(sym, TRUE);
2666 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2667 tryAMAGICunDEREF(to_cv);
2670 if (SvTYPE(cv) == SVt_PVCV)
2675 DIE(aTHX_ "Not a CODE reference");
2676 /* This is the second most common case: */
2686 if (!CvROOT(cv) && !CvXSUB(cv)) {
2691 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2692 if (CvASSERTION(cv) && PL_DBassertion)
2693 sv_setiv(PL_DBassertion, 1);
2695 cv = get_db_sub(&sv, cv);
2697 DIE(aTHX_ "No DBsub routine");
2700 if (!(CvXSUB(cv))) {
2701 /* This path taken at least 75% of the time */
2703 register I32 items = SP - MARK;
2704 AV* padlist = CvPADLIST(cv);
2705 PUSHBLOCK(cx, CXt_SUB, MARK);
2707 cx->blk_sub.retop = PL_op->op_next;
2709 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2710 * that eval'' ops within this sub know the correct lexical space.
2711 * Owing the speed considerations, we choose instead to search for
2712 * the cv using find_runcv() when calling doeval().
2714 if (CvDEPTH(cv) >= 2) {
2715 PERL_STACK_OVERFLOW_CHECK();
2716 pad_push(padlist, CvDEPTH(cv), 1);
2718 PAD_SET_CUR(padlist, CvDEPTH(cv));
2725 DEBUG_S(PerlIO_printf(Perl_debug_log,
2726 "%p entersub preparing @_\n", thr));
2728 av = (AV*)PAD_SVl(0);
2730 /* @_ is normally not REAL--this should only ever
2731 * happen when DB::sub() calls things that modify @_ */
2736 cx->blk_sub.savearray = GvAV(PL_defgv);
2737 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2738 CX_CURPAD_SAVE(cx->blk_sub);
2739 cx->blk_sub.argarray = av;
2742 if (items > AvMAX(av) + 1) {
2744 if (AvARRAY(av) != ary) {
2745 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2746 SvPVX(av) = (char*)ary;
2748 if (items > AvMAX(av) + 1) {
2749 AvMAX(av) = items - 1;
2750 Renew(ary,items,SV*);
2752 SvPVX(av) = (char*)ary;
2755 Copy(MARK,AvARRAY(av),items,SV*);
2756 AvFILLp(av) = items - 1;
2764 /* warning must come *after* we fully set up the context
2765 * stuff so that __WARN__ handlers can safely dounwind()
2768 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2769 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2770 sub_crush_depth(cv);
2772 DEBUG_S(PerlIO_printf(Perl_debug_log,
2773 "%p entersub returning %p\n", thr, CvSTART(cv)));
2775 RETURNOP(CvSTART(cv));
2778 #ifdef PERL_XSUB_OLDSTYLE
2779 if (CvOLDSTYLE(cv)) {
2780 I32 (*fp3)(int,int,int);
2782 register I32 items = SP - MARK;
2783 /* We dont worry to copy from @_. */
2788 PL_stack_sp = mark + 1;
2789 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2790 items = (*fp3)(CvXSUBANY(cv).any_i32,
2791 MARK - PL_stack_base + 1,
2793 PL_stack_sp = PL_stack_base + items;
2796 #endif /* PERL_XSUB_OLDSTYLE */
2798 I32 markix = TOPMARK;
2803 /* Need to copy @_ to stack. Alternative may be to
2804 * switch stack to @_, and copy return values
2805 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2808 av = GvAV(PL_defgv);
2809 items = AvFILLp(av) + 1; /* @_ is not tieable */
2812 /* Mark is at the end of the stack. */
2814 Copy(AvARRAY(av), SP + 1, items, SV*);
2819 /* We assume first XSUB in &DB::sub is the called one. */
2821 SAVEVPTR(PL_curcop);
2822 PL_curcop = PL_curcopdb;
2825 /* Do we need to open block here? XXXX */
2826 (void)(*CvXSUB(cv))(aTHX_ cv);
2828 /* Enforce some sanity in scalar context. */
2829 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2830 if (markix > PL_stack_sp - PL_stack_base)
2831 *(PL_stack_base + markix) = &PL_sv_undef;
2833 *(PL_stack_base + markix) = *PL_stack_sp;
2834 PL_stack_sp = PL_stack_base + markix;
2841 assert (0); /* Cannot get here. */
2842 /* This is deliberately moved here as spaghetti code to keep it out of the
2849 /* anonymous or undef'd function leaves us no recourse */
2850 if (CvANON(cv) || !(gv = CvGV(cv)))
2851 DIE(aTHX_ "Undefined subroutine called");
2853 /* autoloaded stub? */
2854 if (cv != GvCV(gv)) {
2857 /* should call AUTOLOAD now? */
2860 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2867 sub_name = sv_newmortal();
2868 gv_efullname3(sub_name, gv, Nullch);
2869 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2873 DIE(aTHX_ "Not a CODE reference");
2879 Perl_sub_crush_depth(pTHX_ CV *cv)
2882 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2884 SV* tmpstr = sv_newmortal();
2885 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2886 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2896 IV elem = SvIV(elemsv);
2898 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2899 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2902 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2903 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2905 elem -= PL_curcop->cop_arybase;
2906 if (SvTYPE(av) != SVt_PVAV)
2908 svp = av_fetch(av, elem, lval && !defer);
2910 #ifdef PERL_MALLOC_WRAP
2911 static const char oom_array_extend[] =
2912 "Out of memory during array extend"; /* Duplicated in av.c */
2913 if (SvUOK(elemsv)) {
2914 UV uv = SvUV(elemsv);
2915 elem = uv > IV_MAX ? IV_MAX : uv;
2917 else if (SvNOK(elemsv))
2918 elem = (IV)SvNV(elemsv);
2920 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2922 if (!svp || *svp == &PL_sv_undef) {
2925 DIE(aTHX_ PL_no_aelem, elem);
2926 lv = sv_newmortal();
2927 sv_upgrade(lv, SVt_PVLV);
2929 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2930 LvTARG(lv) = SvREFCNT_inc(av);
2931 LvTARGOFF(lv) = elem;
2936 if (PL_op->op_private & OPpLVAL_INTRO)
2937 save_aelem(av, elem, svp);
2938 else if (PL_op->op_private & OPpDEREF)
2939 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2941 sv = (svp ? *svp : &PL_sv_undef);
2942 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2943 sv = sv_mortalcopy(sv);
2949 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2955 Perl_croak(aTHX_ PL_no_modify);
2956 if (SvTYPE(sv) < SVt_RV)
2957 sv_upgrade(sv, SVt_RV);
2958 else if (SvTYPE(sv) >= SVt_PV) {
2960 Safefree(SvPVX(sv));
2961 SvLEN(sv) = SvCUR(sv) = 0;
2965 SvRV(sv) = NEWSV(355,0);
2968 SvRV(sv) = (SV*)newAV();
2971 SvRV(sv) = (SV*)newHV();
2986 if (SvTYPE(rsv) == SVt_PVCV) {
2992 SETs(method_common(sv, Null(U32*)));
3000 U32 hash = SvUVX(sv);
3002 XPUSHs(method_common(sv, &hash));
3007 S_method_common(pTHX_ SV* meth, U32* hashp)
3016 SV *packsv = Nullsv;
3019 name = SvPV(meth, namelen);
3020 sv = *(PL_stack_base + TOPMARK + 1);
3023 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3032 /* this isn't a reference */
3035 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3037 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3039 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3046 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3047 !(ob=(SV*)GvIO(iogv)))
3049 /* this isn't the name of a filehandle either */
3051 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3052 ? !isIDFIRST_utf8((U8*)packname)
3053 : !isIDFIRST(*packname)
3056 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3057 SvOK(sv) ? "without a package or object reference"
3058 : "on an undefined value");
3060 /* assume it's a package name */
3061 stash = gv_stashpvn(packname, packlen, FALSE);
3065 SV* ref = newSViv(PTR2IV(stash));
3066 hv_store(PL_stashcache, packname, packlen, ref, 0);
3070 /* it _is_ a filehandle name -- replace with a reference */
3071 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3074 /* if we got here, ob should be a reference or a glob */
3075 if (!ob || !(SvOBJECT(ob)
3076 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3079 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3083 stash = SvSTASH(ob);
3086 /* NOTE: stash may be null, hope hv_fetch_ent and
3087 gv_fetchmethod can cope (it seems they can) */
3089 /* shortcut for simple names */
3091 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3093 gv = (GV*)HeVAL(he);
3094 if (isGV(gv) && GvCV(gv) &&
3095 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3096 return (SV*)GvCV(gv);
3100 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3103 /* This code tries to figure out just what went wrong with
3104 gv_fetchmethod. It therefore needs to duplicate a lot of
3105 the internals of that function. We can't move it inside
3106 Perl_gv_fetchmethod_autoload(), however, since that would
3107 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3114 for (p = name; *p; p++) {
3116 sep = p, leaf = p + 1;
3117 else if (*p == ':' && *(p + 1) == ':')
3118 sep = p, leaf = p + 2;
3120 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3121 /* the method name is unqualified or starts with SUPER:: */
3122 packname = sep ? CopSTASHPV(PL_curcop) :
3123 stash ? HvNAME(stash) : packname;
3126 "Can't use anonymous symbol table for method lookup");
3128 packlen = strlen(packname);
3131 /* the method name is qualified */
3133 packlen = sep - name;
3136 /* we're relying on gv_fetchmethod not autovivifying the stash */
3137 if (gv_stashpvn(packname, packlen, FALSE)) {
3139 "Can't locate object method \"%s\" via package \"%.*s\"",
3140 leaf, (int)packlen, packname);
3144 "Can't locate object method \"%s\" via package \"%.*s\""
3145 " (perhaps you forgot to load \"%.*s\"?)",
3146 leaf, (int)packlen, packname, (int)packlen, packname);
3149 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;