3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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) {
728 if (SvGMAGICAL(sv)) {
734 if (PL_op->op_flags & OPf_REF ||
735 PL_op->op_private & HINT_STRICT_REFS)
736 DIE(aTHX_ PL_no_usym, "an ARRAY");
737 if (ckWARN(WARN_UNINITIALIZED))
739 if (GIMME == G_ARRAY) {
745 if ((PL_op->op_flags & OPf_SPECIAL) &&
746 !(PL_op->op_flags & OPf_MOD))
748 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
750 && (!is_gv_magical_sv(sv,0)
751 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
757 if (PL_op->op_private & HINT_STRICT_REFS)
758 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
759 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
766 if (PL_op->op_private & OPpLVAL_INTRO)
768 if (PL_op->op_flags & OPf_REF) {
773 if (GIMME == G_SCALAR)
774 Perl_croak(aTHX_ "Can't return array to lvalue"
782 if (GIMME == G_ARRAY) {
783 I32 maxarg = AvFILL(av) + 1;
784 (void)POPs; /* XXXX May be optimized away? */
786 if (SvRMAGICAL(av)) {
788 for (i=0; i < (U32)maxarg; i++) {
789 SV **svp = av_fetch(av, i, FALSE);
790 /* See note in pp_helem, and bug id #27839 */
792 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
797 Copy(AvARRAY(av), SP+1, maxarg, SV*);
801 else if (GIMME_V == G_SCALAR) {
803 I32 maxarg = AvFILL(av) + 1;
817 tryAMAGICunDEREF(to_hv);
820 if (SvTYPE(hv) != SVt_PVHV)
821 DIE(aTHX_ "Not a HASH reference");
822 if (PL_op->op_flags & OPf_REF) {
827 if (gimme != G_ARRAY)
828 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
832 else if (PL_op->op_flags & OPf_MOD
833 && PL_op->op_private & OPpLVAL_INTRO)
834 Perl_croak(aTHX_ PL_no_localize_ref);
837 if (SvTYPE(sv) == SVt_PVHV) {
839 if (PL_op->op_flags & OPf_REF) {
844 if (gimme != G_ARRAY)
845 Perl_croak(aTHX_ "Can't return hash to lvalue"
854 if (SvTYPE(sv) != SVt_PVGV) {
855 if (SvGMAGICAL(sv)) {
861 if (PL_op->op_flags & OPf_REF ||
862 PL_op->op_private & HINT_STRICT_REFS)
863 DIE(aTHX_ PL_no_usym, "a HASH");
864 if (ckWARN(WARN_UNINITIALIZED))
866 if (gimme == G_ARRAY) {
872 if ((PL_op->op_flags & OPf_SPECIAL) &&
873 !(PL_op->op_flags & OPf_MOD))
875 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
877 && (!is_gv_magical_sv(sv,0)
878 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
884 if (PL_op->op_private & HINT_STRICT_REFS)
885 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
886 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
893 if (PL_op->op_private & OPpLVAL_INTRO)
895 if (PL_op->op_flags & OPf_REF) {
900 if (gimme != G_ARRAY)
901 Perl_croak(aTHX_ "Can't return hash to lvalue"
909 if (gimme == G_ARRAY) { /* array wanted */
910 *PL_stack_sp = (SV*)hv;
913 else if (gimme == G_SCALAR) {
915 TARG = Perl_hv_scalar(aTHX_ hv);
922 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
928 if (ckWARN(WARN_MISC)) {
929 if (relem == firstrelem &&
931 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
932 SvTYPE(SvRV(*relem)) == SVt_PVHV))
934 Perl_warner(aTHX_ packWARN(WARN_MISC),
935 "Reference found where even-sized list expected");
938 Perl_warner(aTHX_ packWARN(WARN_MISC),
939 "Odd number of elements in hash assignment");
942 tmpstr = NEWSV(29,0);
943 didstore = hv_store_ent(hash,*relem,tmpstr,0);
944 if (SvMAGICAL(hash)) {
945 if (SvSMAGICAL(tmpstr))
957 SV **lastlelem = PL_stack_sp;
958 SV **lastrelem = PL_stack_base + POPMARK;
959 SV **firstrelem = PL_stack_base + POPMARK + 1;
960 SV **firstlelem = lastrelem + 1;
973 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
976 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
979 /* If there's a common identifier on both sides we have to take
980 * special care that assigning the identifier on the left doesn't
981 * clobber a value on the right that's used later in the list.
983 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
984 EXTEND_MORTAL(lastrelem - firstrelem + 1);
985 for (relem = firstrelem; relem <= lastrelem; relem++) {
988 TAINT_NOT; /* Each item is independent */
989 *relem = sv_mortalcopy(sv);
999 while (lelem <= lastlelem) {
1000 TAINT_NOT; /* Each item stands on its own, taintwise. */
1002 switch (SvTYPE(sv)) {
1005 magic = SvMAGICAL(ary) != 0;
1007 av_extend(ary, lastrelem - relem);
1009 while (relem <= lastrelem) { /* gobble up all the rest */
1012 sv = newSVsv(*relem);
1014 didstore = av_store(ary,i++,sv);
1024 case SVt_PVHV: { /* normal hash */
1028 magic = SvMAGICAL(hash) != 0;
1030 firsthashrelem = relem;
1032 while (relem < lastrelem) { /* gobble up all the rest */
1037 sv = &PL_sv_no, relem++;
1038 tmpstr = NEWSV(29,0);
1040 sv_setsv(tmpstr,*relem); /* value */
1041 *(relem++) = tmpstr;
1042 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1043 /* key overwrites an existing entry */
1045 didstore = hv_store_ent(hash,sv,tmpstr,0);
1047 if (SvSMAGICAL(tmpstr))
1054 if (relem == lastrelem) {
1055 do_oddball(hash, relem, firstrelem);
1061 if (SvIMMORTAL(sv)) {
1062 if (relem <= lastrelem)
1066 if (relem <= lastrelem) {
1067 sv_setsv(sv, *relem);
1071 sv_setsv(sv, &PL_sv_undef);
1076 if (PL_delaymagic & ~DM_DELAY) {
1077 if (PL_delaymagic & DM_UID) {
1078 #ifdef HAS_SETRESUID
1079 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1080 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1083 # ifdef HAS_SETREUID
1084 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1085 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1088 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1089 (void)setruid(PL_uid);
1090 PL_delaymagic &= ~DM_RUID;
1092 # endif /* HAS_SETRUID */
1094 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1095 (void)seteuid(PL_euid);
1096 PL_delaymagic &= ~DM_EUID;
1098 # endif /* HAS_SETEUID */
1099 if (PL_delaymagic & DM_UID) {
1100 if (PL_uid != PL_euid)
1101 DIE(aTHX_ "No setreuid available");
1102 (void)PerlProc_setuid(PL_uid);
1104 # endif /* HAS_SETREUID */
1105 #endif /* HAS_SETRESUID */
1106 PL_uid = PerlProc_getuid();
1107 PL_euid = PerlProc_geteuid();
1109 if (PL_delaymagic & DM_GID) {
1110 #ifdef HAS_SETRESGID
1111 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1112 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1115 # ifdef HAS_SETREGID
1116 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1117 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1120 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1121 (void)setrgid(PL_gid);
1122 PL_delaymagic &= ~DM_RGID;
1124 # endif /* HAS_SETRGID */
1126 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1127 (void)setegid(PL_egid);
1128 PL_delaymagic &= ~DM_EGID;
1130 # endif /* HAS_SETEGID */
1131 if (PL_delaymagic & DM_GID) {
1132 if (PL_gid != PL_egid)
1133 DIE(aTHX_ "No setregid available");
1134 (void)PerlProc_setgid(PL_gid);
1136 # endif /* HAS_SETREGID */
1137 #endif /* HAS_SETRESGID */
1138 PL_gid = PerlProc_getgid();
1139 PL_egid = PerlProc_getegid();
1141 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1145 if (gimme == G_VOID)
1146 SP = firstrelem - 1;
1147 else if (gimme == G_SCALAR) {
1150 SETi(lastrelem - firstrelem + 1 - duplicates);
1157 /* Removes from the stack the entries which ended up as
1158 * duplicated keys in the hash (fix for [perl #24380]) */
1159 Move(firsthashrelem + duplicates,
1160 firsthashrelem, duplicates, SV**);
1161 lastrelem -= duplicates;
1166 SP = firstrelem + (lastlelem - firstlelem);
1167 lelem = firstlelem + (relem - firstrelem);
1169 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1177 register PMOP *pm = cPMOP;
1178 SV *rv = sv_newmortal();
1179 SV *sv = newSVrv(rv, "Regexp");
1180 if (pm->op_pmdynflags & PMdf_TAINTED)
1182 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1189 register PMOP *pm = cPMOP;
1195 I32 r_flags = REXEC_CHECKED;
1196 char *truebase; /* Start of string */
1197 register REGEXP *rx = PM_GETRE(pm);
1202 I32 oldsave = PL_savestack_ix;
1203 I32 update_minmatch = 1;
1204 I32 had_zerolen = 0;
1206 if (PL_op->op_flags & OPf_STACKED)
1208 else if (PL_op->op_private & OPpTARGET_MY)
1215 PUTBACK; /* EVAL blocks need stack_sp. */
1216 s = SvPV(TARG, len);
1219 DIE(aTHX_ "panic: pp_match");
1220 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1221 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1224 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1226 /* PMdf_USED is set after a ?? matches once */
1227 if (pm->op_pmdynflags & PMdf_USED) {
1229 if (gimme == G_ARRAY)
1234 /* empty pattern special-cased to use last successful pattern if possible */
1235 if (!rx->prelen && PL_curpm) {
1240 if (rx->minlen > (I32)len)
1245 /* XXXX What part of this is needed with true \G-support? */
1246 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1248 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1249 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1250 if (mg && mg->mg_len >= 0) {
1251 if (!(rx->reganch & ROPT_GPOS_SEEN))
1252 rx->endp[0] = rx->startp[0] = mg->mg_len;
1253 else if (rx->reganch & ROPT_ANCH_GPOS) {
1254 r_flags |= REXEC_IGNOREPOS;
1255 rx->endp[0] = rx->startp[0] = mg->mg_len;
1257 minmatch = (mg->mg_flags & MGf_MINMATCH);
1258 update_minmatch = 0;
1262 if ((!global && rx->nparens)
1263 || SvTEMP(TARG) || PL_sawampersand)
1264 r_flags |= REXEC_COPY_STR;
1266 r_flags |= REXEC_SCREAM;
1269 if (global && rx->startp[0] != -1) {
1270 t = s = rx->endp[0] + truebase;
1271 if ((s + rx->minlen) > strend)
1273 if (update_minmatch++)
1274 minmatch = had_zerolen;
1276 if (rx->reganch & RE_USE_INTUIT &&
1277 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1278 PL_bostr = truebase;
1279 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1283 if ( (rx->reganch & ROPT_CHECK_ALL)
1285 && ((rx->reganch & ROPT_NOSCAN)
1286 || !((rx->reganch & RE_INTUIT_TAIL)
1287 && (r_flags & REXEC_SCREAM)))
1288 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1291 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1294 if (dynpm->op_pmflags & PMf_ONCE)
1295 dynpm->op_pmdynflags |= PMdf_USED;
1304 RX_MATCH_TAINTED_on(rx);
1305 TAINT_IF(RX_MATCH_TAINTED(rx));
1306 if (gimme == G_ARRAY) {
1307 I32 nparens, i, len;
1309 nparens = rx->nparens;
1310 if (global && !nparens)
1314 SPAGAIN; /* EVAL blocks could move the stack. */
1315 EXTEND(SP, nparens + i);
1316 EXTEND_MORTAL(nparens + i);
1317 for (i = !i; i <= nparens; i++) {
1318 PUSHs(sv_newmortal());
1320 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1321 len = rx->endp[i] - rx->startp[i];
1322 s = rx->startp[i] + truebase;
1323 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1324 len < 0 || len > strend - s)
1325 DIE(aTHX_ "panic: pp_match start/end pointers");
1326 sv_setpvn(*SP, s, len);
1327 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1332 if (dynpm->op_pmflags & PMf_CONTINUE) {
1334 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1335 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1337 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1338 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1340 if (rx->startp[0] != -1) {
1341 mg->mg_len = rx->endp[0];
1342 if (rx->startp[0] == rx->endp[0])
1343 mg->mg_flags |= MGf_MINMATCH;
1345 mg->mg_flags &= ~MGf_MINMATCH;
1348 had_zerolen = (rx->startp[0] != -1
1349 && rx->startp[0] == rx->endp[0]);
1350 PUTBACK; /* EVAL blocks may use stack */
1351 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1356 LEAVE_SCOPE(oldsave);
1362 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1363 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1365 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1366 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1368 if (rx->startp[0] != -1) {
1369 mg->mg_len = rx->endp[0];
1370 if (rx->startp[0] == rx->endp[0])
1371 mg->mg_flags |= MGf_MINMATCH;
1373 mg->mg_flags &= ~MGf_MINMATCH;
1376 LEAVE_SCOPE(oldsave);
1380 yup: /* Confirmed by INTUIT */
1382 RX_MATCH_TAINTED_on(rx);
1383 TAINT_IF(RX_MATCH_TAINTED(rx));
1385 if (dynpm->op_pmflags & PMf_ONCE)
1386 dynpm->op_pmdynflags |= PMdf_USED;
1387 if (RX_MATCH_COPIED(rx))
1388 Safefree(rx->subbeg);
1389 RX_MATCH_COPIED_off(rx);
1390 rx->subbeg = Nullch;
1392 rx->subbeg = truebase;
1393 rx->startp[0] = s - truebase;
1394 if (RX_MATCH_UTF8(rx)) {
1395 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1396 rx->endp[0] = t - truebase;
1399 rx->endp[0] = s - truebase + rx->minlen;
1401 rx->sublen = strend - truebase;
1404 if (PL_sawampersand) {
1406 #ifdef PERL_COPY_ON_WRITE
1407 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1409 PerlIO_printf(Perl_debug_log,
1410 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1411 (int) SvTYPE(TARG), truebase, t,
1414 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1415 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1416 assert (SvPOKp(rx->saved_copy));
1421 rx->subbeg = savepvn(t, strend - t);
1422 #ifdef PERL_COPY_ON_WRITE
1423 rx->saved_copy = Nullsv;
1426 rx->sublen = strend - t;
1427 RX_MATCH_COPIED_on(rx);
1428 off = rx->startp[0] = s - t;
1429 rx->endp[0] = off + rx->minlen;
1431 else { /* startp/endp are used by @- @+. */
1432 rx->startp[0] = s - truebase;
1433 rx->endp[0] = s - truebase + rx->minlen;
1435 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1436 LEAVE_SCOPE(oldsave);
1441 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1442 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1443 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1448 LEAVE_SCOPE(oldsave);
1449 if (gimme == G_ARRAY)
1455 Perl_do_readline(pTHX)
1457 dSP; dTARGETSTACKED;
1462 register IO *io = GvIO(PL_last_in_gv);
1463 register I32 type = PL_op->op_type;
1464 I32 gimme = GIMME_V;
1467 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1469 XPUSHs(SvTIED_obj((SV*)io, mg));
1472 call_method("READLINE", gimme);
1475 if (gimme == G_SCALAR) {
1477 SvSetSV_nosteal(TARG, result);
1486 if (IoFLAGS(io) & IOf_ARGV) {
1487 if (IoFLAGS(io) & IOf_START) {
1489 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1490 IoFLAGS(io) &= ~IOf_START;
1491 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1492 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1493 SvSETMAGIC(GvSV(PL_last_in_gv));
1498 fp = nextargv(PL_last_in_gv);
1499 if (!fp) { /* Note: fp != IoIFP(io) */
1500 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1503 else if (type == OP_GLOB)
1504 fp = Perl_start_glob(aTHX_ POPs, io);
1506 else if (type == OP_GLOB)
1508 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1509 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1513 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1514 && (!io || !(IoFLAGS(io) & IOf_START))) {
1515 if (type == OP_GLOB)
1516 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1517 "glob failed (can't start child: %s)",
1520 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1522 if (gimme == G_SCALAR) {
1523 /* undef TARG, and push that undefined value */
1524 if (type != OP_RCATLINE) {
1525 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1533 if (gimme == G_SCALAR) {
1537 (void)SvUPGRADE(sv, SVt_PV);
1538 tmplen = SvLEN(sv); /* remember if already alloced */
1539 if (!tmplen && !SvREADONLY(sv))
1540 Sv_Grow(sv, 80); /* try short-buffering it */
1542 if (type == OP_RCATLINE && SvOK(sv)) {
1545 (void)SvPV_force(sv, n_a);
1551 sv = sv_2mortal(NEWSV(57, 80));
1555 /* This should not be marked tainted if the fp is marked clean */
1556 #define MAYBE_TAINT_LINE(io, sv) \
1557 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1562 /* delay EOF state for a snarfed empty file */
1563 #define SNARF_EOF(gimme,rs,io,sv) \
1564 (gimme != G_SCALAR || SvCUR(sv) \
1565 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1569 if (!sv_gets(sv, fp, offset)
1571 || SNARF_EOF(gimme, PL_rs, io, sv)
1572 || PerlIO_error(fp)))
1574 PerlIO_clearerr(fp);
1575 if (IoFLAGS(io) & IOf_ARGV) {
1576 fp = nextargv(PL_last_in_gv);
1579 (void)do_close(PL_last_in_gv, FALSE);
1581 else if (type == OP_GLOB) {
1582 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1583 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1584 "glob failed (child exited with status %d%s)",
1585 (int)(STATUS_CURRENT >> 8),
1586 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1589 if (gimme == G_SCALAR) {
1590 if (type != OP_RCATLINE) {
1591 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1597 MAYBE_TAINT_LINE(io, sv);
1600 MAYBE_TAINT_LINE(io, sv);
1602 IoFLAGS(io) |= IOf_NOLINE;
1606 if (type == OP_GLOB) {
1609 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1610 tmps = SvEND(sv) - 1;
1611 if (*tmps == *SvPVX(PL_rs)) {
1616 for (tmps = SvPVX(sv); *tmps; tmps++)
1617 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1618 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1620 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1621 (void)POPs; /* Unmatched wildcard? Chuck it... */
1624 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1625 U8 *s = (U8*)SvPVX(sv) + offset;
1626 STRLEN len = SvCUR(sv) - offset;
1629 if (ckWARN(WARN_UTF8) &&
1630 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1631 /* Emulate :encoding(utf8) warning in the same case. */
1632 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1633 "utf8 \"\\x%02X\" does not map to Unicode",
1634 f < (U8*)SvEND(sv) ? *f : 0);
1636 if (gimme == G_ARRAY) {
1637 if (SvLEN(sv) - SvCUR(sv) > 20) {
1638 SvLEN_set(sv, SvCUR(sv)+1);
1639 Renew(SvPVX(sv), SvLEN(sv), char);
1641 sv = sv_2mortal(NEWSV(58, 80));
1644 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1645 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1649 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1650 Renew(SvPVX(sv), SvLEN(sv), char);
1659 register PERL_CONTEXT *cx;
1660 I32 gimme = OP_GIMME(PL_op, -1);
1663 if (cxstack_ix >= 0)
1664 gimme = cxstack[cxstack_ix].blk_gimme;
1672 PUSHBLOCK(cx, CXt_BLOCK, SP);
1684 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1685 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1687 #ifdef PERL_COPY_ON_WRITE
1688 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1690 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1694 if (SvTYPE(hv) == SVt_PVHV) {
1695 if (PL_op->op_private & OPpLVAL_INTRO) {
1698 /* does the element we're localizing already exist? */
1700 /* can we determine whether it exists? */
1702 || mg_find((SV*)hv, PERL_MAGIC_env)
1703 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1704 /* Try to preserve the existenceness of a tied hash
1705 * element by using EXISTS and DELETE if possible.
1706 * Fallback to FETCH and STORE otherwise */
1707 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1708 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1709 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1711 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1714 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1715 svp = he ? &HeVAL(he) : 0;
1721 if (!svp || *svp == &PL_sv_undef) {
1726 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1728 lv = sv_newmortal();
1729 sv_upgrade(lv, SVt_PVLV);
1731 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1732 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1733 LvTARG(lv) = SvREFCNT_inc(hv);
1738 if (PL_op->op_private & OPpLVAL_INTRO) {
1739 if (HvNAME(hv) && isGV(*svp))
1740 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1744 char *key = SvPV(keysv, keylen);
1745 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1747 save_helem(hv, keysv, svp);
1750 else if (PL_op->op_private & OPpDEREF)
1751 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1753 sv = (svp ? *svp : &PL_sv_undef);
1754 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1755 * Pushing the magical RHS on to the stack is useless, since
1756 * that magic is soon destined to be misled by the local(),
1757 * and thus the later pp_sassign() will fail to mg_get() the
1758 * old value. This should also cure problems with delayed
1759 * mg_get()s. GSAR 98-07-03 */
1760 if (!lval && SvGMAGICAL(sv))
1761 sv = sv_mortalcopy(sv);
1769 register PERL_CONTEXT *cx;
1775 if (PL_op->op_flags & OPf_SPECIAL) {
1776 cx = &cxstack[cxstack_ix];
1777 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1782 gimme = OP_GIMME(PL_op, -1);
1784 if (cxstack_ix >= 0)
1785 gimme = cxstack[cxstack_ix].blk_gimme;
1791 if (gimme == G_VOID)
1793 else if (gimme == G_SCALAR) {
1796 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1799 *MARK = sv_mortalcopy(TOPs);
1802 *MARK = &PL_sv_undef;
1806 else if (gimme == G_ARRAY) {
1807 /* in case LEAVE wipes old return values */
1808 for (mark = newsp + 1; mark <= SP; mark++) {
1809 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1810 *mark = sv_mortalcopy(*mark);
1811 TAINT_NOT; /* Each item is independent */
1815 PL_curpm = newpm; /* Don't pop $1 et al till now */
1825 register PERL_CONTEXT *cx;
1831 cx = &cxstack[cxstack_ix];
1832 if (CxTYPE(cx) != CXt_LOOP)
1833 DIE(aTHX_ "panic: pp_iter");
1835 itersvp = CxITERVAR(cx);
1836 av = cx->blk_loop.iterary;
1837 if (SvTYPE(av) != SVt_PVAV) {
1838 /* iterate ($min .. $max) */
1839 if (cx->blk_loop.iterlval) {
1840 /* string increment */
1841 register SV* cur = cx->blk_loop.iterlval;
1843 char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1844 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1845 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1846 /* safe to reuse old SV */
1847 sv_setsv(*itersvp, cur);
1851 /* we need a fresh SV every time so that loop body sees a
1852 * completely new SV for closures/references to work as
1855 *itersvp = newSVsv(cur);
1856 SvREFCNT_dec(oldsv);
1858 if (strEQ(SvPVX(cur), max))
1859 sv_setiv(cur, 0); /* terminate next time */
1866 /* integer increment */
1867 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1870 /* don't risk potential race */
1871 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1872 /* safe to reuse old SV */
1873 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1877 /* we need a fresh SV every time so that loop body sees a
1878 * completely new SV for closures/references to work as they
1881 *itersvp = newSViv(cx->blk_loop.iterix++);
1882 SvREFCNT_dec(oldsv);
1888 if (PL_op->op_private & OPpITER_REVERSED) {
1889 /* In reverse, use itermax as the min :-) */
1890 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1893 if (SvMAGICAL(av) || AvREIFY(av)) {
1894 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1901 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1905 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1909 if (SvMAGICAL(av) || AvREIFY(av)) {
1910 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1917 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1921 if (sv && SvREFCNT(sv) == 0) {
1923 Perl_croak(aTHX_ "Use of freed value in iteration");
1930 if (av != PL_curstack && sv == &PL_sv_undef) {
1931 SV *lv = cx->blk_loop.iterlval;
1932 if (lv && SvREFCNT(lv) > 1) {
1937 SvREFCNT_dec(LvTARG(lv));
1939 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1940 sv_upgrade(lv, SVt_PVLV);
1942 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1944 LvTARG(lv) = SvREFCNT_inc(av);
1945 LvTARGOFF(lv) = cx->blk_loop.iterix;
1946 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1951 *itersvp = SvREFCNT_inc(sv);
1952 SvREFCNT_dec(oldsv);
1960 register PMOP *pm = cPMOP;
1976 register REGEXP *rx = PM_GETRE(pm);
1978 int force_on_match = 0;
1979 I32 oldsave = PL_savestack_ix;
1981 bool doutf8 = FALSE;
1982 #ifdef PERL_COPY_ON_WRITE
1987 /* known replacement string? */
1988 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1989 if (PL_op->op_flags & OPf_STACKED)
1991 else if (PL_op->op_private & OPpTARGET_MY)
1998 #ifdef PERL_COPY_ON_WRITE
1999 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2000 because they make integers such as 256 "false". */
2001 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2004 sv_force_normal_flags(TARG,0);
2007 #ifdef PERL_COPY_ON_WRITE
2011 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2012 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2013 DIE(aTHX_ PL_no_modify);
2016 s = SvPV(TARG, len);
2017 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2019 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2020 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2025 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2029 DIE(aTHX_ "panic: pp_subst");
2032 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2033 maxiters = 2 * slen + 10; /* We can match twice at each
2034 position, once with zero-length,
2035 second time with non-zero. */
2037 if (!rx->prelen && PL_curpm) {
2041 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2042 ? REXEC_COPY_STR : 0;
2044 r_flags |= REXEC_SCREAM;
2047 if (rx->reganch & RE_USE_INTUIT) {
2049 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2053 /* How to do it in subst? */
2054 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2056 && ((rx->reganch & ROPT_NOSCAN)
2057 || !((rx->reganch & RE_INTUIT_TAIL)
2058 && (r_flags & REXEC_SCREAM))))
2063 /* only replace once? */
2064 once = !(rpm->op_pmflags & PMf_GLOBAL);
2066 /* known replacement string? */
2068 /* replacement needing upgrading? */
2069 if (DO_UTF8(TARG) && !doutf8) {
2070 nsv = sv_newmortal();
2073 sv_recode_to_utf8(nsv, PL_encoding);
2075 sv_utf8_upgrade(nsv);
2076 c = SvPV(nsv, clen);
2080 c = SvPV(dstr, clen);
2081 doutf8 = DO_UTF8(dstr);
2089 /* can do inplace substitution? */
2091 #ifdef PERL_COPY_ON_WRITE
2094 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2095 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2096 && (!doutf8 || SvUTF8(TARG))) {
2097 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2098 r_flags | REXEC_CHECKED))
2102 LEAVE_SCOPE(oldsave);
2105 #ifdef PERL_COPY_ON_WRITE
2106 if (SvIsCOW(TARG)) {
2107 assert (!force_on_match);
2111 if (force_on_match) {
2113 s = SvPV_force(TARG, len);
2118 SvSCREAM_off(TARG); /* disable possible screamer */
2120 rxtainted |= RX_MATCH_TAINTED(rx);
2121 m = orig + rx->startp[0];
2122 d = orig + rx->endp[0];
2124 if (m - s > strend - d) { /* faster to shorten from end */
2126 Copy(c, m, clen, char);
2131 Move(d, m, i, char);
2135 SvCUR_set(TARG, m - s);
2138 else if ((i = m - s)) { /* faster from front */
2146 Copy(c, m, clen, char);
2151 Copy(c, d, clen, char);
2156 TAINT_IF(rxtainted & 1);
2162 if (iters++ > maxiters)
2163 DIE(aTHX_ "Substitution loop");
2164 rxtainted |= RX_MATCH_TAINTED(rx);
2165 m = rx->startp[0] + orig;
2169 Move(s, d, i, char);
2173 Copy(c, d, clen, char);
2176 s = rx->endp[0] + orig;
2177 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2179 /* don't match same null twice */
2180 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2183 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2184 Move(s, d, i+1, char); /* include the NUL */
2186 TAINT_IF(rxtainted & 1);
2188 PUSHs(sv_2mortal(newSViv((I32)iters)));
2190 (void)SvPOK_only_UTF8(TARG);
2191 TAINT_IF(rxtainted);
2192 if (SvSMAGICAL(TARG)) {
2200 LEAVE_SCOPE(oldsave);
2204 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2205 r_flags | REXEC_CHECKED))
2207 if (force_on_match) {
2209 s = SvPV_force(TARG, len);
2212 #ifdef PERL_COPY_ON_WRITE
2215 rxtainted |= RX_MATCH_TAINTED(rx);
2216 dstr = newSVpvn(m, s-m);
2221 register PERL_CONTEXT *cx;
2225 RETURNOP(cPMOP->op_pmreplroot);
2227 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2229 if (iters++ > maxiters)
2230 DIE(aTHX_ "Substitution loop");
2231 rxtainted |= RX_MATCH_TAINTED(rx);
2232 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2237 strend = s + (strend - m);
2239 m = rx->startp[0] + orig;
2240 if (doutf8 && !SvUTF8(dstr))
2241 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2243 sv_catpvn(dstr, s, m-s);
2244 s = rx->endp[0] + orig;
2246 sv_catpvn(dstr, c, clen);
2249 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2250 TARG, NULL, r_flags));
2251 if (doutf8 && !DO_UTF8(TARG))
2252 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2254 sv_catpvn(dstr, s, strend - s);
2256 #ifdef PERL_COPY_ON_WRITE
2257 /* The match may make the string COW. If so, brilliant, because that's
2258 just saved us one malloc, copy and free - the regexp has donated
2259 the old buffer, and we malloc an entirely new one, rather than the
2260 regexp malloc()ing a buffer and copying our original, only for
2261 us to throw it away here during the substitution. */
2262 if (SvIsCOW(TARG)) {
2263 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2269 Safefree(SvPVX(TARG));
2271 SvPVX(TARG) = SvPVX(dstr);
2272 SvCUR_set(TARG, SvCUR(dstr));
2273 SvLEN_set(TARG, SvLEN(dstr));
2274 doutf8 |= DO_UTF8(dstr);
2278 TAINT_IF(rxtainted & 1);
2280 PUSHs(sv_2mortal(newSViv((I32)iters)));
2282 (void)SvPOK_only(TARG);
2285 TAINT_IF(rxtainted);
2288 LEAVE_SCOPE(oldsave);
2297 LEAVE_SCOPE(oldsave);
2306 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2307 ++*PL_markstack_ptr;
2308 LEAVE; /* exit inner scope */
2311 if (PL_stack_base + *PL_markstack_ptr > SP) {
2313 I32 gimme = GIMME_V;
2315 LEAVE; /* exit outer scope */
2316 (void)POPMARK; /* pop src */
2317 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2318 (void)POPMARK; /* pop dst */
2319 SP = PL_stack_base + POPMARK; /* pop original mark */
2320 if (gimme == G_SCALAR) {
2321 if (PL_op->op_private & OPpGREP_LEX) {
2322 SV* sv = sv_newmortal();
2323 sv_setiv(sv, items);
2331 else if (gimme == G_ARRAY)
2338 ENTER; /* enter inner scope */
2341 src = PL_stack_base[*PL_markstack_ptr];
2343 if (PL_op->op_private & OPpGREP_LEX)
2344 PAD_SVl(PL_op->op_targ) = src;
2348 RETURNOP(cLOGOP->op_other);
2359 register PERL_CONTEXT *cx;
2363 cxstack_ix++; /* temporarily protect top context */
2366 if (gimme == G_SCALAR) {
2369 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2371 *MARK = SvREFCNT_inc(TOPs);
2376 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2378 *MARK = sv_mortalcopy(sv);
2383 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2387 *MARK = &PL_sv_undef;
2391 else if (gimme == G_ARRAY) {
2392 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2393 if (!SvTEMP(*MARK)) {
2394 *MARK = sv_mortalcopy(*MARK);
2395 TAINT_NOT; /* Each item is independent */
2403 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2404 PL_curpm = newpm; /* ... and pop $1 et al */
2407 return cx->blk_sub.retop;
2410 /* This duplicates the above code because the above code must not
2411 * get any slower by more conditions */
2419 register PERL_CONTEXT *cx;
2423 cxstack_ix++; /* temporarily protect top context */
2427 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2428 /* We are an argument to a function or grep().
2429 * This kind of lvalueness was legal before lvalue
2430 * subroutines too, so be backward compatible:
2431 * cannot report errors. */
2433 /* Scalar context *is* possible, on the LHS of -> only,
2434 * as in f()->meth(). But this is not an lvalue. */
2435 if (gimme == G_SCALAR)
2437 if (gimme == G_ARRAY) {
2438 if (!CvLVALUE(cx->blk_sub.cv))
2439 goto temporise_array;
2440 EXTEND_MORTAL(SP - newsp);
2441 for (mark = newsp + 1; mark <= SP; mark++) {
2444 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2445 *mark = sv_mortalcopy(*mark);
2447 /* Can be a localized value subject to deletion. */
2448 PL_tmps_stack[++PL_tmps_ix] = *mark;
2449 (void)SvREFCNT_inc(*mark);
2454 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2455 /* Here we go for robustness, not for speed, so we change all
2456 * the refcounts so the caller gets a live guy. Cannot set
2457 * TEMP, so sv_2mortal is out of question. */
2458 if (!CvLVALUE(cx->blk_sub.cv)) {
2464 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2466 if (gimme == G_SCALAR) {
2470 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2476 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2477 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2478 : "a readonly value" : "a temporary");
2480 else { /* Can be a localized value
2481 * subject to deletion. */
2482 PL_tmps_stack[++PL_tmps_ix] = *mark;
2483 (void)SvREFCNT_inc(*mark);
2486 else { /* Should not happen? */
2492 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2493 (MARK > SP ? "Empty array" : "Array"));
2497 else if (gimme == G_ARRAY) {
2498 EXTEND_MORTAL(SP - newsp);
2499 for (mark = newsp + 1; mark <= SP; mark++) {
2500 if (*mark != &PL_sv_undef
2501 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2502 /* Might be flattened array after $#array = */
2509 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2510 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2513 /* Can be a localized value subject to deletion. */
2514 PL_tmps_stack[++PL_tmps_ix] = *mark;
2515 (void)SvREFCNT_inc(*mark);
2521 if (gimme == G_SCALAR) {
2525 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2527 *MARK = SvREFCNT_inc(TOPs);
2532 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2534 *MARK = sv_mortalcopy(sv);
2539 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2543 *MARK = &PL_sv_undef;
2547 else if (gimme == G_ARRAY) {
2549 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2550 if (!SvTEMP(*MARK)) {
2551 *MARK = sv_mortalcopy(*MARK);
2552 TAINT_NOT; /* Each item is independent */
2561 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2562 PL_curpm = newpm; /* ... and pop $1 et al */
2565 return cx->blk_sub.retop;
2570 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2572 SV *dbsv = GvSV(PL_DBsub);
2574 if (!PERLDB_SUB_NN) {
2578 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2579 || strEQ(GvNAME(gv), "END")
2580 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2581 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2582 && (gv = (GV*)*svp) ))) {
2583 /* Use GV from the stack as a fallback. */
2584 /* GV is potentially non-unique, or contain different CV. */
2585 SV *tmp = newRV((SV*)cv);
2586 sv_setsv(dbsv, tmp);
2590 gv_efullname3(dbsv, gv, Nullch);
2594 (void)SvUPGRADE(dbsv, SVt_PVIV);
2595 (void)SvIOK_on(dbsv);
2596 SAVEIV(SvIVX(dbsv));
2597 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2601 PL_curcopdb = PL_curcop;
2602 cv = GvCV(PL_DBsub);
2612 register PERL_CONTEXT *cx;
2614 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2617 DIE(aTHX_ "Not a CODE reference");
2618 switch (SvTYPE(sv)) {
2619 /* This is overwhelming the most common case: */
2621 if (!(cv = GvCVu((GV*)sv)))
2622 cv = sv_2cv(sv, &stash, &gv, FALSE);
2634 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2636 SP = PL_stack_base + POPMARK;
2639 if (SvGMAGICAL(sv)) {
2643 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2646 sym = SvPV(sv, n_a);
2648 DIE(aTHX_ PL_no_usym, "a subroutine");
2649 if (PL_op->op_private & HINT_STRICT_REFS)
2650 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2651 cv = get_cv(sym, TRUE);
2656 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2657 tryAMAGICunDEREF(to_cv);
2660 if (SvTYPE(cv) == SVt_PVCV)
2665 DIE(aTHX_ "Not a CODE reference");
2666 /* This is the second most common case: */
2676 if (!CvROOT(cv) && !CvXSUB(cv)) {
2681 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2682 if (CvASSERTION(cv) && PL_DBassertion)
2683 sv_setiv(PL_DBassertion, 1);
2685 cv = get_db_sub(&sv, cv);
2687 DIE(aTHX_ "No DBsub routine");
2690 if (!(CvXSUB(cv))) {
2691 /* This path taken at least 75% of the time */
2693 register I32 items = SP - MARK;
2694 AV* padlist = CvPADLIST(cv);
2695 PUSHBLOCK(cx, CXt_SUB, MARK);
2697 cx->blk_sub.retop = PL_op->op_next;
2699 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2700 * that eval'' ops within this sub know the correct lexical space.
2701 * Owing the speed considerations, we choose instead to search for
2702 * the cv using find_runcv() when calling doeval().
2704 if (CvDEPTH(cv) >= 2) {
2705 PERL_STACK_OVERFLOW_CHECK();
2706 pad_push(padlist, CvDEPTH(cv));
2708 PAD_SET_CUR(padlist, CvDEPTH(cv));
2715 DEBUG_S(PerlIO_printf(Perl_debug_log,
2716 "%p entersub preparing @_\n", thr));
2718 av = (AV*)PAD_SVl(0);
2720 /* @_ is normally not REAL--this should only ever
2721 * happen when DB::sub() calls things that modify @_ */
2726 cx->blk_sub.savearray = GvAV(PL_defgv);
2727 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2728 CX_CURPAD_SAVE(cx->blk_sub);
2729 cx->blk_sub.argarray = av;
2732 if (items > AvMAX(av) + 1) {
2734 if (AvARRAY(av) != ary) {
2735 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2736 SvPVX(av) = (char*)ary;
2738 if (items > AvMAX(av) + 1) {
2739 AvMAX(av) = items - 1;
2740 Renew(ary,items,SV*);
2742 SvPVX(av) = (char*)ary;
2745 Copy(MARK,AvARRAY(av),items,SV*);
2746 AvFILLp(av) = items - 1;
2754 /* warning must come *after* we fully set up the context
2755 * stuff so that __WARN__ handlers can safely dounwind()
2758 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2759 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2760 sub_crush_depth(cv);
2762 DEBUG_S(PerlIO_printf(Perl_debug_log,
2763 "%p entersub returning %p\n", thr, CvSTART(cv)));
2765 RETURNOP(CvSTART(cv));
2768 #ifdef PERL_XSUB_OLDSTYLE
2769 if (CvOLDSTYLE(cv)) {
2770 I32 (*fp3)(int,int,int);
2772 register I32 items = SP - MARK;
2773 /* We dont worry to copy from @_. */
2778 PL_stack_sp = mark + 1;
2779 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2780 items = (*fp3)(CvXSUBANY(cv).any_i32,
2781 MARK - PL_stack_base + 1,
2783 PL_stack_sp = PL_stack_base + items;
2786 #endif /* PERL_XSUB_OLDSTYLE */
2788 I32 markix = TOPMARK;
2793 /* Need to copy @_ to stack. Alternative may be to
2794 * switch stack to @_, and copy return values
2795 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2798 av = GvAV(PL_defgv);
2799 items = AvFILLp(av) + 1; /* @_ is not tieable */
2802 /* Mark is at the end of the stack. */
2804 Copy(AvARRAY(av), SP + 1, items, SV*);
2809 /* We assume first XSUB in &DB::sub is the called one. */
2811 SAVEVPTR(PL_curcop);
2812 PL_curcop = PL_curcopdb;
2815 /* Do we need to open block here? XXXX */
2816 (void)(*CvXSUB(cv))(aTHX_ cv);
2818 /* Enforce some sanity in scalar context. */
2819 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2820 if (markix > PL_stack_sp - PL_stack_base)
2821 *(PL_stack_base + markix) = &PL_sv_undef;
2823 *(PL_stack_base + markix) = *PL_stack_sp;
2824 PL_stack_sp = PL_stack_base + markix;
2831 assert (0); /* Cannot get here. */
2832 /* This is deliberately moved here as spaghetti code to keep it out of the
2839 /* anonymous or undef'd function leaves us no recourse */
2840 if (CvANON(cv) || !(gv = CvGV(cv)))
2841 DIE(aTHX_ "Undefined subroutine called");
2843 /* autoloaded stub? */
2844 if (cv != GvCV(gv)) {
2847 /* should call AUTOLOAD now? */
2850 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2857 sub_name = sv_newmortal();
2858 gv_efullname3(sub_name, gv, Nullch);
2859 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2863 DIE(aTHX_ "Not a CODE reference");
2869 Perl_sub_crush_depth(pTHX_ CV *cv)
2872 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2874 SV* tmpstr = sv_newmortal();
2875 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2876 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2886 IV elem = SvIV(elemsv);
2888 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2889 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2892 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2893 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2895 elem -= PL_curcop->cop_arybase;
2896 if (SvTYPE(av) != SVt_PVAV)
2898 svp = av_fetch(av, elem, lval && !defer);
2900 #ifdef PERL_MALLOC_WRAP
2901 static const char oom_array_extend[] =
2902 "Out of memory during array extend"; /* Duplicated in av.c */
2903 if (SvUOK(elemsv)) {
2904 UV uv = SvUV(elemsv);
2905 elem = uv > IV_MAX ? IV_MAX : uv;
2907 else if (SvNOK(elemsv))
2908 elem = (IV)SvNV(elemsv);
2910 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2912 if (!svp || *svp == &PL_sv_undef) {
2915 DIE(aTHX_ PL_no_aelem, elem);
2916 lv = sv_newmortal();
2917 sv_upgrade(lv, SVt_PVLV);
2919 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2920 LvTARG(lv) = SvREFCNT_inc(av);
2921 LvTARGOFF(lv) = elem;
2926 if (PL_op->op_private & OPpLVAL_INTRO)
2927 save_aelem(av, elem, svp);
2928 else if (PL_op->op_private & OPpDEREF)
2929 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2931 sv = (svp ? *svp : &PL_sv_undef);
2932 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2933 sv = sv_mortalcopy(sv);
2939 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2945 Perl_croak(aTHX_ PL_no_modify);
2946 if (SvTYPE(sv) < SVt_RV)
2947 sv_upgrade(sv, SVt_RV);
2948 else if (SvTYPE(sv) >= SVt_PV) {
2950 Safefree(SvPVX(sv));
2951 SvLEN(sv) = SvCUR(sv) = 0;
2955 SvRV(sv) = NEWSV(355,0);
2958 SvRV(sv) = (SV*)newAV();
2961 SvRV(sv) = (SV*)newHV();
2976 if (SvTYPE(rsv) == SVt_PVCV) {
2982 SETs(method_common(sv, Null(U32*)));
2990 U32 hash = SvUVX(sv);
2992 XPUSHs(method_common(sv, &hash));
2997 S_method_common(pTHX_ SV* meth, U32* hashp)
3006 SV *packsv = Nullsv;
3009 name = SvPV(meth, namelen);
3010 sv = *(PL_stack_base + TOPMARK + 1);
3013 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3022 /* this isn't a reference */
3025 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3027 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3029 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3036 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3037 !(ob=(SV*)GvIO(iogv)))
3039 /* this isn't the name of a filehandle either */
3041 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3042 ? !isIDFIRST_utf8((U8*)packname)
3043 : !isIDFIRST(*packname)
3046 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3047 SvOK(sv) ? "without a package or object reference"
3048 : "on an undefined value");
3050 /* assume it's a package name */
3051 stash = gv_stashpvn(packname, packlen, FALSE);
3055 SV* ref = newSViv(PTR2IV(stash));
3056 hv_store(PL_stashcache, packname, packlen, ref, 0);
3060 /* it _is_ a filehandle name -- replace with a reference */
3061 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3064 /* if we got here, ob should be a reference or a glob */
3065 if (!ob || !(SvOBJECT(ob)
3066 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3069 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3073 stash = SvSTASH(ob);
3076 /* NOTE: stash may be null, hope hv_fetch_ent and
3077 gv_fetchmethod can cope (it seems they can) */
3079 /* shortcut for simple names */
3081 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3083 gv = (GV*)HeVAL(he);
3084 if (isGV(gv) && GvCV(gv) &&
3085 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3086 return (SV*)GvCV(gv);
3090 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3093 /* This code tries to figure out just what went wrong with
3094 gv_fetchmethod. It therefore needs to duplicate a lot of
3095 the internals of that function. We can't move it inside
3096 Perl_gv_fetchmethod_autoload(), however, since that would
3097 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3104 for (p = name; *p; p++) {
3106 sep = p, leaf = p + 1;
3107 else if (*p == ':' && *(p + 1) == ':')
3108 sep = p, leaf = p + 2;
3110 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3111 /* the method name is unqualified or starts with SUPER:: */
3112 packname = sep ? CopSTASHPV(PL_curcop) :
3113 stash ? HvNAME(stash) : packname;
3116 "Can't use anonymous symbol table for method lookup");
3118 packlen = strlen(packname);
3121 /* the method name is qualified */
3123 packlen = sep - name;
3126 /* we're relying on gv_fetchmethod not autovivifying the stash */
3127 if (gv_stashpvn(packname, packlen, FALSE)) {
3129 "Can't locate object method \"%s\" via package \"%.*s\"",
3130 leaf, (int)packlen, packname);
3134 "Can't locate object method \"%s\" via package \"%.*s\""
3135 " (perhaps you forgot to load \"%.*s\"?)",
3136 leaf, (int)packlen, packname, (int)packlen, packname);
3139 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3144 * c-indentation-style: bsd
3146 * indent-tabs-mode: t
3149 * vim: shiftwidth=4: