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;
1277 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1278 SAVEINT(PL_multiline);
1279 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1283 if (global && rx->startp[0] != -1) {
1284 t = s = rx->endp[0] + truebase;
1285 if ((s + rx->minlen) > strend)
1287 if (update_minmatch++)
1288 minmatch = had_zerolen;
1290 if (rx->reganch & RE_USE_INTUIT &&
1291 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1292 PL_bostr = truebase;
1293 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1297 if ( (rx->reganch & ROPT_CHECK_ALL)
1299 && ((rx->reganch & ROPT_NOSCAN)
1300 || !((rx->reganch & RE_INTUIT_TAIL)
1301 && (r_flags & REXEC_SCREAM)))
1302 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1305 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1308 if (dynpm->op_pmflags & PMf_ONCE)
1309 dynpm->op_pmdynflags |= PMdf_USED;
1318 RX_MATCH_TAINTED_on(rx);
1319 TAINT_IF(RX_MATCH_TAINTED(rx));
1320 if (gimme == G_ARRAY) {
1321 I32 nparens, i, len;
1323 nparens = rx->nparens;
1324 if (global && !nparens)
1328 SPAGAIN; /* EVAL blocks could move the stack. */
1329 EXTEND(SP, nparens + i);
1330 EXTEND_MORTAL(nparens + i);
1331 for (i = !i; i <= nparens; i++) {
1332 PUSHs(sv_newmortal());
1334 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1335 len = rx->endp[i] - rx->startp[i];
1336 s = rx->startp[i] + truebase;
1337 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1338 len < 0 || len > strend - s)
1339 DIE(aTHX_ "panic: pp_match start/end pointers");
1340 sv_setpvn(*SP, s, len);
1341 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1346 if (dynpm->op_pmflags & PMf_CONTINUE) {
1348 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1349 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1351 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1352 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1354 if (rx->startp[0] != -1) {
1355 mg->mg_len = rx->endp[0];
1356 if (rx->startp[0] == rx->endp[0])
1357 mg->mg_flags |= MGf_MINMATCH;
1359 mg->mg_flags &= ~MGf_MINMATCH;
1362 had_zerolen = (rx->startp[0] != -1
1363 && rx->startp[0] == rx->endp[0]);
1364 PUTBACK; /* EVAL blocks may use stack */
1365 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1370 LEAVE_SCOPE(oldsave);
1376 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1377 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1379 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1380 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1382 if (rx->startp[0] != -1) {
1383 mg->mg_len = rx->endp[0];
1384 if (rx->startp[0] == rx->endp[0])
1385 mg->mg_flags |= MGf_MINMATCH;
1387 mg->mg_flags &= ~MGf_MINMATCH;
1390 LEAVE_SCOPE(oldsave);
1394 yup: /* Confirmed by INTUIT */
1396 RX_MATCH_TAINTED_on(rx);
1397 TAINT_IF(RX_MATCH_TAINTED(rx));
1399 if (dynpm->op_pmflags & PMf_ONCE)
1400 dynpm->op_pmdynflags |= PMdf_USED;
1401 if (RX_MATCH_COPIED(rx))
1402 Safefree(rx->subbeg);
1403 RX_MATCH_COPIED_off(rx);
1404 rx->subbeg = Nullch;
1406 rx->subbeg = truebase;
1407 rx->startp[0] = s - truebase;
1408 if (RX_MATCH_UTF8(rx)) {
1409 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1410 rx->endp[0] = t - truebase;
1413 rx->endp[0] = s - truebase + rx->minlen;
1415 rx->sublen = strend - truebase;
1418 if (PL_sawampersand) {
1420 #ifdef PERL_COPY_ON_WRITE
1421 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1423 PerlIO_printf(Perl_debug_log,
1424 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1425 (int) SvTYPE(TARG), truebase, t,
1428 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1429 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1430 assert (SvPOKp(rx->saved_copy));
1435 rx->subbeg = savepvn(t, strend - t);
1436 #ifdef PERL_COPY_ON_WRITE
1437 rx->saved_copy = Nullsv;
1440 rx->sublen = strend - t;
1441 RX_MATCH_COPIED_on(rx);
1442 off = rx->startp[0] = s - t;
1443 rx->endp[0] = off + rx->minlen;
1445 else { /* startp/endp are used by @- @+. */
1446 rx->startp[0] = s - truebase;
1447 rx->endp[0] = s - truebase + rx->minlen;
1449 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1450 LEAVE_SCOPE(oldsave);
1455 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1456 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1457 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1462 LEAVE_SCOPE(oldsave);
1463 if (gimme == G_ARRAY)
1469 Perl_do_readline(pTHX)
1471 dSP; dTARGETSTACKED;
1476 register IO *io = GvIO(PL_last_in_gv);
1477 register I32 type = PL_op->op_type;
1478 I32 gimme = GIMME_V;
1481 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1483 XPUSHs(SvTIED_obj((SV*)io, mg));
1486 call_method("READLINE", gimme);
1489 if (gimme == G_SCALAR) {
1491 SvSetSV_nosteal(TARG, result);
1500 if (IoFLAGS(io) & IOf_ARGV) {
1501 if (IoFLAGS(io) & IOf_START) {
1503 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1504 IoFLAGS(io) &= ~IOf_START;
1505 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1506 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1507 SvSETMAGIC(GvSV(PL_last_in_gv));
1512 fp = nextargv(PL_last_in_gv);
1513 if (!fp) { /* Note: fp != IoIFP(io) */
1514 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1517 else if (type == OP_GLOB)
1518 fp = Perl_start_glob(aTHX_ POPs, io);
1520 else if (type == OP_GLOB)
1522 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1523 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1527 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1528 && (!io || !(IoFLAGS(io) & IOf_START))) {
1529 if (type == OP_GLOB)
1530 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1531 "glob failed (can't start child: %s)",
1534 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1536 if (gimme == G_SCALAR) {
1537 /* undef TARG, and push that undefined value */
1538 if (type != OP_RCATLINE) {
1539 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1547 if (gimme == G_SCALAR) {
1551 (void)SvUPGRADE(sv, SVt_PV);
1552 tmplen = SvLEN(sv); /* remember if already alloced */
1553 if (!tmplen && !SvREADONLY(sv))
1554 Sv_Grow(sv, 80); /* try short-buffering it */
1556 if (type == OP_RCATLINE && SvOK(sv)) {
1559 (void)SvPV_force(sv, n_a);
1565 sv = sv_2mortal(NEWSV(57, 80));
1569 /* This should not be marked tainted if the fp is marked clean */
1570 #define MAYBE_TAINT_LINE(io, sv) \
1571 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1576 /* delay EOF state for a snarfed empty file */
1577 #define SNARF_EOF(gimme,rs,io,sv) \
1578 (gimme != G_SCALAR || SvCUR(sv) \
1579 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1583 if (!sv_gets(sv, fp, offset)
1585 || SNARF_EOF(gimme, PL_rs, io, sv)
1586 || PerlIO_error(fp)))
1588 PerlIO_clearerr(fp);
1589 if (IoFLAGS(io) & IOf_ARGV) {
1590 fp = nextargv(PL_last_in_gv);
1593 (void)do_close(PL_last_in_gv, FALSE);
1595 else if (type == OP_GLOB) {
1596 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1597 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1598 "glob failed (child exited with status %d%s)",
1599 (int)(STATUS_CURRENT >> 8),
1600 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1603 if (gimme == G_SCALAR) {
1604 if (type != OP_RCATLINE) {
1605 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1611 MAYBE_TAINT_LINE(io, sv);
1614 MAYBE_TAINT_LINE(io, sv);
1616 IoFLAGS(io) |= IOf_NOLINE;
1620 if (type == OP_GLOB) {
1623 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1624 tmps = SvEND(sv) - 1;
1625 if (*tmps == *SvPVX(PL_rs)) {
1630 for (tmps = SvPVX(sv); *tmps; tmps++)
1631 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1632 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1634 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1635 (void)POPs; /* Unmatched wildcard? Chuck it... */
1638 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1639 U8 *s = (U8*)SvPVX(sv) + offset;
1640 STRLEN len = SvCUR(sv) - offset;
1643 if (ckWARN(WARN_UTF8) &&
1644 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1645 /* Emulate :encoding(utf8) warning in the same case. */
1646 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1647 "utf8 \"\\x%02X\" does not map to Unicode",
1648 f < (U8*)SvEND(sv) ? *f : 0);
1650 if (gimme == G_ARRAY) {
1651 if (SvLEN(sv) - SvCUR(sv) > 20) {
1652 SvLEN_set(sv, SvCUR(sv)+1);
1653 Renew(SvPVX(sv), SvLEN(sv), char);
1655 sv = sv_2mortal(NEWSV(58, 80));
1658 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1659 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1663 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1664 Renew(SvPVX(sv), SvLEN(sv), char);
1673 register PERL_CONTEXT *cx;
1674 I32 gimme = OP_GIMME(PL_op, -1);
1677 if (cxstack_ix >= 0)
1678 gimme = cxstack[cxstack_ix].blk_gimme;
1686 PUSHBLOCK(cx, CXt_BLOCK, SP);
1698 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1699 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1701 #ifdef PERL_COPY_ON_WRITE
1702 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1704 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1708 if (SvTYPE(hv) == SVt_PVHV) {
1709 if (PL_op->op_private & OPpLVAL_INTRO) {
1712 /* does the element we're localizing already exist? */
1714 /* can we determine whether it exists? */
1716 || mg_find((SV*)hv, PERL_MAGIC_env)
1717 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1718 /* Try to preserve the existenceness of a tied hash
1719 * element by using EXISTS and DELETE if possible.
1720 * Fallback to FETCH and STORE otherwise */
1721 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1722 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1723 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1725 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1728 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1729 svp = he ? &HeVAL(he) : 0;
1735 if (!svp || *svp == &PL_sv_undef) {
1740 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1742 lv = sv_newmortal();
1743 sv_upgrade(lv, SVt_PVLV);
1745 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1746 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1747 LvTARG(lv) = SvREFCNT_inc(hv);
1752 if (PL_op->op_private & OPpLVAL_INTRO) {
1753 if (HvNAME(hv) && isGV(*svp))
1754 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1758 char *key = SvPV(keysv, keylen);
1759 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1761 save_helem(hv, keysv, svp);
1764 else if (PL_op->op_private & OPpDEREF)
1765 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1767 sv = (svp ? *svp : &PL_sv_undef);
1768 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1769 * Pushing the magical RHS on to the stack is useless, since
1770 * that magic is soon destined to be misled by the local(),
1771 * and thus the later pp_sassign() will fail to mg_get() the
1772 * old value. This should also cure problems with delayed
1773 * mg_get()s. GSAR 98-07-03 */
1774 if (!lval && SvGMAGICAL(sv))
1775 sv = sv_mortalcopy(sv);
1783 register PERL_CONTEXT *cx;
1789 if (PL_op->op_flags & OPf_SPECIAL) {
1790 cx = &cxstack[cxstack_ix];
1791 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1796 gimme = OP_GIMME(PL_op, -1);
1798 if (cxstack_ix >= 0)
1799 gimme = cxstack[cxstack_ix].blk_gimme;
1805 if (gimme == G_VOID)
1807 else if (gimme == G_SCALAR) {
1810 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1813 *MARK = sv_mortalcopy(TOPs);
1816 *MARK = &PL_sv_undef;
1820 else if (gimme == G_ARRAY) {
1821 /* in case LEAVE wipes old return values */
1822 for (mark = newsp + 1; mark <= SP; mark++) {
1823 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1824 *mark = sv_mortalcopy(*mark);
1825 TAINT_NOT; /* Each item is independent */
1829 PL_curpm = newpm; /* Don't pop $1 et al till now */
1839 register PERL_CONTEXT *cx;
1845 cx = &cxstack[cxstack_ix];
1846 if (CxTYPE(cx) != CXt_LOOP)
1847 DIE(aTHX_ "panic: pp_iter");
1849 itersvp = CxITERVAR(cx);
1850 av = cx->blk_loop.iterary;
1851 if (SvTYPE(av) != SVt_PVAV) {
1852 /* iterate ($min .. $max) */
1853 if (cx->blk_loop.iterlval) {
1854 /* string increment */
1855 register SV* cur = cx->blk_loop.iterlval;
1857 char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1858 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1859 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1860 /* safe to reuse old SV */
1861 sv_setsv(*itersvp, cur);
1865 /* we need a fresh SV every time so that loop body sees a
1866 * completely new SV for closures/references to work as
1869 *itersvp = newSVsv(cur);
1870 SvREFCNT_dec(oldsv);
1872 if (strEQ(SvPVX(cur), max))
1873 sv_setiv(cur, 0); /* terminate next time */
1880 /* integer increment */
1881 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1884 /* don't risk potential race */
1885 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1886 /* safe to reuse old SV */
1887 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1891 /* we need a fresh SV every time so that loop body sees a
1892 * completely new SV for closures/references to work as they
1895 *itersvp = newSViv(cx->blk_loop.iterix++);
1896 SvREFCNT_dec(oldsv);
1902 if (PL_op->op_private & OPpITER_REVERSED) {
1903 /* In reverse, use itermax as the min :-) */
1904 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1907 if (SvMAGICAL(av) || AvREIFY(av)) {
1908 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1915 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1919 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1923 if (SvMAGICAL(av) || AvREIFY(av)) {
1924 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1931 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1935 if (sv && SvREFCNT(sv) == 0) {
1937 Perl_croak(aTHX_ "Use of freed value in iteration");
1944 if (av != PL_curstack && sv == &PL_sv_undef) {
1945 SV *lv = cx->blk_loop.iterlval;
1946 if (lv && SvREFCNT(lv) > 1) {
1951 SvREFCNT_dec(LvTARG(lv));
1953 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1954 sv_upgrade(lv, SVt_PVLV);
1956 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1958 LvTARG(lv) = SvREFCNT_inc(av);
1959 LvTARGOFF(lv) = cx->blk_loop.iterix;
1960 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1965 *itersvp = SvREFCNT_inc(sv);
1966 SvREFCNT_dec(oldsv);
1974 register PMOP *pm = cPMOP;
1990 register REGEXP *rx = PM_GETRE(pm);
1992 int force_on_match = 0;
1993 I32 oldsave = PL_savestack_ix;
1995 bool doutf8 = FALSE;
1996 #ifdef PERL_COPY_ON_WRITE
2001 /* known replacement string? */
2002 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
2003 if (PL_op->op_flags & OPf_STACKED)
2005 else if (PL_op->op_private & OPpTARGET_MY)
2012 #ifdef PERL_COPY_ON_WRITE
2013 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2014 because they make integers such as 256 "false". */
2015 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2018 sv_force_normal_flags(TARG,0);
2021 #ifdef PERL_COPY_ON_WRITE
2025 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2026 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2027 DIE(aTHX_ PL_no_modify);
2030 s = SvPV(TARG, len);
2031 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2033 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2034 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2039 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2043 DIE(aTHX_ "panic: pp_subst");
2046 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2047 maxiters = 2 * slen + 10; /* We can match twice at each
2048 position, once with zero-length,
2049 second time with non-zero. */
2051 if (!rx->prelen && PL_curpm) {
2055 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2056 ? REXEC_COPY_STR : 0;
2058 r_flags |= REXEC_SCREAM;
2059 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
2060 SAVEINT(PL_multiline);
2061 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2064 if (rx->reganch & RE_USE_INTUIT) {
2066 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2070 /* How to do it in subst? */
2071 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2073 && ((rx->reganch & ROPT_NOSCAN)
2074 || !((rx->reganch & RE_INTUIT_TAIL)
2075 && (r_flags & REXEC_SCREAM))))
2080 /* only replace once? */
2081 once = !(rpm->op_pmflags & PMf_GLOBAL);
2083 /* known replacement string? */
2085 /* replacement needing upgrading? */
2086 if (DO_UTF8(TARG) && !doutf8) {
2087 nsv = sv_newmortal();
2090 sv_recode_to_utf8(nsv, PL_encoding);
2092 sv_utf8_upgrade(nsv);
2093 c = SvPV(nsv, clen);
2097 c = SvPV(dstr, clen);
2098 doutf8 = DO_UTF8(dstr);
2106 /* can do inplace substitution? */
2108 #ifdef PERL_COPY_ON_WRITE
2111 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2112 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2113 && (!doutf8 || SvUTF8(TARG))) {
2114 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2115 r_flags | REXEC_CHECKED))
2119 LEAVE_SCOPE(oldsave);
2122 #ifdef PERL_COPY_ON_WRITE
2123 if (SvIsCOW(TARG)) {
2124 assert (!force_on_match);
2128 if (force_on_match) {
2130 s = SvPV_force(TARG, len);
2135 SvSCREAM_off(TARG); /* disable possible screamer */
2137 rxtainted |= RX_MATCH_TAINTED(rx);
2138 m = orig + rx->startp[0];
2139 d = orig + rx->endp[0];
2141 if (m - s > strend - d) { /* faster to shorten from end */
2143 Copy(c, m, clen, char);
2148 Move(d, m, i, char);
2152 SvCUR_set(TARG, m - s);
2155 else if ((i = m - s)) { /* faster from front */
2163 Copy(c, m, clen, char);
2168 Copy(c, d, clen, char);
2173 TAINT_IF(rxtainted & 1);
2179 if (iters++ > maxiters)
2180 DIE(aTHX_ "Substitution loop");
2181 rxtainted |= RX_MATCH_TAINTED(rx);
2182 m = rx->startp[0] + orig;
2186 Move(s, d, i, char);
2190 Copy(c, d, clen, char);
2193 s = rx->endp[0] + orig;
2194 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2196 /* don't match same null twice */
2197 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2200 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2201 Move(s, d, i+1, char); /* include the NUL */
2203 TAINT_IF(rxtainted & 1);
2205 PUSHs(sv_2mortal(newSViv((I32)iters)));
2207 (void)SvPOK_only_UTF8(TARG);
2208 TAINT_IF(rxtainted);
2209 if (SvSMAGICAL(TARG)) {
2217 LEAVE_SCOPE(oldsave);
2221 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2222 r_flags | REXEC_CHECKED))
2224 if (force_on_match) {
2226 s = SvPV_force(TARG, len);
2229 #ifdef PERL_COPY_ON_WRITE
2232 rxtainted |= RX_MATCH_TAINTED(rx);
2233 dstr = NEWSV(25, len);
2234 sv_setpvn(dstr, m, s-m);
2239 register PERL_CONTEXT *cx;
2243 RETURNOP(cPMOP->op_pmreplroot);
2245 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2247 if (iters++ > maxiters)
2248 DIE(aTHX_ "Substitution loop");
2249 rxtainted |= RX_MATCH_TAINTED(rx);
2250 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2255 strend = s + (strend - m);
2257 m = rx->startp[0] + orig;
2258 if (doutf8 && !SvUTF8(dstr))
2259 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2261 sv_catpvn(dstr, s, m-s);
2262 s = rx->endp[0] + orig;
2264 sv_catpvn(dstr, c, clen);
2267 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2268 TARG, NULL, r_flags));
2269 if (doutf8 && !DO_UTF8(TARG))
2270 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2272 sv_catpvn(dstr, s, strend - s);
2274 #ifdef PERL_COPY_ON_WRITE
2275 /* The match may make the string COW. If so, brilliant, because that's
2276 just saved us one malloc, copy and free - the regexp has donated
2277 the old buffer, and we malloc an entirely new one, rather than the
2278 regexp malloc()ing a buffer and copying our original, only for
2279 us to throw it away here during the substitution. */
2280 if (SvIsCOW(TARG)) {
2281 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2287 Safefree(SvPVX(TARG));
2289 SvPVX(TARG) = SvPVX(dstr);
2290 SvCUR_set(TARG, SvCUR(dstr));
2291 SvLEN_set(TARG, SvLEN(dstr));
2292 doutf8 |= DO_UTF8(dstr);
2296 TAINT_IF(rxtainted & 1);
2298 PUSHs(sv_2mortal(newSViv((I32)iters)));
2300 (void)SvPOK_only(TARG);
2303 TAINT_IF(rxtainted);
2306 LEAVE_SCOPE(oldsave);
2315 LEAVE_SCOPE(oldsave);
2324 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2325 ++*PL_markstack_ptr;
2326 LEAVE; /* exit inner scope */
2329 if (PL_stack_base + *PL_markstack_ptr > SP) {
2331 I32 gimme = GIMME_V;
2333 LEAVE; /* exit outer scope */
2334 (void)POPMARK; /* pop src */
2335 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2336 (void)POPMARK; /* pop dst */
2337 SP = PL_stack_base + POPMARK; /* pop original mark */
2338 if (gimme == G_SCALAR) {
2339 if (PL_op->op_private & OPpGREP_LEX) {
2340 SV* sv = sv_newmortal();
2341 sv_setiv(sv, items);
2349 else if (gimme == G_ARRAY)
2356 ENTER; /* enter inner scope */
2359 src = PL_stack_base[*PL_markstack_ptr];
2361 if (PL_op->op_private & OPpGREP_LEX)
2362 PAD_SVl(PL_op->op_targ) = src;
2366 RETURNOP(cLOGOP->op_other);
2377 register PERL_CONTEXT *cx;
2381 cxstack_ix++; /* temporarily protect top context */
2384 if (gimme == G_SCALAR) {
2387 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2389 *MARK = SvREFCNT_inc(TOPs);
2394 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2396 *MARK = sv_mortalcopy(sv);
2401 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2405 *MARK = &PL_sv_undef;
2409 else if (gimme == G_ARRAY) {
2410 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2411 if (!SvTEMP(*MARK)) {
2412 *MARK = sv_mortalcopy(*MARK);
2413 TAINT_NOT; /* Each item is independent */
2421 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2422 PL_curpm = newpm; /* ... and pop $1 et al */
2425 return cx->blk_sub.retop;
2428 /* This duplicates the above code because the above code must not
2429 * get any slower by more conditions */
2437 register PERL_CONTEXT *cx;
2441 cxstack_ix++; /* temporarily protect top context */
2445 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2446 /* We are an argument to a function or grep().
2447 * This kind of lvalueness was legal before lvalue
2448 * subroutines too, so be backward compatible:
2449 * cannot report errors. */
2451 /* Scalar context *is* possible, on the LHS of -> only,
2452 * as in f()->meth(). But this is not an lvalue. */
2453 if (gimme == G_SCALAR)
2455 if (gimme == G_ARRAY) {
2456 if (!CvLVALUE(cx->blk_sub.cv))
2457 goto temporise_array;
2458 EXTEND_MORTAL(SP - newsp);
2459 for (mark = newsp + 1; mark <= SP; mark++) {
2462 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2463 *mark = sv_mortalcopy(*mark);
2465 /* Can be a localized value subject to deletion. */
2466 PL_tmps_stack[++PL_tmps_ix] = *mark;
2467 (void)SvREFCNT_inc(*mark);
2472 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2473 /* Here we go for robustness, not for speed, so we change all
2474 * the refcounts so the caller gets a live guy. Cannot set
2475 * TEMP, so sv_2mortal is out of question. */
2476 if (!CvLVALUE(cx->blk_sub.cv)) {
2482 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2484 if (gimme == G_SCALAR) {
2488 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2494 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2495 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2496 : "a readonly value" : "a temporary");
2498 else { /* Can be a localized value
2499 * subject to deletion. */
2500 PL_tmps_stack[++PL_tmps_ix] = *mark;
2501 (void)SvREFCNT_inc(*mark);
2504 else { /* Should not happen? */
2510 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2511 (MARK > SP ? "Empty array" : "Array"));
2515 else if (gimme == G_ARRAY) {
2516 EXTEND_MORTAL(SP - newsp);
2517 for (mark = newsp + 1; mark <= SP; mark++) {
2518 if (*mark != &PL_sv_undef
2519 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2520 /* Might be flattened array after $#array = */
2527 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2528 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2531 /* Can be a localized value subject to deletion. */
2532 PL_tmps_stack[++PL_tmps_ix] = *mark;
2533 (void)SvREFCNT_inc(*mark);
2539 if (gimme == G_SCALAR) {
2543 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2545 *MARK = SvREFCNT_inc(TOPs);
2550 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2552 *MARK = sv_mortalcopy(sv);
2557 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2561 *MARK = &PL_sv_undef;
2565 else if (gimme == G_ARRAY) {
2567 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2568 if (!SvTEMP(*MARK)) {
2569 *MARK = sv_mortalcopy(*MARK);
2570 TAINT_NOT; /* Each item is independent */
2579 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2580 PL_curpm = newpm; /* ... and pop $1 et al */
2583 return cx->blk_sub.retop;
2588 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2590 SV *dbsv = GvSV(PL_DBsub);
2592 if (!PERLDB_SUB_NN) {
2596 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2597 || strEQ(GvNAME(gv), "END")
2598 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2599 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2600 && (gv = (GV*)*svp) ))) {
2601 /* Use GV from the stack as a fallback. */
2602 /* GV is potentially non-unique, or contain different CV. */
2603 SV *tmp = newRV((SV*)cv);
2604 sv_setsv(dbsv, tmp);
2608 gv_efullname3(dbsv, gv, Nullch);
2612 (void)SvUPGRADE(dbsv, SVt_PVIV);
2613 (void)SvIOK_on(dbsv);
2614 SAVEIV(SvIVX(dbsv));
2615 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2619 PL_curcopdb = PL_curcop;
2620 cv = GvCV(PL_DBsub);
2630 register PERL_CONTEXT *cx;
2632 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2635 DIE(aTHX_ "Not a CODE reference");
2636 switch (SvTYPE(sv)) {
2637 /* This is overwhelming the most common case: */
2639 if (!(cv = GvCVu((GV*)sv)))
2640 cv = sv_2cv(sv, &stash, &gv, FALSE);
2652 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2654 SP = PL_stack_base + POPMARK;
2657 if (SvGMAGICAL(sv)) {
2661 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2664 sym = SvPV(sv, n_a);
2666 DIE(aTHX_ PL_no_usym, "a subroutine");
2667 if (PL_op->op_private & HINT_STRICT_REFS)
2668 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2669 cv = get_cv(sym, TRUE);
2674 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2675 tryAMAGICunDEREF(to_cv);
2678 if (SvTYPE(cv) == SVt_PVCV)
2683 DIE(aTHX_ "Not a CODE reference");
2684 /* This is the second most common case: */
2694 if (!CvROOT(cv) && !CvXSUB(cv)) {
2699 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2700 if (CvASSERTION(cv) && PL_DBassertion)
2701 sv_setiv(PL_DBassertion, 1);
2703 cv = get_db_sub(&sv, cv);
2705 DIE(aTHX_ "No DBsub routine");
2708 if (!(CvXSUB(cv))) {
2709 /* This path taken at least 75% of the time */
2711 register I32 items = SP - MARK;
2712 AV* padlist = CvPADLIST(cv);
2713 PUSHBLOCK(cx, CXt_SUB, MARK);
2715 cx->blk_sub.retop = PL_op->op_next;
2717 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2718 * that eval'' ops within this sub know the correct lexical space.
2719 * Owing the speed considerations, we choose instead to search for
2720 * the cv using find_runcv() when calling doeval().
2722 if (CvDEPTH(cv) >= 2) {
2723 PERL_STACK_OVERFLOW_CHECK();
2724 pad_push(padlist, CvDEPTH(cv), 1);
2726 PAD_SET_CUR(padlist, CvDEPTH(cv));
2733 DEBUG_S(PerlIO_printf(Perl_debug_log,
2734 "%p entersub preparing @_\n", thr));
2736 av = (AV*)PAD_SVl(0);
2738 /* @_ is normally not REAL--this should only ever
2739 * happen when DB::sub() calls things that modify @_ */
2744 cx->blk_sub.savearray = GvAV(PL_defgv);
2745 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2746 CX_CURPAD_SAVE(cx->blk_sub);
2747 cx->blk_sub.argarray = av;
2750 if (items > AvMAX(av) + 1) {
2752 if (AvARRAY(av) != ary) {
2753 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2754 SvPVX(av) = (char*)ary;
2756 if (items > AvMAX(av) + 1) {
2757 AvMAX(av) = items - 1;
2758 Renew(ary,items,SV*);
2760 SvPVX(av) = (char*)ary;
2763 Copy(MARK,AvARRAY(av),items,SV*);
2764 AvFILLp(av) = items - 1;
2772 /* warning must come *after* we fully set up the context
2773 * stuff so that __WARN__ handlers can safely dounwind()
2776 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2777 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2778 sub_crush_depth(cv);
2780 DEBUG_S(PerlIO_printf(Perl_debug_log,
2781 "%p entersub returning %p\n", thr, CvSTART(cv)));
2783 RETURNOP(CvSTART(cv));
2786 #ifdef PERL_XSUB_OLDSTYLE
2787 if (CvOLDSTYLE(cv)) {
2788 I32 (*fp3)(int,int,int);
2790 register I32 items = SP - MARK;
2791 /* We dont worry to copy from @_. */
2796 PL_stack_sp = mark + 1;
2797 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2798 items = (*fp3)(CvXSUBANY(cv).any_i32,
2799 MARK - PL_stack_base + 1,
2801 PL_stack_sp = PL_stack_base + items;
2804 #endif /* PERL_XSUB_OLDSTYLE */
2806 I32 markix = TOPMARK;
2811 /* Need to copy @_ to stack. Alternative may be to
2812 * switch stack to @_, and copy return values
2813 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2816 av = GvAV(PL_defgv);
2817 items = AvFILLp(av) + 1; /* @_ is not tieable */
2820 /* Mark is at the end of the stack. */
2822 Copy(AvARRAY(av), SP + 1, items, SV*);
2827 /* We assume first XSUB in &DB::sub is the called one. */
2829 SAVEVPTR(PL_curcop);
2830 PL_curcop = PL_curcopdb;
2833 /* Do we need to open block here? XXXX */
2834 (void)(*CvXSUB(cv))(aTHX_ cv);
2836 /* Enforce some sanity in scalar context. */
2837 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2838 if (markix > PL_stack_sp - PL_stack_base)
2839 *(PL_stack_base + markix) = &PL_sv_undef;
2841 *(PL_stack_base + markix) = *PL_stack_sp;
2842 PL_stack_sp = PL_stack_base + markix;
2849 assert (0); /* Cannot get here. */
2850 /* This is deliberately moved here as spaghetti code to keep it out of the
2857 /* anonymous or undef'd function leaves us no recourse */
2858 if (CvANON(cv) || !(gv = CvGV(cv)))
2859 DIE(aTHX_ "Undefined subroutine called");
2861 /* autoloaded stub? */
2862 if (cv != GvCV(gv)) {
2865 /* should call AUTOLOAD now? */
2868 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2875 sub_name = sv_newmortal();
2876 gv_efullname3(sub_name, gv, Nullch);
2877 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2881 DIE(aTHX_ "Not a CODE reference");
2887 Perl_sub_crush_depth(pTHX_ CV *cv)
2890 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2892 SV* tmpstr = sv_newmortal();
2893 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2894 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2904 IV elem = SvIV(elemsv);
2906 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2907 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2910 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2911 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2913 elem -= PL_curcop->cop_arybase;
2914 if (SvTYPE(av) != SVt_PVAV)
2916 svp = av_fetch(av, elem, lval && !defer);
2918 #ifdef PERL_MALLOC_WRAP
2919 static const char oom_array_extend[] =
2920 "Out of memory during array extend"; /* Duplicated in av.c */
2921 if (SvUOK(elemsv)) {
2922 UV uv = SvUV(elemsv);
2923 elem = uv > IV_MAX ? IV_MAX : uv;
2925 else if (SvNOK(elemsv))
2926 elem = (IV)SvNV(elemsv);
2928 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2930 if (!svp || *svp == &PL_sv_undef) {
2933 DIE(aTHX_ PL_no_aelem, elem);
2934 lv = sv_newmortal();
2935 sv_upgrade(lv, SVt_PVLV);
2937 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2938 LvTARG(lv) = SvREFCNT_inc(av);
2939 LvTARGOFF(lv) = elem;
2944 if (PL_op->op_private & OPpLVAL_INTRO)
2945 save_aelem(av, elem, svp);
2946 else if (PL_op->op_private & OPpDEREF)
2947 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2949 sv = (svp ? *svp : &PL_sv_undef);
2950 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2951 sv = sv_mortalcopy(sv);
2957 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2963 Perl_croak(aTHX_ PL_no_modify);
2964 if (SvTYPE(sv) < SVt_RV)
2965 sv_upgrade(sv, SVt_RV);
2966 else if (SvTYPE(sv) >= SVt_PV) {
2968 Safefree(SvPVX(sv));
2969 SvLEN(sv) = SvCUR(sv) = 0;
2973 SvRV(sv) = NEWSV(355,0);
2976 SvRV(sv) = (SV*)newAV();
2979 SvRV(sv) = (SV*)newHV();
2994 if (SvTYPE(rsv) == SVt_PVCV) {
3000 SETs(method_common(sv, Null(U32*)));
3008 U32 hash = SvUVX(sv);
3010 XPUSHs(method_common(sv, &hash));
3015 S_method_common(pTHX_ SV* meth, U32* hashp)
3024 SV *packsv = Nullsv;
3027 name = SvPV(meth, namelen);
3028 sv = *(PL_stack_base + TOPMARK + 1);
3031 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3040 /* this isn't a reference */
3043 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3045 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3047 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3054 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3055 !(ob=(SV*)GvIO(iogv)))
3057 /* this isn't the name of a filehandle either */
3059 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3060 ? !isIDFIRST_utf8((U8*)packname)
3061 : !isIDFIRST(*packname)
3064 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3065 SvOK(sv) ? "without a package or object reference"
3066 : "on an undefined value");
3068 /* assume it's a package name */
3069 stash = gv_stashpvn(packname, packlen, FALSE);
3073 SV* ref = newSViv(PTR2IV(stash));
3074 hv_store(PL_stashcache, packname, packlen, ref, 0);
3078 /* it _is_ a filehandle name -- replace with a reference */
3079 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3082 /* if we got here, ob should be a reference or a glob */
3083 if (!ob || !(SvOBJECT(ob)
3084 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3087 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3091 stash = SvSTASH(ob);
3094 /* NOTE: stash may be null, hope hv_fetch_ent and
3095 gv_fetchmethod can cope (it seems they can) */
3097 /* shortcut for simple names */
3099 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3101 gv = (GV*)HeVAL(he);
3102 if (isGV(gv) && GvCV(gv) &&
3103 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3104 return (SV*)GvCV(gv);
3108 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3111 /* This code tries to figure out just what went wrong with
3112 gv_fetchmethod. It therefore needs to duplicate a lot of
3113 the internals of that function. We can't move it inside
3114 Perl_gv_fetchmethod_autoload(), however, since that would
3115 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3122 for (p = name; *p; p++) {
3124 sep = p, leaf = p + 1;
3125 else if (*p == ':' && *(p + 1) == ':')
3126 sep = p, leaf = p + 2;
3128 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3129 /* the method name is unqualified or starts with SUPER:: */
3130 packname = sep ? CopSTASHPV(PL_curcop) :
3131 stash ? HvNAME(stash) : packname;
3134 "Can't use anonymous symbol table for method lookup");
3136 packlen = strlen(packname);
3139 /* the method name is qualified */
3141 packlen = sep - name;
3144 /* we're relying on gv_fetchmethod not autovivifying the stash */
3145 if (gv_stashpvn(packname, packlen, FALSE)) {
3147 "Can't locate object method \"%s\" via package \"%.*s\"",
3148 leaf, (int)packlen, packname);
3152 "Can't locate object method \"%s\" via package \"%.*s\""
3153 " (perhaps you forgot to load \"%.*s\"?)",
3154 leaf, (int)packlen, packname, (int)packlen, packname);
3157 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;