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(GvSVn(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);
150 const char *rpv = SvPV_const(right, rlen); /* mg_get(right) happens here */
151 const bool rbyte = !DO_UTF8(right);
152 bool rcopied = FALSE;
154 if (TARG == right && right != left) {
155 right = sv_2mortal(newSVpvn(rpv, rlen));
156 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
162 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
163 lbyte = !DO_UTF8(left);
164 sv_setpvn(TARG, lpv, llen);
170 else { /* TARG == left */
172 SvGETMAGIC(left); /* or mg_get(left) may happen here */
174 sv_setpvn(left, "", 0);
175 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
176 lbyte = !DO_UTF8(left);
181 if (lbyte != rbyte) {
183 sv_utf8_upgrade_nomg(TARG);
186 right = sv_2mortal(newSVpvn(rpv, rlen));
187 sv_utf8_upgrade_nomg(right);
188 rpv = SvPV_const(right, rlen);
191 sv_catpvn_nomg(TARG, rpv, rlen);
202 if (PL_op->op_flags & OPf_MOD) {
203 if (PL_op->op_private & OPpLVAL_INTRO)
204 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
205 if (PL_op->op_private & OPpDEREF) {
207 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
216 tryAMAGICunTARGET(iter, 0);
217 PL_last_in_gv = (GV*)(*PL_stack_sp--);
218 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
219 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
220 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
223 XPUSHs((SV*)PL_last_in_gv);
226 PL_last_in_gv = (GV*)(*PL_stack_sp--);
229 return do_readline();
234 dSP; tryAMAGICbinSET(eq,0);
235 #ifndef NV_PRESERVES_UV
236 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
238 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
242 #ifdef PERL_PRESERVE_IVUV
245 /* Unless the left argument is integer in range we are going
246 to have to use NV maths. Hence only attempt to coerce the
247 right argument if we know the left is integer. */
250 bool auvok = SvUOK(TOPm1s);
251 bool buvok = SvUOK(TOPs);
253 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
254 /* Casting IV to UV before comparison isn't going to matter
255 on 2s complement. On 1s complement or sign&magnitude
256 (if we have any of them) it could to make negative zero
257 differ from normal zero. As I understand it. (Need to
258 check - is negative zero implementation defined behaviour
260 UV buv = SvUVX(POPs);
261 UV auv = SvUVX(TOPs);
263 SETs(boolSV(auv == buv));
266 { /* ## Mixed IV,UV ## */
270 /* == is commutative so doesn't matter which is left or right */
272 /* top of stack (b) is the iv */
281 /* As uv is a UV, it's >0, so it cannot be == */
285 /* we know iv is >= 0 */
286 SETs(boolSV((UV)iv == SvUVX(uvp)));
294 SETs(boolSV(TOPn == value));
302 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
303 DIE(aTHX_ PL_no_modify);
304 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
305 && SvIVX(TOPs) != IV_MAX)
307 SvIV_set(TOPs, SvIVX(TOPs) + 1);
308 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
310 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
323 RETURNOP(cLOGOP->op_other);
331 bool defined = FALSE;
332 const int op_type = PL_op->op_type;
334 if(op_type == OP_DOR) {
336 if (!sv || !SvANY(sv)) {
338 RETURNOP(cLOGOP->op_other);
340 } else if (op_type == OP_DEFINED) {
342 if (!sv || !SvANY(sv))
346 switch (SvTYPE(sv)) {
348 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
352 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
356 if (CvROOT(sv) || CvXSUB(sv))
366 if(op_type == OP_DOR)
368 else if (op_type == OP_DEFINED)
372 if(op_type == OP_DOR) {
374 RETURNOP(cLOGOP->op_other);
375 } else if (op_type == OP_DEFINED) {
382 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
383 useleft = USE_LEFT(TOPm1s);
384 #ifdef PERL_PRESERVE_IVUV
385 /* We must see if we can perform the addition with integers if possible,
386 as the integer code detects overflow while the NV code doesn't.
387 If either argument hasn't had a numeric conversion yet attempt to get
388 the IV. It's important to do this now, rather than just assuming that
389 it's not IOK as a PV of "9223372036854775806" may not take well to NV
390 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
391 integer in case the second argument is IV=9223372036854775806
392 We can (now) rely on sv_2iv to do the right thing, only setting the
393 public IOK flag if the value in the NV (or PV) slot is truly integer.
395 A side effect is that this also aggressively prefers integer maths over
396 fp maths for integer values.
398 How to detect overflow?
400 C 99 section 6.2.6.1 says
402 The range of nonnegative values of a signed integer type is a subrange
403 of the corresponding unsigned integer type, and the representation of
404 the same value in each type is the same. A computation involving
405 unsigned operands can never overflow, because a result that cannot be
406 represented by the resulting unsigned integer type is reduced modulo
407 the number that is one greater than the largest value that can be
408 represented by the resulting type.
412 which I read as "unsigned ints wrap."
414 signed integer overflow seems to be classed as "exception condition"
416 If an exceptional condition occurs during the evaluation of an
417 expression (that is, if the result is not mathematically defined or not
418 in the range of representable values for its type), the behavior is
421 (6.5, the 5th paragraph)
423 I had assumed that on 2s complement machines signed arithmetic would
424 wrap, hence coded pp_add and pp_subtract on the assumption that
425 everything perl builds on would be happy. After much wailing and
426 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
427 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
428 unsigned code below is actually shorter than the old code. :-)
433 /* Unless the left argument is integer in range we are going to have to
434 use NV maths. Hence only attempt to coerce the right argument if
435 we know the left is integer. */
443 /* left operand is undef, treat as zero. + 0 is identity,
444 Could SETi or SETu right now, but space optimise by not adding
445 lots of code to speed up what is probably a rarish case. */
447 /* Left operand is defined, so is it IV? */
450 if ((auvok = SvUOK(TOPm1s)))
453 register const IV aiv = SvIVX(TOPm1s);
456 auvok = 1; /* Now acting as a sign flag. */
457 } else { /* 2s complement assumption for IV_MIN */
465 bool result_good = 0;
468 bool buvok = SvUOK(TOPs);
473 register const IV biv = SvIVX(TOPs);
480 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
481 else "IV" now, independent of how it came in.
482 if a, b represents positive, A, B negative, a maps to -A etc
487 all UV maths. negate result if A negative.
488 add if signs same, subtract if signs differ. */
494 /* Must get smaller */
500 /* result really should be -(auv-buv). as its negation
501 of true value, need to swap our result flag */
518 if (result <= (UV)IV_MIN)
521 /* result valid, but out of range for IV. */
526 } /* Overflow, drop through to NVs. */
533 /* left operand is undef, treat as zero. + 0.0 is identity. */
537 SETn( value + TOPn );
545 AV *av = PL_op->op_flags & OPf_SPECIAL ?
546 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
547 const U32 lval = PL_op->op_flags & OPf_MOD;
548 SV** svp = av_fetch(av, PL_op->op_private, lval);
549 SV *sv = (svp ? *svp : &PL_sv_undef);
551 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
552 sv = sv_mortalcopy(sv);
561 do_join(TARG, *MARK, MARK, SP);
572 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
573 * will be enough to hold an OP*.
575 SV* const sv = sv_newmortal();
576 sv_upgrade(sv, SVt_PVLV);
578 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
586 /* Oversized hot code. */
590 dVAR; dSP; dMARK; dORIGMARK;
596 if (PL_op->op_flags & OPf_STACKED)
601 if (gv && (io = GvIO(gv))
602 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
605 if (MARK == ORIGMARK) {
606 /* If using default handle then we need to make space to
607 * pass object as 1st arg, so move other args up ...
611 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
615 *MARK = SvTIED_obj((SV*)io, mg);
618 call_method("PRINT", G_SCALAR);
626 if (!(io = GvIO(gv))) {
627 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
628 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
630 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
631 report_evil_fh(gv, io, PL_op->op_type);
632 SETERRNO(EBADF,RMS_IFI);
635 else if (!(fp = IoOFP(io))) {
636 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
638 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
639 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
640 report_evil_fh(gv, io, PL_op->op_type);
642 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
647 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
649 if (!do_print(*MARK, fp))
653 if (!do_print(PL_ofs_sv, fp)) { /* $, */
662 if (!do_print(*MARK, fp))
670 if (PL_ors_sv && SvOK(PL_ors_sv))
671 if (!do_print(PL_ors_sv, fp)) /* $\ */
674 if (IoFLAGS(io) & IOf_FLUSH)
675 if (PerlIO_flush(fp) == EOF)
696 tryAMAGICunDEREF(to_av);
699 if (SvTYPE(av) != SVt_PVAV)
700 DIE(aTHX_ "Not an ARRAY reference");
701 if (PL_op->op_flags & OPf_REF) {
706 if (GIMME == G_SCALAR)
707 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
711 else if (PL_op->op_flags & OPf_MOD
712 && PL_op->op_private & OPpLVAL_INTRO)
713 Perl_croak(aTHX_ PL_no_localize_ref);
716 if (SvTYPE(sv) == SVt_PVAV) {
718 if (PL_op->op_flags & OPf_REF) {
723 if (GIMME == G_SCALAR)
724 Perl_croak(aTHX_ "Can't return array to lvalue"
733 if (SvTYPE(sv) != SVt_PVGV) {
734 if (SvGMAGICAL(sv)) {
740 if (PL_op->op_flags & OPf_REF ||
741 PL_op->op_private & HINT_STRICT_REFS)
742 DIE(aTHX_ PL_no_usym, "an ARRAY");
743 if (ckWARN(WARN_UNINITIALIZED))
745 if (GIMME == G_ARRAY) {
751 if ((PL_op->op_flags & OPf_SPECIAL) &&
752 !(PL_op->op_flags & OPf_MOD))
754 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
756 && (!is_gv_magical_sv(sv,0)
757 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
763 if (PL_op->op_private & HINT_STRICT_REFS)
764 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
765 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
772 if (PL_op->op_private & OPpLVAL_INTRO)
774 if (PL_op->op_flags & OPf_REF) {
779 if (GIMME == G_SCALAR)
780 Perl_croak(aTHX_ "Can't return array to lvalue"
788 if (GIMME == G_ARRAY) {
789 const I32 maxarg = AvFILL(av) + 1;
790 (void)POPs; /* XXXX May be optimized away? */
792 if (SvRMAGICAL(av)) {
794 for (i=0; i < (U32)maxarg; i++) {
795 SV **svp = av_fetch(av, i, FALSE);
796 /* See note in pp_helem, and bug id #27839 */
798 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
803 Copy(AvARRAY(av), SP+1, maxarg, SV*);
807 else if (GIMME_V == G_SCALAR) {
809 const I32 maxarg = AvFILL(av) + 1;
819 const I32 gimme = GIMME_V;
820 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
824 tryAMAGICunDEREF(to_hv);
827 if (SvTYPE(hv) != SVt_PVHV)
828 DIE(aTHX_ "Not a HASH reference");
829 if (PL_op->op_flags & OPf_REF) {
834 if (gimme != G_ARRAY)
835 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
839 else if (PL_op->op_flags & OPf_MOD
840 && PL_op->op_private & OPpLVAL_INTRO)
841 Perl_croak(aTHX_ PL_no_localize_ref);
844 if (SvTYPE(sv) == SVt_PVHV) {
846 if (PL_op->op_flags & OPf_REF) {
851 if (gimme != G_ARRAY)
852 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
860 if (SvTYPE(sv) != SVt_PVGV) {
861 if (SvGMAGICAL(sv)) {
867 if (PL_op->op_flags & OPf_REF ||
868 PL_op->op_private & HINT_STRICT_REFS)
869 DIE(aTHX_ PL_no_usym, "a HASH");
870 if (ckWARN(WARN_UNINITIALIZED))
872 if (gimme == G_ARRAY) {
878 if ((PL_op->op_flags & OPf_SPECIAL) &&
879 !(PL_op->op_flags & OPf_MOD))
881 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
883 && (!is_gv_magical_sv(sv,0)
884 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
890 if (PL_op->op_private & HINT_STRICT_REFS)
891 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
892 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
899 if (PL_op->op_private & OPpLVAL_INTRO)
901 if (PL_op->op_flags & OPf_REF) {
906 if (gimme != G_ARRAY)
907 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
914 if (gimme == G_ARRAY) { /* array wanted */
915 *PL_stack_sp = (SV*)hv;
918 else if (gimme == G_SCALAR) {
920 TARG = Perl_hv_scalar(aTHX_ hv);
927 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
933 if (ckWARN(WARN_MISC)) {
935 if (relem == firstrelem &&
937 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
938 SvTYPE(SvRV(*relem)) == SVt_PVHV))
940 err = "Reference found where even-sized list expected";
943 err = "Odd number of elements in hash assignment";
944 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
947 tmpstr = NEWSV(29,0);
948 didstore = hv_store_ent(hash,*relem,tmpstr,0);
949 if (SvMAGICAL(hash)) {
950 if (SvSMAGICAL(tmpstr))
962 SV **lastlelem = PL_stack_sp;
963 SV **lastrelem = PL_stack_base + POPMARK;
964 SV **firstrelem = PL_stack_base + POPMARK + 1;
965 SV **firstlelem = lastrelem + 1;
978 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
981 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
984 /* If there's a common identifier on both sides we have to take
985 * special care that assigning the identifier on the left doesn't
986 * clobber a value on the right that's used later in the list.
988 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
989 EXTEND_MORTAL(lastrelem - firstrelem + 1);
990 for (relem = firstrelem; relem <= lastrelem; relem++) {
992 TAINT_NOT; /* Each item is independent */
993 *relem = sv_mortalcopy(sv);
1003 while (lelem <= lastlelem) {
1004 TAINT_NOT; /* Each item stands on its own, taintwise. */
1006 switch (SvTYPE(sv)) {
1009 magic = SvMAGICAL(ary) != 0;
1011 av_extend(ary, lastrelem - relem);
1013 while (relem <= lastrelem) { /* gobble up all the rest */
1016 sv = newSVsv(*relem);
1018 didstore = av_store(ary,i++,sv);
1028 case SVt_PVHV: { /* normal hash */
1032 magic = SvMAGICAL(hash) != 0;
1034 firsthashrelem = relem;
1036 while (relem < lastrelem) { /* gobble up all the rest */
1041 sv = &PL_sv_no, relem++;
1042 tmpstr = NEWSV(29,0);
1044 sv_setsv(tmpstr,*relem); /* value */
1045 *(relem++) = tmpstr;
1046 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1047 /* key overwrites an existing entry */
1049 didstore = hv_store_ent(hash,sv,tmpstr,0);
1051 if (SvSMAGICAL(tmpstr))
1058 if (relem == lastrelem) {
1059 do_oddball(hash, relem, firstrelem);
1065 if (SvIMMORTAL(sv)) {
1066 if (relem <= lastrelem)
1070 if (relem <= lastrelem) {
1071 sv_setsv(sv, *relem);
1075 sv_setsv(sv, &PL_sv_undef);
1080 if (PL_delaymagic & ~DM_DELAY) {
1081 if (PL_delaymagic & DM_UID) {
1082 #ifdef HAS_SETRESUID
1083 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1084 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1087 # ifdef HAS_SETREUID
1088 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1089 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1092 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1093 (void)setruid(PL_uid);
1094 PL_delaymagic &= ~DM_RUID;
1096 # endif /* HAS_SETRUID */
1098 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1099 (void)seteuid(PL_euid);
1100 PL_delaymagic &= ~DM_EUID;
1102 # endif /* HAS_SETEUID */
1103 if (PL_delaymagic & DM_UID) {
1104 if (PL_uid != PL_euid)
1105 DIE(aTHX_ "No setreuid available");
1106 (void)PerlProc_setuid(PL_uid);
1108 # endif /* HAS_SETREUID */
1109 #endif /* HAS_SETRESUID */
1110 PL_uid = PerlProc_getuid();
1111 PL_euid = PerlProc_geteuid();
1113 if (PL_delaymagic & DM_GID) {
1114 #ifdef HAS_SETRESGID
1115 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1116 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1119 # ifdef HAS_SETREGID
1120 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1121 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1124 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1125 (void)setrgid(PL_gid);
1126 PL_delaymagic &= ~DM_RGID;
1128 # endif /* HAS_SETRGID */
1130 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1131 (void)setegid(PL_egid);
1132 PL_delaymagic &= ~DM_EGID;
1134 # endif /* HAS_SETEGID */
1135 if (PL_delaymagic & DM_GID) {
1136 if (PL_gid != PL_egid)
1137 DIE(aTHX_ "No setregid available");
1138 (void)PerlProc_setgid(PL_gid);
1140 # endif /* HAS_SETREGID */
1141 #endif /* HAS_SETRESGID */
1142 PL_gid = PerlProc_getgid();
1143 PL_egid = PerlProc_getegid();
1145 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1149 if (gimme == G_VOID)
1150 SP = firstrelem - 1;
1151 else if (gimme == G_SCALAR) {
1154 SETi(lastrelem - firstrelem + 1 - duplicates);
1161 /* Removes from the stack the entries which ended up as
1162 * duplicated keys in the hash (fix for [perl #24380]) */
1163 Move(firsthashrelem + duplicates,
1164 firsthashrelem, duplicates, SV**);
1165 lastrelem -= duplicates;
1170 SP = firstrelem + (lastlelem - firstlelem);
1171 lelem = firstlelem + (relem - firstrelem);
1173 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1181 register PMOP * const pm = cPMOP;
1182 SV * const rv = sv_newmortal();
1183 SV * const sv = newSVrv(rv, "Regexp");
1184 if (pm->op_pmdynflags & PMdf_TAINTED)
1186 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1193 register PMOP *pm = cPMOP;
1195 register const char *t;
1196 register const char *s;
1199 I32 r_flags = REXEC_CHECKED;
1200 const char *truebase; /* Start of string */
1201 register REGEXP *rx = PM_GETRE(pm);
1203 const I32 gimme = GIMME;
1206 const I32 oldsave = PL_savestack_ix;
1207 I32 update_minmatch = 1;
1208 I32 had_zerolen = 0;
1210 if (PL_op->op_flags & OPf_STACKED)
1212 else if (PL_op->op_private & OPpTARGET_MY)
1219 PUTBACK; /* EVAL blocks need stack_sp. */
1220 s = SvPV_const(TARG, len);
1222 DIE(aTHX_ "panic: pp_match");
1224 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1225 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1228 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1230 /* PMdf_USED is set after a ?? matches once */
1231 if (pm->op_pmdynflags & PMdf_USED) {
1233 if (gimme == G_ARRAY)
1238 /* empty pattern special-cased to use last successful pattern if possible */
1239 if (!rx->prelen && PL_curpm) {
1244 if (rx->minlen > (I32)len)
1249 /* XXXX What part of this is needed with true \G-support? */
1250 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1252 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1253 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1254 if (mg && mg->mg_len >= 0) {
1255 if (!(rx->reganch & ROPT_GPOS_SEEN))
1256 rx->endp[0] = rx->startp[0] = mg->mg_len;
1257 else if (rx->reganch & ROPT_ANCH_GPOS) {
1258 r_flags |= REXEC_IGNOREPOS;
1259 rx->endp[0] = rx->startp[0] = mg->mg_len;
1261 minmatch = (mg->mg_flags & MGf_MINMATCH);
1262 update_minmatch = 0;
1266 if ((!global && rx->nparens)
1267 || SvTEMP(TARG) || PL_sawampersand)
1268 r_flags |= REXEC_COPY_STR;
1270 r_flags |= REXEC_SCREAM;
1273 if (global && rx->startp[0] != -1) {
1274 t = s = rx->endp[0] + truebase;
1275 if ((s + rx->minlen) > strend)
1277 if (update_minmatch++)
1278 minmatch = had_zerolen;
1280 if (rx->reganch & RE_USE_INTUIT &&
1281 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1282 /* FIXME - can PL_bostr be made const char *? */
1283 PL_bostr = (char *)truebase;
1284 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1288 if ( (rx->reganch & ROPT_CHECK_ALL)
1290 && ((rx->reganch & ROPT_NOSCAN)
1291 || !((rx->reganch & RE_INTUIT_TAIL)
1292 && (r_flags & REXEC_SCREAM)))
1293 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1296 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1299 if (dynpm->op_pmflags & PMf_ONCE)
1300 dynpm->op_pmdynflags |= PMdf_USED;
1309 RX_MATCH_TAINTED_on(rx);
1310 TAINT_IF(RX_MATCH_TAINTED(rx));
1311 if (gimme == G_ARRAY) {
1312 const I32 nparens = rx->nparens;
1313 I32 i = (global && !nparens) ? 1 : 0;
1315 SPAGAIN; /* EVAL blocks could move the stack. */
1316 EXTEND(SP, nparens + i);
1317 EXTEND_MORTAL(nparens + i);
1318 for (i = !i; i <= nparens; i++) {
1319 PUSHs(sv_newmortal());
1320 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1321 const I32 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 /* FIXME - should rx->subbeg be const char *? */
1393 rx->subbeg = (char *) truebase;
1394 rx->startp[0] = s - truebase;
1395 if (RX_MATCH_UTF8(rx)) {
1396 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1397 rx->endp[0] = t - truebase;
1400 rx->endp[0] = s - truebase + rx->minlen;
1402 rx->sublen = strend - truebase;
1405 if (PL_sawampersand) {
1407 #ifdef PERL_OLD_COPY_ON_WRITE
1408 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1410 PerlIO_printf(Perl_debug_log,
1411 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1412 (int) SvTYPE(TARG), truebase, t,
1415 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1416 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1417 assert (SvPOKp(rx->saved_copy));
1422 rx->subbeg = savepvn(t, strend - t);
1423 #ifdef PERL_OLD_COPY_ON_WRITE
1424 rx->saved_copy = Nullsv;
1427 rx->sublen = strend - t;
1428 RX_MATCH_COPIED_on(rx);
1429 off = rx->startp[0] = s - t;
1430 rx->endp[0] = off + rx->minlen;
1432 else { /* startp/endp are used by @- @+. */
1433 rx->startp[0] = s - truebase;
1434 rx->endp[0] = s - truebase + rx->minlen;
1436 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1437 LEAVE_SCOPE(oldsave);
1442 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1443 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1444 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1449 LEAVE_SCOPE(oldsave);
1450 if (gimme == G_ARRAY)
1456 Perl_do_readline(pTHX)
1458 dVAR; dSP; dTARGETSTACKED;
1463 register IO * const io = GvIO(PL_last_in_gv);
1464 register const I32 type = PL_op->op_type;
1465 const I32 gimme = GIMME_V;
1468 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1470 XPUSHs(SvTIED_obj((SV*)io, mg));
1473 call_method("READLINE", gimme);
1476 if (gimme == G_SCALAR) {
1478 SvSetSV_nosteal(TARG, result);
1487 if (IoFLAGS(io) & IOf_ARGV) {
1488 if (IoFLAGS(io) & IOf_START) {
1490 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1491 IoFLAGS(io) &= ~IOf_START;
1492 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1493 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1494 SvSETMAGIC(GvSV(PL_last_in_gv));
1499 fp = nextargv(PL_last_in_gv);
1500 if (!fp) { /* Note: fp != IoIFP(io) */
1501 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1504 else if (type == OP_GLOB)
1505 fp = Perl_start_glob(aTHX_ POPs, io);
1507 else if (type == OP_GLOB)
1509 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1510 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1514 if ((!io || !(IoFLAGS(io) & IOf_START))
1515 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1517 if (type == OP_GLOB)
1518 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1519 "glob failed (can't start child: %s)",
1522 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1524 if (gimme == G_SCALAR) {
1525 /* undef TARG, and push that undefined value */
1526 if (type != OP_RCATLINE) {
1527 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1535 if (gimme == G_SCALAR) {
1539 SvUPGRADE(sv, SVt_PV);
1540 tmplen = SvLEN(sv); /* remember if already alloced */
1541 if (!tmplen && !SvREADONLY(sv))
1542 Sv_Grow(sv, 80); /* try short-buffering it */
1544 if (type == OP_RCATLINE && SvOK(sv)) {
1546 SvPV_force_nolen(sv);
1552 sv = sv_2mortal(NEWSV(57, 80));
1556 /* This should not be marked tainted if the fp is marked clean */
1557 #define MAYBE_TAINT_LINE(io, sv) \
1558 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1563 /* delay EOF state for a snarfed empty file */
1564 #define SNARF_EOF(gimme,rs,io,sv) \
1565 (gimme != G_SCALAR || SvCUR(sv) \
1566 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1570 if (!sv_gets(sv, fp, offset)
1572 || SNARF_EOF(gimme, PL_rs, io, sv)
1573 || PerlIO_error(fp)))
1575 PerlIO_clearerr(fp);
1576 if (IoFLAGS(io) & IOf_ARGV) {
1577 fp = nextargv(PL_last_in_gv);
1580 (void)do_close(PL_last_in_gv, FALSE);
1582 else if (type == OP_GLOB) {
1583 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1584 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1585 "glob failed (child exited with status %d%s)",
1586 (int)(STATUS_CURRENT >> 8),
1587 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1590 if (gimme == G_SCALAR) {
1591 if (type != OP_RCATLINE) {
1592 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1598 MAYBE_TAINT_LINE(io, sv);
1601 MAYBE_TAINT_LINE(io, sv);
1603 IoFLAGS(io) |= IOf_NOLINE;
1607 if (type == OP_GLOB) {
1611 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1612 tmps = SvEND(sv) - 1;
1613 if (*tmps == *SvPVX_const(PL_rs)) {
1615 SvCUR_set(sv, SvCUR(sv) - 1);
1618 for (t1 = SvPVX_const(sv); *t1; t1++)
1619 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1620 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1622 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1623 (void)POPs; /* Unmatched wildcard? Chuck it... */
1626 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1627 const U8 *s = (const U8*)SvPVX_const(sv) + offset;
1628 const STRLEN len = SvCUR(sv) - offset;
1631 if (ckWARN(WARN_UTF8) &&
1632 !is_utf8_string_loc(s, len, &f))
1633 /* Emulate :encoding(utf8) warning in the same case. */
1634 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1635 "utf8 \"\\x%02X\" does not map to Unicode",
1636 f < (U8*)SvEND(sv) ? *f : 0);
1638 if (gimme == G_ARRAY) {
1639 if (SvLEN(sv) - SvCUR(sv) > 20) {
1640 SvPV_shrink_to_cur(sv);
1642 sv = sv_2mortal(NEWSV(58, 80));
1645 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1646 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1647 const STRLEN new_len
1648 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1649 SvPV_renew(sv, new_len);
1658 register PERL_CONTEXT *cx;
1659 I32 gimme = OP_GIMME(PL_op, -1);
1662 if (cxstack_ix >= 0)
1663 gimme = cxstack[cxstack_ix].blk_gimme;
1671 PUSHBLOCK(cx, CXt_BLOCK, SP);
1683 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1684 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1686 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1689 if (SvTYPE(hv) == SVt_PVHV) {
1690 if (PL_op->op_private & OPpLVAL_INTRO) {
1693 /* does the element we're localizing already exist? */
1695 /* can we determine whether it exists? */
1697 || mg_find((SV*)hv, PERL_MAGIC_env)
1698 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1699 /* Try to preserve the existenceness of a tied hash
1700 * element by using EXISTS and DELETE if possible.
1701 * Fallback to FETCH and STORE otherwise */
1702 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1703 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1704 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1706 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1709 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1710 svp = he ? &HeVAL(he) : 0;
1716 if (!svp || *svp == &PL_sv_undef) {
1720 DIE(aTHX_ PL_no_helem_sv, keysv);
1722 lv = sv_newmortal();
1723 sv_upgrade(lv, SVt_PVLV);
1725 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1726 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1727 LvTARG(lv) = SvREFCNT_inc(hv);
1732 if (PL_op->op_private & OPpLVAL_INTRO) {
1733 if (HvNAME_get(hv) && isGV(*svp))
1734 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1738 const char * const key = SvPV_const(keysv, keylen);
1739 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1741 save_helem(hv, keysv, svp);
1744 else if (PL_op->op_private & OPpDEREF)
1745 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1747 sv = (svp ? *svp : &PL_sv_undef);
1748 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1749 * Pushing the magical RHS on to the stack is useless, since
1750 * that magic is soon destined to be misled by the local(),
1751 * and thus the later pp_sassign() will fail to mg_get() the
1752 * old value. This should also cure problems with delayed
1753 * mg_get()s. GSAR 98-07-03 */
1754 if (!lval && SvGMAGICAL(sv))
1755 sv = sv_mortalcopy(sv);
1763 register PERL_CONTEXT *cx;
1768 if (PL_op->op_flags & OPf_SPECIAL) {
1769 cx = &cxstack[cxstack_ix];
1770 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1775 gimme = OP_GIMME(PL_op, -1);
1777 if (cxstack_ix >= 0)
1778 gimme = cxstack[cxstack_ix].blk_gimme;
1784 if (gimme == G_VOID)
1786 else if (gimme == G_SCALAR) {
1790 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1793 *MARK = sv_mortalcopy(TOPs);
1796 *MARK = &PL_sv_undef;
1800 else if (gimme == G_ARRAY) {
1801 /* in case LEAVE wipes old return values */
1803 for (mark = newsp + 1; mark <= SP; mark++) {
1804 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1805 *mark = sv_mortalcopy(*mark);
1806 TAINT_NOT; /* Each item is independent */
1810 PL_curpm = newpm; /* Don't pop $1 et al till now */
1820 register PERL_CONTEXT *cx;
1826 cx = &cxstack[cxstack_ix];
1827 if (CxTYPE(cx) != CXt_LOOP)
1828 DIE(aTHX_ "panic: pp_iter");
1830 itersvp = CxITERVAR(cx);
1831 av = cx->blk_loop.iterary;
1832 if (SvTYPE(av) != SVt_PVAV) {
1833 /* iterate ($min .. $max) */
1834 if (cx->blk_loop.iterlval) {
1835 /* string increment */
1836 register SV* cur = cx->blk_loop.iterlval;
1838 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1839 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1840 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1841 /* safe to reuse old SV */
1842 sv_setsv(*itersvp, cur);
1846 /* we need a fresh SV every time so that loop body sees a
1847 * completely new SV for closures/references to work as
1850 *itersvp = newSVsv(cur);
1851 SvREFCNT_dec(oldsv);
1853 if (strEQ(SvPVX_const(cur), max))
1854 sv_setiv(cur, 0); /* terminate next time */
1861 /* integer increment */
1862 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1865 /* don't risk potential race */
1866 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1867 /* safe to reuse old SV */
1868 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1872 /* we need a fresh SV every time so that loop body sees a
1873 * completely new SV for closures/references to work as they
1876 *itersvp = newSViv(cx->blk_loop.iterix++);
1877 SvREFCNT_dec(oldsv);
1883 if (PL_op->op_private & OPpITER_REVERSED) {
1884 /* In reverse, use itermax as the min :-) */
1885 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1888 if (SvMAGICAL(av) || AvREIFY(av)) {
1889 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1896 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1900 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1904 if (SvMAGICAL(av) || AvREIFY(av)) {
1905 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1912 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1916 if (sv && SvREFCNT(sv) == 0) {
1918 Perl_croak(aTHX_ "Use of freed value in iteration");
1925 if (av != PL_curstack && sv == &PL_sv_undef) {
1926 SV *lv = cx->blk_loop.iterlval;
1927 if (lv && SvREFCNT(lv) > 1) {
1932 SvREFCNT_dec(LvTARG(lv));
1934 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1935 sv_upgrade(lv, SVt_PVLV);
1937 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1939 LvTARG(lv) = SvREFCNT_inc(av);
1940 LvTARGOFF(lv) = cx->blk_loop.iterix;
1941 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1946 *itersvp = SvREFCNT_inc(sv);
1947 SvREFCNT_dec(oldsv);
1955 register PMOP *pm = cPMOP;
1971 register REGEXP *rx = PM_GETRE(pm);
1973 int force_on_match = 0;
1974 I32 oldsave = PL_savestack_ix;
1976 bool doutf8 = FALSE;
1977 #ifdef PERL_OLD_COPY_ON_WRITE
1982 /* known replacement string? */
1983 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1984 if (PL_op->op_flags & OPf_STACKED)
1986 else if (PL_op->op_private & OPpTARGET_MY)
1993 #ifdef PERL_OLD_COPY_ON_WRITE
1994 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1995 because they make integers such as 256 "false". */
1996 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1999 sv_force_normal_flags(TARG,0);
2002 #ifdef PERL_OLD_COPY_ON_WRITE
2006 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2007 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2008 DIE(aTHX_ PL_no_modify);
2011 s = SvPV_mutable(TARG, len);
2012 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2014 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2015 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2020 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2024 DIE(aTHX_ "panic: pp_subst");
2027 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2028 maxiters = 2 * slen + 10; /* We can match twice at each
2029 position, once with zero-length,
2030 second time with non-zero. */
2032 if (!rx->prelen && PL_curpm) {
2036 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2037 ? REXEC_COPY_STR : 0;
2039 r_flags |= REXEC_SCREAM;
2042 if (rx->reganch & RE_USE_INTUIT) {
2044 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2048 /* How to do it in subst? */
2049 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2051 && ((rx->reganch & ROPT_NOSCAN)
2052 || !((rx->reganch & RE_INTUIT_TAIL)
2053 && (r_flags & REXEC_SCREAM))))
2058 /* only replace once? */
2059 once = !(rpm->op_pmflags & PMf_GLOBAL);
2061 /* known replacement string? */
2063 /* replacement needing upgrading? */
2064 if (DO_UTF8(TARG) && !doutf8) {
2065 nsv = sv_newmortal();
2068 sv_recode_to_utf8(nsv, PL_encoding);
2070 sv_utf8_upgrade(nsv);
2071 c = SvPV_const(nsv, clen);
2075 c = SvPV_const(dstr, clen);
2076 doutf8 = DO_UTF8(dstr);
2084 /* can do inplace substitution? */
2086 #ifdef PERL_OLD_COPY_ON_WRITE
2089 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2090 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2091 && (!doutf8 || SvUTF8(TARG))) {
2092 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2093 r_flags | REXEC_CHECKED))
2097 LEAVE_SCOPE(oldsave);
2100 #ifdef PERL_OLD_COPY_ON_WRITE
2101 if (SvIsCOW(TARG)) {
2102 assert (!force_on_match);
2106 if (force_on_match) {
2108 s = SvPV_force(TARG, len);
2113 SvSCREAM_off(TARG); /* disable possible screamer */
2115 rxtainted |= RX_MATCH_TAINTED(rx);
2116 m = orig + rx->startp[0];
2117 d = orig + rx->endp[0];
2119 if (m - s > strend - d) { /* faster to shorten from end */
2121 Copy(c, m, clen, char);
2126 Move(d, m, i, char);
2130 SvCUR_set(TARG, m - s);
2132 else if ((i = m - s)) { /* faster from front */
2140 Copy(c, m, clen, char);
2145 Copy(c, d, clen, char);
2150 TAINT_IF(rxtainted & 1);
2156 if (iters++ > maxiters)
2157 DIE(aTHX_ "Substitution loop");
2158 rxtainted |= RX_MATCH_TAINTED(rx);
2159 m = rx->startp[0] + orig;
2162 Move(s, d, i, char);
2166 Copy(c, d, clen, char);
2169 s = rx->endp[0] + orig;
2170 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2172 /* don't match same null twice */
2173 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2176 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2177 Move(s, d, i+1, char); /* include the NUL */
2179 TAINT_IF(rxtainted & 1);
2181 PUSHs(sv_2mortal(newSViv((I32)iters)));
2183 (void)SvPOK_only_UTF8(TARG);
2184 TAINT_IF(rxtainted);
2185 if (SvSMAGICAL(TARG)) {
2193 LEAVE_SCOPE(oldsave);
2197 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2198 r_flags | REXEC_CHECKED))
2200 if (force_on_match) {
2202 s = SvPV_force(TARG, len);
2205 #ifdef PERL_OLD_COPY_ON_WRITE
2208 rxtainted |= RX_MATCH_TAINTED(rx);
2209 dstr = newSVpvn(m, s-m);
2214 register PERL_CONTEXT *cx;
2216 (void)ReREFCNT_inc(rx);
2218 RETURNOP(cPMOP->op_pmreplroot);
2220 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2222 if (iters++ > maxiters)
2223 DIE(aTHX_ "Substitution loop");
2224 rxtainted |= RX_MATCH_TAINTED(rx);
2225 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2230 strend = s + (strend - m);
2232 m = rx->startp[0] + orig;
2233 if (doutf8 && !SvUTF8(dstr))
2234 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2236 sv_catpvn(dstr, s, m-s);
2237 s = rx->endp[0] + orig;
2239 sv_catpvn(dstr, c, clen);
2242 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2243 TARG, NULL, r_flags));
2244 if (doutf8 && !DO_UTF8(TARG))
2245 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2247 sv_catpvn(dstr, s, strend - s);
2249 #ifdef PERL_OLD_COPY_ON_WRITE
2250 /* The match may make the string COW. If so, brilliant, because that's
2251 just saved us one malloc, copy and free - the regexp has donated
2252 the old buffer, and we malloc an entirely new one, rather than the
2253 regexp malloc()ing a buffer and copying our original, only for
2254 us to throw it away here during the substitution. */
2255 if (SvIsCOW(TARG)) {
2256 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2262 SvPV_set(TARG, SvPVX(dstr));
2263 SvCUR_set(TARG, SvCUR(dstr));
2264 SvLEN_set(TARG, SvLEN(dstr));
2265 doutf8 |= DO_UTF8(dstr);
2266 SvPV_set(dstr, (char*)0);
2269 TAINT_IF(rxtainted & 1);
2271 PUSHs(sv_2mortal(newSViv((I32)iters)));
2273 (void)SvPOK_only(TARG);
2276 TAINT_IF(rxtainted);
2279 LEAVE_SCOPE(oldsave);
2288 LEAVE_SCOPE(oldsave);
2297 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2298 ++*PL_markstack_ptr;
2299 LEAVE; /* exit inner scope */
2302 if (PL_stack_base + *PL_markstack_ptr > SP) {
2304 const I32 gimme = GIMME_V;
2306 LEAVE; /* exit outer scope */
2307 (void)POPMARK; /* pop src */
2308 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2309 (void)POPMARK; /* pop dst */
2310 SP = PL_stack_base + POPMARK; /* pop original mark */
2311 if (gimme == G_SCALAR) {
2312 if (PL_op->op_private & OPpGREP_LEX) {
2313 SV* const sv = sv_newmortal();
2314 sv_setiv(sv, items);
2322 else if (gimme == G_ARRAY)
2329 ENTER; /* enter inner scope */
2332 src = PL_stack_base[*PL_markstack_ptr];
2334 if (PL_op->op_private & OPpGREP_LEX)
2335 PAD_SVl(PL_op->op_targ) = src;
2339 RETURNOP(cLOGOP->op_other);
2350 register PERL_CONTEXT *cx;
2353 if (CxMULTICALL(&cxstack[cxstack_ix]))
2357 cxstack_ix++; /* temporarily protect top context */
2360 if (gimme == G_SCALAR) {
2363 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2365 *MARK = SvREFCNT_inc(TOPs);
2370 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2372 *MARK = sv_mortalcopy(sv);
2377 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2381 *MARK = &PL_sv_undef;
2385 else if (gimme == G_ARRAY) {
2386 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2387 if (!SvTEMP(*MARK)) {
2388 *MARK = sv_mortalcopy(*MARK);
2389 TAINT_NOT; /* Each item is independent */
2397 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2398 PL_curpm = newpm; /* ... and pop $1 et al */
2401 return cx->blk_sub.retop;
2404 /* This duplicates the above code because the above code must not
2405 * get any slower by more conditions */
2413 register PERL_CONTEXT *cx;
2416 if (CxMULTICALL(&cxstack[cxstack_ix]))
2420 cxstack_ix++; /* temporarily protect top context */
2424 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2425 /* We are an argument to a function or grep().
2426 * This kind of lvalueness was legal before lvalue
2427 * subroutines too, so be backward compatible:
2428 * cannot report errors. */
2430 /* Scalar context *is* possible, on the LHS of -> only,
2431 * as in f()->meth(). But this is not an lvalue. */
2432 if (gimme == G_SCALAR)
2434 if (gimme == G_ARRAY) {
2435 if (!CvLVALUE(cx->blk_sub.cv))
2436 goto temporise_array;
2437 EXTEND_MORTAL(SP - newsp);
2438 for (mark = newsp + 1; mark <= SP; mark++) {
2441 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2442 *mark = sv_mortalcopy(*mark);
2444 /* Can be a localized value subject to deletion. */
2445 PL_tmps_stack[++PL_tmps_ix] = *mark;
2446 (void)SvREFCNT_inc(*mark);
2451 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2452 /* Here we go for robustness, not for speed, so we change all
2453 * the refcounts so the caller gets a live guy. Cannot set
2454 * TEMP, so sv_2mortal is out of question. */
2455 if (!CvLVALUE(cx->blk_sub.cv)) {
2461 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2463 if (gimme == G_SCALAR) {
2467 /* Temporaries are bad unless they happen to be elements
2468 * of a tied hash or array */
2469 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2470 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
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 = GvSVn(PL_DBsub);
2575 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 * const tmp = newRV((SV*)cv);
2586 sv_setsv(dbsv, tmp);
2590 gv_efullname3(dbsv, gv, Nullch);
2594 const int type = SvTYPE(dbsv);
2595 if (type < SVt_PVIV && type != SVt_IV)
2596 sv_upgrade(dbsv, SVt_PVIV);
2597 (void)SvIOK_on(dbsv);
2598 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2602 PL_curcopdb = PL_curcop;
2603 cv = GvCV(PL_DBsub);
2613 register PERL_CONTEXT *cx;
2615 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2618 DIE(aTHX_ "Not a CODE reference");
2619 switch (SvTYPE(sv)) {
2620 /* This is overwhelming the most common case: */
2622 if (!(cv = GvCVu((GV*)sv)))
2623 cv = sv_2cv(sv, &stash, &gv, FALSE);
2633 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2635 SP = PL_stack_base + POPMARK;
2638 if (SvGMAGICAL(sv)) {
2642 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2645 sym = SvPV_nolen_const(sv);
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 * const * 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);
2686 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2687 DIE(aTHX_ "No DB::sub routine defined");
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));
2709 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2714 DEBUG_S(PerlIO_printf(Perl_debug_log,
2715 "%p entersub preparing @_\n", thr));
2717 av = (AV*)PAD_SVl(0);
2719 /* @_ is normally not REAL--this should only ever
2720 * happen when DB::sub() calls things that modify @_ */
2725 cx->blk_sub.savearray = GvAV(PL_defgv);
2726 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2727 CX_CURPAD_SAVE(cx->blk_sub);
2728 cx->blk_sub.argarray = av;
2731 if (items > AvMAX(av) + 1) {
2732 SV **ary = AvALLOC(av);
2733 if (AvARRAY(av) != ary) {
2734 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2735 SvPV_set(av, (char*)ary);
2737 if (items > AvMAX(av) + 1) {
2738 AvMAX(av) = items - 1;
2739 Renew(ary,items,SV*);
2741 SvPV_set(av, (char*)ary);
2744 Copy(MARK,AvARRAY(av),items,SV*);
2745 AvFILLp(av) = items - 1;
2753 /* warning must come *after* we fully set up the context
2754 * stuff so that __WARN__ handlers can safely dounwind()
2757 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2758 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2759 sub_crush_depth(cv);
2761 DEBUG_S(PerlIO_printf(Perl_debug_log,
2762 "%p entersub returning %p\n", thr, CvSTART(cv)));
2764 RETURNOP(CvSTART(cv));
2767 #ifdef PERL_XSUB_OLDSTYLE
2768 if (CvOLDSTYLE(cv)) {
2769 I32 (*fp3)(int,int,int);
2771 register I32 items = SP - MARK;
2772 /* We dont worry to copy from @_. */
2777 PL_stack_sp = mark + 1;
2778 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2779 items = (*fp3)(CvXSUBANY(cv).any_i32,
2780 MARK - PL_stack_base + 1,
2782 PL_stack_sp = PL_stack_base + items;
2785 #endif /* PERL_XSUB_OLDSTYLE */
2787 I32 markix = TOPMARK;
2792 /* Need to copy @_ to stack. Alternative may be to
2793 * switch stack to @_, and copy return values
2794 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2795 AV * const av = GvAV(PL_defgv);
2796 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2799 /* Mark is at the end of the stack. */
2801 Copy(AvARRAY(av), SP + 1, items, SV*);
2806 /* We assume first XSUB in &DB::sub is the called one. */
2808 SAVEVPTR(PL_curcop);
2809 PL_curcop = PL_curcopdb;
2812 /* Do we need to open block here? XXXX */
2813 (void)(*CvXSUB(cv))(aTHX_ cv);
2815 /* Enforce some sanity in scalar context. */
2816 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2817 if (markix > PL_stack_sp - PL_stack_base)
2818 *(PL_stack_base + markix) = &PL_sv_undef;
2820 *(PL_stack_base + markix) = *PL_stack_sp;
2821 PL_stack_sp = PL_stack_base + markix;
2829 assert (0); /* Cannot get here. */
2830 /* This is deliberately moved here as spaghetti code to keep it out of the
2837 /* anonymous or undef'd function leaves us no recourse */
2838 if (CvANON(cv) || !(gv = CvGV(cv)))
2839 DIE(aTHX_ "Undefined subroutine called");
2841 /* autoloaded stub? */
2842 if (cv != GvCV(gv)) {
2845 /* should call AUTOLOAD now? */
2848 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2855 sub_name = sv_newmortal();
2856 gv_efullname3(sub_name, gv, Nullch);
2857 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2861 DIE(aTHX_ "Not a CODE reference");
2867 Perl_sub_crush_depth(pTHX_ CV *cv)
2870 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2872 SV* const tmpstr = sv_newmortal();
2873 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2874 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2883 SV* const elemsv = POPs;
2884 IV elem = SvIV(elemsv);
2886 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2887 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2890 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2891 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2893 elem -= PL_curcop->cop_arybase;
2894 if (SvTYPE(av) != SVt_PVAV)
2896 svp = av_fetch(av, elem, lval && !defer);
2898 #ifdef PERL_MALLOC_WRAP
2899 if (SvUOK(elemsv)) {
2900 const UV uv = SvUV(elemsv);
2901 elem = uv > IV_MAX ? IV_MAX : uv;
2903 else if (SvNOK(elemsv))
2904 elem = (IV)SvNV(elemsv);
2906 static const char oom_array_extend[] =
2907 "Out of memory during array extend"; /* Duplicated in av.c */
2908 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2911 if (!svp || *svp == &PL_sv_undef) {
2914 DIE(aTHX_ PL_no_aelem, elem);
2915 lv = sv_newmortal();
2916 sv_upgrade(lv, SVt_PVLV);
2918 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2919 LvTARG(lv) = SvREFCNT_inc(av);
2920 LvTARGOFF(lv) = elem;
2925 if (PL_op->op_private & OPpLVAL_INTRO)
2926 save_aelem(av, elem, svp);
2927 else if (PL_op->op_private & OPpDEREF)
2928 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2930 sv = (svp ? *svp : &PL_sv_undef);
2931 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2932 sv = sv_mortalcopy(sv);
2938 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2943 Perl_croak(aTHX_ PL_no_modify);
2944 if (SvTYPE(sv) < SVt_RV)
2945 sv_upgrade(sv, SVt_RV);
2946 else if (SvTYPE(sv) >= SVt_PV) {
2953 SvRV_set(sv, NEWSV(355,0));
2956 SvRV_set(sv, (SV*)newAV());
2959 SvRV_set(sv, (SV*)newHV());
2970 SV* const sv = TOPs;
2973 SV* const rsv = SvRV(sv);
2974 if (SvTYPE(rsv) == SVt_PVCV) {
2980 SETs(method_common(sv, Null(U32*)));
2987 SV* const sv = cSVOP_sv;
2988 U32 hash = SvSHARED_HASH(sv);
2990 XPUSHs(method_common(sv, &hash));
2995 S_method_common(pTHX_ SV* meth, U32* hashp)
3001 const char* packname = Nullch;
3002 SV *packsv = Nullsv;
3004 const char * const name = SvPV_const(meth, namelen);
3005 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3008 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3016 /* this isn't a reference */
3017 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3018 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3020 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3027 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3028 !(ob=(SV*)GvIO(iogv)))
3030 /* this isn't the name of a filehandle either */
3032 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3033 ? !isIDFIRST_utf8((U8*)packname)
3034 : !isIDFIRST(*packname)
3037 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3038 SvOK(sv) ? "without a package or object reference"
3039 : "on an undefined value");
3041 /* assume it's a package name */
3042 stash = gv_stashpvn(packname, packlen, FALSE);
3046 SV* ref = newSViv(PTR2IV(stash));
3047 hv_store(PL_stashcache, packname, packlen, ref, 0);
3051 /* it _is_ a filehandle name -- replace with a reference */
3052 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3055 /* if we got here, ob should be a reference or a glob */
3056 if (!ob || !(SvOBJECT(ob)
3057 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3060 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3064 stash = SvSTASH(ob);
3067 /* NOTE: stash may be null, hope hv_fetch_ent and
3068 gv_fetchmethod can cope (it seems they can) */
3070 /* shortcut for simple names */
3072 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3074 gv = (GV*)HeVAL(he);
3075 if (isGV(gv) && GvCV(gv) &&
3076 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3077 return (SV*)GvCV(gv);
3081 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3084 /* This code tries to figure out just what went wrong with
3085 gv_fetchmethod. It therefore needs to duplicate a lot of
3086 the internals of that function. We can't move it inside
3087 Perl_gv_fetchmethod_autoload(), however, since that would
3088 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3091 const char* leaf = name;
3092 const char* sep = Nullch;
3095 for (p = name; *p; p++) {
3097 sep = p, leaf = p + 1;
3098 else if (*p == ':' && *(p + 1) == ':')
3099 sep = p, leaf = p + 2;
3101 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3102 /* the method name is unqualified or starts with SUPER:: */
3103 bool need_strlen = 1;
3105 packname = CopSTASHPV(PL_curcop);
3108 HEK * const packhek = HvNAME_HEK(stash);
3110 packname = HEK_KEY(packhek);
3111 packlen = HEK_LEN(packhek);
3121 "Can't use anonymous symbol table for method lookup");
3123 else if (need_strlen)
3124 packlen = strlen(packname);
3128 /* the method name is qualified */
3130 packlen = sep - name;
3133 /* we're relying on gv_fetchmethod not autovivifying the stash */
3134 if (gv_stashpvn(packname, packlen, FALSE)) {
3136 "Can't locate object method \"%s\" via package \"%.*s\"",
3137 leaf, (int)packlen, packname);
3141 "Can't locate object method \"%s\" via package \"%.*s\""
3142 " (perhaps you forgot to load \"%.*s\"?)",
3143 leaf, (int)packlen, packname, (int)packlen, packname);
3146 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3151 * c-indentation-style: bsd
3153 * indent-tabs-mode: t
3156 * ex: set ts=8 sts=4 sw=4 noet: