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);
103 if (PL_op->op_type == OP_AND)
105 RETURNOP(cLOGOP->op_other);
113 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
115 temp = left; left = right; right = temp;
117 if (PL_tainting && PL_tainted && !SvTAINTED(left))
119 SvSetMagicSV(right, left);
128 RETURNOP(cLOGOP->op_other);
130 RETURNOP(cLOGOP->op_next);
136 TAINT_NOT; /* Each statement is presumed innocent */
137 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
139 oldsave = PL_scopestack[PL_scopestack_ix - 1];
140 LEAVE_SCOPE(oldsave);
146 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
151 const char *rpv = SvPV_const(right, rlen); /* mg_get(right) happens here */
152 const bool rbyte = !DO_UTF8(right);
153 bool rcopied = FALSE;
155 if (TARG == right && right != left) {
156 right = sv_2mortal(newSVpvn(rpv, rlen));
157 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
163 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
164 lbyte = !DO_UTF8(left);
165 sv_setpvn(TARG, lpv, llen);
171 else { /* TARG == left */
173 SvGETMAGIC(left); /* or mg_get(left) may happen here */
175 sv_setpvn(left, "", 0);
176 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
177 lbyte = !DO_UTF8(left);
182 if (lbyte != rbyte) {
184 sv_utf8_upgrade_nomg(TARG);
187 right = sv_2mortal(newSVpvn(rpv, rlen));
188 sv_utf8_upgrade_nomg(right);
189 rpv = SvPV_const(right, rlen);
192 sv_catpvn_nomg(TARG, rpv, rlen);
203 if (PL_op->op_flags & OPf_MOD) {
204 if (PL_op->op_private & OPpLVAL_INTRO)
205 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
206 if (PL_op->op_private & OPpDEREF) {
208 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
217 tryAMAGICunTARGET(iter, 0);
218 PL_last_in_gv = (GV*)(*PL_stack_sp--);
219 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
220 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
221 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
224 XPUSHs((SV*)PL_last_in_gv);
227 PL_last_in_gv = (GV*)(*PL_stack_sp--);
230 return do_readline();
235 dSP; tryAMAGICbinSET(eq,0);
236 #ifndef NV_PRESERVES_UV
237 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
239 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
243 #ifdef PERL_PRESERVE_IVUV
246 /* Unless the left argument is integer in range we are going
247 to have to use NV maths. Hence only attempt to coerce the
248 right argument if we know the left is integer. */
251 bool auvok = SvUOK(TOPm1s);
252 bool buvok = SvUOK(TOPs);
254 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
255 /* Casting IV to UV before comparison isn't going to matter
256 on 2s complement. On 1s complement or sign&magnitude
257 (if we have any of them) it could to make negative zero
258 differ from normal zero. As I understand it. (Need to
259 check - is negative zero implementation defined behaviour
261 UV buv = SvUVX(POPs);
262 UV auv = SvUVX(TOPs);
264 SETs(boolSV(auv == buv));
267 { /* ## Mixed IV,UV ## */
271 /* == is commutative so doesn't matter which is left or right */
273 /* top of stack (b) is the iv */
282 /* As uv is a UV, it's >0, so it cannot be == */
286 /* we know iv is >= 0 */
287 SETs(boolSV((UV)iv == SvUVX(uvp)));
295 SETs(boolSV(TOPn == value));
303 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
304 DIE(aTHX_ PL_no_modify);
305 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
306 && SvIVX(TOPs) != IV_MAX)
308 SvIV_set(TOPs, SvIVX(TOPs) + 1);
309 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
311 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
323 if (PL_op->op_type == OP_OR)
325 RETURNOP(cLOGOP->op_other);
332 register SV* sv = NULL;
333 bool defined = FALSE;
334 const int op_type = PL_op->op_type;
336 if(op_type == OP_DOR || op_type == OP_DORASSIGN) {
338 if (!sv || !SvANY(sv)) {
339 if (op_type == OP_DOR)
341 RETURNOP(cLOGOP->op_other);
343 } else if (op_type == OP_DEFINED) {
345 if (!sv || !SvANY(sv))
348 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
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))
369 if(op_type == OP_DOR || op_type == OP_DORASSIGN) {
372 if(op_type == OP_DOR)
374 RETURNOP(cLOGOP->op_other);
376 /* assuming OP_DEFINED */
384 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
385 useleft = USE_LEFT(TOPm1s);
386 #ifdef PERL_PRESERVE_IVUV
387 /* We must see if we can perform the addition with integers if possible,
388 as the integer code detects overflow while the NV code doesn't.
389 If either argument hasn't had a numeric conversion yet attempt to get
390 the IV. It's important to do this now, rather than just assuming that
391 it's not IOK as a PV of "9223372036854775806" may not take well to NV
392 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
393 integer in case the second argument is IV=9223372036854775806
394 We can (now) rely on sv_2iv to do the right thing, only setting the
395 public IOK flag if the value in the NV (or PV) slot is truly integer.
397 A side effect is that this also aggressively prefers integer maths over
398 fp maths for integer values.
400 How to detect overflow?
402 C 99 section 6.2.6.1 says
404 The range of nonnegative values of a signed integer type is a subrange
405 of the corresponding unsigned integer type, and the representation of
406 the same value in each type is the same. A computation involving
407 unsigned operands can never overflow, because a result that cannot be
408 represented by the resulting unsigned integer type is reduced modulo
409 the number that is one greater than the largest value that can be
410 represented by the resulting type.
414 which I read as "unsigned ints wrap."
416 signed integer overflow seems to be classed as "exception condition"
418 If an exceptional condition occurs during the evaluation of an
419 expression (that is, if the result is not mathematically defined or not
420 in the range of representable values for its type), the behavior is
423 (6.5, the 5th paragraph)
425 I had assumed that on 2s complement machines signed arithmetic would
426 wrap, hence coded pp_add and pp_subtract on the assumption that
427 everything perl builds on would be happy. After much wailing and
428 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
429 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
430 unsigned code below is actually shorter than the old code. :-)
435 /* Unless the left argument is integer in range we are going to have to
436 use NV maths. Hence only attempt to coerce the right argument if
437 we know the left is integer. */
445 /* left operand is undef, treat as zero. + 0 is identity,
446 Could SETi or SETu right now, but space optimise by not adding
447 lots of code to speed up what is probably a rarish case. */
449 /* Left operand is defined, so is it IV? */
452 if ((auvok = SvUOK(TOPm1s)))
455 register const IV aiv = SvIVX(TOPm1s);
458 auvok = 1; /* Now acting as a sign flag. */
459 } else { /* 2s complement assumption for IV_MIN */
467 bool result_good = 0;
470 bool buvok = SvUOK(TOPs);
475 register const IV biv = SvIVX(TOPs);
482 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
483 else "IV" now, independent of how it came in.
484 if a, b represents positive, A, B negative, a maps to -A etc
489 all UV maths. negate result if A negative.
490 add if signs same, subtract if signs differ. */
496 /* Must get smaller */
502 /* result really should be -(auv-buv). as its negation
503 of true value, need to swap our result flag */
520 if (result <= (UV)IV_MIN)
523 /* result valid, but out of range for IV. */
528 } /* Overflow, drop through to NVs. */
535 /* left operand is undef, treat as zero. + 0.0 is identity. */
539 SETn( value + TOPn );
547 AV *av = PL_op->op_flags & OPf_SPECIAL ?
548 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
549 const U32 lval = PL_op->op_flags & OPf_MOD;
550 SV** svp = av_fetch(av, PL_op->op_private, lval);
551 SV *sv = (svp ? *svp : &PL_sv_undef);
553 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
554 sv = sv_mortalcopy(sv);
563 do_join(TARG, *MARK, MARK, SP);
574 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
575 * will be enough to hold an OP*.
577 SV* const sv = sv_newmortal();
578 sv_upgrade(sv, SVt_PVLV);
580 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
588 /* Oversized hot code. */
592 dVAR; dSP; dMARK; dORIGMARK;
598 if (PL_op->op_flags & OPf_STACKED)
603 if (gv && (io = GvIO(gv))
604 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
607 if (MARK == ORIGMARK) {
608 /* If using default handle then we need to make space to
609 * pass object as 1st arg, so move other args up ...
613 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
617 *MARK = SvTIED_obj((SV*)io, mg);
620 call_method("PRINT", G_SCALAR);
628 if (!(io = GvIO(gv))) {
629 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
630 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
632 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
633 report_evil_fh(gv, io, PL_op->op_type);
634 SETERRNO(EBADF,RMS_IFI);
637 else if (!(fp = IoOFP(io))) {
638 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
640 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
641 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
642 report_evil_fh(gv, io, PL_op->op_type);
644 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
649 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
651 if (!do_print(*MARK, fp))
655 if (!do_print(PL_ofs_sv, fp)) { /* $, */
664 if (!do_print(*MARK, fp))
672 if (PL_ors_sv && SvOK(PL_ors_sv))
673 if (!do_print(PL_ors_sv, fp)) /* $\ */
676 if (IoFLAGS(io) & IOf_FLUSH)
677 if (PerlIO_flush(fp) == EOF)
687 XPUSHs(&PL_sv_undef);
698 tryAMAGICunDEREF(to_av);
701 if (SvTYPE(av) != SVt_PVAV)
702 DIE(aTHX_ "Not an ARRAY reference");
703 if (PL_op->op_flags & OPf_REF) {
708 if (GIMME == G_SCALAR)
709 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
713 else if (PL_op->op_flags & OPf_MOD
714 && PL_op->op_private & OPpLVAL_INTRO)
715 Perl_croak(aTHX_ PL_no_localize_ref);
718 if (SvTYPE(sv) == SVt_PVAV) {
720 if (PL_op->op_flags & OPf_REF) {
725 if (GIMME == G_SCALAR)
726 Perl_croak(aTHX_ "Can't return array to lvalue"
735 if (SvTYPE(sv) != SVt_PVGV) {
736 if (SvGMAGICAL(sv)) {
742 if (PL_op->op_flags & OPf_REF ||
743 PL_op->op_private & HINT_STRICT_REFS)
744 DIE(aTHX_ PL_no_usym, "an ARRAY");
745 if (ckWARN(WARN_UNINITIALIZED))
747 if (GIMME == G_ARRAY) {
753 if ((PL_op->op_flags & OPf_SPECIAL) &&
754 !(PL_op->op_flags & OPf_MOD))
756 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
758 && (!is_gv_magical_sv(sv,0)
759 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
765 if (PL_op->op_private & HINT_STRICT_REFS)
766 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
767 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
774 if (PL_op->op_private & OPpLVAL_INTRO)
776 if (PL_op->op_flags & OPf_REF) {
781 if (GIMME == G_SCALAR)
782 Perl_croak(aTHX_ "Can't return array to lvalue"
790 if (GIMME == G_ARRAY) {
791 const I32 maxarg = AvFILL(av) + 1;
792 (void)POPs; /* XXXX May be optimized away? */
794 if (SvRMAGICAL(av)) {
796 for (i=0; i < (U32)maxarg; i++) {
797 SV **svp = av_fetch(av, i, FALSE);
798 /* See note in pp_helem, and bug id #27839 */
800 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
805 Copy(AvARRAY(av), SP+1, maxarg, SV*);
809 else if (GIMME_V == G_SCALAR) {
811 const I32 maxarg = AvFILL(av) + 1;
821 const I32 gimme = GIMME_V;
822 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
826 tryAMAGICunDEREF(to_hv);
829 if (SvTYPE(hv) != SVt_PVHV)
830 DIE(aTHX_ "Not a HASH reference");
831 if (PL_op->op_flags & OPf_REF) {
836 if (gimme != G_ARRAY)
837 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
841 else if (PL_op->op_flags & OPf_MOD
842 && PL_op->op_private & OPpLVAL_INTRO)
843 Perl_croak(aTHX_ PL_no_localize_ref);
846 if (SvTYPE(sv) == SVt_PVHV) {
848 if (PL_op->op_flags & OPf_REF) {
853 if (gimme != G_ARRAY)
854 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
862 if (SvTYPE(sv) != SVt_PVGV) {
863 if (SvGMAGICAL(sv)) {
869 if (PL_op->op_flags & OPf_REF ||
870 PL_op->op_private & HINT_STRICT_REFS)
871 DIE(aTHX_ PL_no_usym, "a HASH");
872 if (ckWARN(WARN_UNINITIALIZED))
874 if (gimme == G_ARRAY) {
880 if ((PL_op->op_flags & OPf_SPECIAL) &&
881 !(PL_op->op_flags & OPf_MOD))
883 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
885 && (!is_gv_magical_sv(sv,0)
886 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
892 if (PL_op->op_private & HINT_STRICT_REFS)
893 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
894 gv = (GV*)gv_fetchsv(sv, 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_ return_hash_to_lvalue_scalar );
916 if (gimme == G_ARRAY) { /* array wanted */
917 *PL_stack_sp = (SV*)hv;
920 else if (gimme == G_SCALAR) {
922 TARG = Perl_hv_scalar(aTHX_ hv);
929 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
935 if (ckWARN(WARN_MISC)) {
937 if (relem == firstrelem &&
939 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
940 SvTYPE(SvRV(*relem)) == SVt_PVHV))
942 err = "Reference found where even-sized list expected";
945 err = "Odd number of elements in hash assignment";
946 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
949 tmpstr = NEWSV(29,0);
950 didstore = hv_store_ent(hash,*relem,tmpstr,0);
951 if (SvMAGICAL(hash)) {
952 if (SvSMAGICAL(tmpstr))
964 SV **lastlelem = PL_stack_sp;
965 SV **lastrelem = PL_stack_base + POPMARK;
966 SV **firstrelem = PL_stack_base + POPMARK + 1;
967 SV **firstlelem = lastrelem + 1;
980 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
983 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
986 /* If there's a common identifier on both sides we have to take
987 * special care that assigning the identifier on the left doesn't
988 * clobber a value on the right that's used later in the list.
990 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
991 EXTEND_MORTAL(lastrelem - firstrelem + 1);
992 for (relem = firstrelem; relem <= lastrelem; relem++) {
994 TAINT_NOT; /* Each item is independent */
995 *relem = sv_mortalcopy(sv);
1005 while (lelem <= lastlelem) {
1006 TAINT_NOT; /* Each item stands on its own, taintwise. */
1008 switch (SvTYPE(sv)) {
1011 magic = SvMAGICAL(ary) != 0;
1013 av_extend(ary, lastrelem - relem);
1015 while (relem <= lastrelem) { /* gobble up all the rest */
1018 sv = newSVsv(*relem);
1020 didstore = av_store(ary,i++,sv);
1030 case SVt_PVHV: { /* normal hash */
1034 magic = SvMAGICAL(hash) != 0;
1036 firsthashrelem = relem;
1038 while (relem < lastrelem) { /* gobble up all the rest */
1043 sv = &PL_sv_no, relem++;
1044 tmpstr = NEWSV(29,0);
1046 sv_setsv(tmpstr,*relem); /* value */
1047 *(relem++) = tmpstr;
1048 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1049 /* key overwrites an existing entry */
1051 didstore = hv_store_ent(hash,sv,tmpstr,0);
1053 if (SvSMAGICAL(tmpstr))
1060 if (relem == lastrelem) {
1061 do_oddball(hash, relem, firstrelem);
1067 if (SvIMMORTAL(sv)) {
1068 if (relem <= lastrelem)
1072 if (relem <= lastrelem) {
1073 sv_setsv(sv, *relem);
1077 sv_setsv(sv, &PL_sv_undef);
1082 if (PL_delaymagic & ~DM_DELAY) {
1083 if (PL_delaymagic & DM_UID) {
1084 #ifdef HAS_SETRESUID
1085 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1086 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1089 # ifdef HAS_SETREUID
1090 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1091 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1094 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1095 (void)setruid(PL_uid);
1096 PL_delaymagic &= ~DM_RUID;
1098 # endif /* HAS_SETRUID */
1100 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1101 (void)seteuid(PL_euid);
1102 PL_delaymagic &= ~DM_EUID;
1104 # endif /* HAS_SETEUID */
1105 if (PL_delaymagic & DM_UID) {
1106 if (PL_uid != PL_euid)
1107 DIE(aTHX_ "No setreuid available");
1108 (void)PerlProc_setuid(PL_uid);
1110 # endif /* HAS_SETREUID */
1111 #endif /* HAS_SETRESUID */
1112 PL_uid = PerlProc_getuid();
1113 PL_euid = PerlProc_geteuid();
1115 if (PL_delaymagic & DM_GID) {
1116 #ifdef HAS_SETRESGID
1117 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1118 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1121 # ifdef HAS_SETREGID
1122 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1123 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1126 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1127 (void)setrgid(PL_gid);
1128 PL_delaymagic &= ~DM_RGID;
1130 # endif /* HAS_SETRGID */
1132 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1133 (void)setegid(PL_egid);
1134 PL_delaymagic &= ~DM_EGID;
1136 # endif /* HAS_SETEGID */
1137 if (PL_delaymagic & DM_GID) {
1138 if (PL_gid != PL_egid)
1139 DIE(aTHX_ "No setregid available");
1140 (void)PerlProc_setgid(PL_gid);
1142 # endif /* HAS_SETREGID */
1143 #endif /* HAS_SETRESGID */
1144 PL_gid = PerlProc_getgid();
1145 PL_egid = PerlProc_getegid();
1147 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1151 if (gimme == G_VOID)
1152 SP = firstrelem - 1;
1153 else if (gimme == G_SCALAR) {
1156 SETi(lastrelem - firstrelem + 1 - duplicates);
1163 /* Removes from the stack the entries which ended up as
1164 * duplicated keys in the hash (fix for [perl #24380]) */
1165 Move(firsthashrelem + duplicates,
1166 firsthashrelem, duplicates, SV**);
1167 lastrelem -= duplicates;
1172 SP = firstrelem + (lastlelem - firstlelem);
1173 lelem = firstlelem + (relem - firstrelem);
1175 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1183 register PMOP * const pm = cPMOP;
1184 SV * const rv = sv_newmortal();
1185 SV * const sv = newSVrv(rv, "Regexp");
1186 if (pm->op_pmdynflags & PMdf_TAINTED)
1188 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1195 register PMOP *pm = cPMOP;
1197 register const char *t;
1198 register const char *s;
1201 I32 r_flags = REXEC_CHECKED;
1202 const char *truebase; /* Start of string */
1203 register REGEXP *rx = PM_GETRE(pm);
1205 const I32 gimme = GIMME;
1208 const I32 oldsave = PL_savestack_ix;
1209 I32 update_minmatch = 1;
1210 I32 had_zerolen = 0;
1212 if (PL_op->op_flags & OPf_STACKED)
1214 else if (PL_op->op_private & OPpTARGET_MY)
1221 PUTBACK; /* EVAL blocks need stack_sp. */
1222 s = SvPV_const(TARG, len);
1224 DIE(aTHX_ "panic: pp_match");
1226 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1227 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1230 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1232 /* PMdf_USED is set after a ?? matches once */
1233 if (pm->op_pmdynflags & PMdf_USED) {
1235 if (gimme == G_ARRAY)
1240 /* empty pattern special-cased to use last successful pattern if possible */
1241 if (!rx->prelen && PL_curpm) {
1246 if (rx->minlen > (I32)len)
1251 /* XXXX What part of this is needed with true \G-support? */
1252 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1254 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1255 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1256 if (mg && mg->mg_len >= 0) {
1257 if (!(rx->reganch & ROPT_GPOS_SEEN))
1258 rx->endp[0] = rx->startp[0] = mg->mg_len;
1259 else if (rx->reganch & ROPT_ANCH_GPOS) {
1260 r_flags |= REXEC_IGNOREPOS;
1261 rx->endp[0] = rx->startp[0] = mg->mg_len;
1263 minmatch = (mg->mg_flags & MGf_MINMATCH);
1264 update_minmatch = 0;
1268 if ((!global && rx->nparens)
1269 || SvTEMP(TARG) || PL_sawampersand)
1270 r_flags |= REXEC_COPY_STR;
1272 r_flags |= REXEC_SCREAM;
1275 if (global && rx->startp[0] != -1) {
1276 t = s = rx->endp[0] + truebase;
1277 if ((s + rx->minlen) > strend)
1279 if (update_minmatch++)
1280 minmatch = had_zerolen;
1282 if (rx->reganch & RE_USE_INTUIT &&
1283 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1284 /* FIXME - can PL_bostr be made const char *? */
1285 PL_bostr = (char *)truebase;
1286 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1290 if ( (rx->reganch & ROPT_CHECK_ALL)
1292 && ((rx->reganch & ROPT_NOSCAN)
1293 || !((rx->reganch & RE_INTUIT_TAIL)
1294 && (r_flags & REXEC_SCREAM)))
1295 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1298 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1301 if (dynpm->op_pmflags & PMf_ONCE)
1302 dynpm->op_pmdynflags |= PMdf_USED;
1311 RX_MATCH_TAINTED_on(rx);
1312 TAINT_IF(RX_MATCH_TAINTED(rx));
1313 if (gimme == G_ARRAY) {
1314 const I32 nparens = rx->nparens;
1315 I32 i = (global && !nparens) ? 1 : 0;
1317 SPAGAIN; /* EVAL blocks could move the stack. */
1318 EXTEND(SP, nparens + i);
1319 EXTEND_MORTAL(nparens + i);
1320 for (i = !i; i <= nparens; i++) {
1321 PUSHs(sv_newmortal());
1322 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1323 const I32 len = rx->endp[i] - rx->startp[i];
1324 s = rx->startp[i] + truebase;
1325 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1326 len < 0 || len > strend - s)
1327 DIE(aTHX_ "panic: pp_match start/end pointers");
1328 sv_setpvn(*SP, s, len);
1329 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1334 if (dynpm->op_pmflags & PMf_CONTINUE) {
1336 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1337 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1339 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1340 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1342 if (rx->startp[0] != -1) {
1343 mg->mg_len = rx->endp[0];
1344 if (rx->startp[0] == rx->endp[0])
1345 mg->mg_flags |= MGf_MINMATCH;
1347 mg->mg_flags &= ~MGf_MINMATCH;
1350 had_zerolen = (rx->startp[0] != -1
1351 && rx->startp[0] == rx->endp[0]);
1352 PUTBACK; /* EVAL blocks may use stack */
1353 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1358 LEAVE_SCOPE(oldsave);
1364 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1365 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1367 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1368 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1370 if (rx->startp[0] != -1) {
1371 mg->mg_len = rx->endp[0];
1372 if (rx->startp[0] == rx->endp[0])
1373 mg->mg_flags |= MGf_MINMATCH;
1375 mg->mg_flags &= ~MGf_MINMATCH;
1378 LEAVE_SCOPE(oldsave);
1382 yup: /* Confirmed by INTUIT */
1384 RX_MATCH_TAINTED_on(rx);
1385 TAINT_IF(RX_MATCH_TAINTED(rx));
1387 if (dynpm->op_pmflags & PMf_ONCE)
1388 dynpm->op_pmdynflags |= PMdf_USED;
1389 if (RX_MATCH_COPIED(rx))
1390 Safefree(rx->subbeg);
1391 RX_MATCH_COPIED_off(rx);
1392 rx->subbeg = Nullch;
1394 /* FIXME - should rx->subbeg be const char *? */
1395 rx->subbeg = (char *) truebase;
1396 rx->startp[0] = s - truebase;
1397 if (RX_MATCH_UTF8(rx)) {
1398 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1399 rx->endp[0] = t - truebase;
1402 rx->endp[0] = s - truebase + rx->minlen;
1404 rx->sublen = strend - truebase;
1407 if (PL_sawampersand) {
1409 #ifdef PERL_OLD_COPY_ON_WRITE
1410 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1412 PerlIO_printf(Perl_debug_log,
1413 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1414 (int) SvTYPE(TARG), truebase, t,
1417 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1418 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1419 assert (SvPOKp(rx->saved_copy));
1424 rx->subbeg = savepvn(t, strend - t);
1425 #ifdef PERL_OLD_COPY_ON_WRITE
1426 rx->saved_copy = Nullsv;
1429 rx->sublen = strend - t;
1430 RX_MATCH_COPIED_on(rx);
1431 off = rx->startp[0] = s - t;
1432 rx->endp[0] = off + rx->minlen;
1434 else { /* startp/endp are used by @- @+. */
1435 rx->startp[0] = s - truebase;
1436 rx->endp[0] = s - truebase + rx->minlen;
1438 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1439 LEAVE_SCOPE(oldsave);
1444 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1445 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1446 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1451 LEAVE_SCOPE(oldsave);
1452 if (gimme == G_ARRAY)
1458 Perl_do_readline(pTHX)
1460 dVAR; dSP; dTARGETSTACKED;
1465 register IO * const io = GvIO(PL_last_in_gv);
1466 register const I32 type = PL_op->op_type;
1467 const I32 gimme = GIMME_V;
1470 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1472 XPUSHs(SvTIED_obj((SV*)io, mg));
1475 call_method("READLINE", gimme);
1478 if (gimme == G_SCALAR) {
1480 SvSetSV_nosteal(TARG, result);
1489 if (IoFLAGS(io) & IOf_ARGV) {
1490 if (IoFLAGS(io) & IOf_START) {
1492 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1493 IoFLAGS(io) &= ~IOf_START;
1494 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1495 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1496 SvSETMAGIC(GvSV(PL_last_in_gv));
1501 fp = nextargv(PL_last_in_gv);
1502 if (!fp) { /* Note: fp != IoIFP(io) */
1503 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1506 else if (type == OP_GLOB)
1507 fp = Perl_start_glob(aTHX_ POPs, io);
1509 else if (type == OP_GLOB)
1511 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1512 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1516 if ((!io || !(IoFLAGS(io) & IOf_START))
1517 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1519 if (type == OP_GLOB)
1520 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1521 "glob failed (can't start child: %s)",
1524 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1526 if (gimme == G_SCALAR) {
1527 /* undef TARG, and push that undefined value */
1528 if (type != OP_RCATLINE) {
1529 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1537 if (gimme == G_SCALAR) {
1541 SvUPGRADE(sv, SVt_PV);
1542 tmplen = SvLEN(sv); /* remember if already alloced */
1543 if (!tmplen && !SvREADONLY(sv))
1544 Sv_Grow(sv, 80); /* try short-buffering it */
1546 if (type == OP_RCATLINE && SvOK(sv)) {
1548 SvPV_force_nolen(sv);
1554 sv = sv_2mortal(NEWSV(57, 80));
1558 /* This should not be marked tainted if the fp is marked clean */
1559 #define MAYBE_TAINT_LINE(io, sv) \
1560 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1565 /* delay EOF state for a snarfed empty file */
1566 #define SNARF_EOF(gimme,rs,io,sv) \
1567 (gimme != G_SCALAR || SvCUR(sv) \
1568 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1572 if (!sv_gets(sv, fp, offset)
1574 || SNARF_EOF(gimme, PL_rs, io, sv)
1575 || PerlIO_error(fp)))
1577 PerlIO_clearerr(fp);
1578 if (IoFLAGS(io) & IOf_ARGV) {
1579 fp = nextargv(PL_last_in_gv);
1582 (void)do_close(PL_last_in_gv, FALSE);
1584 else if (type == OP_GLOB) {
1585 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1586 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1587 "glob failed (child exited with status %d%s)",
1588 (int)(STATUS_CURRENT >> 8),
1589 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1592 if (gimme == G_SCALAR) {
1593 if (type != OP_RCATLINE) {
1594 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1600 MAYBE_TAINT_LINE(io, sv);
1603 MAYBE_TAINT_LINE(io, sv);
1605 IoFLAGS(io) |= IOf_NOLINE;
1609 if (type == OP_GLOB) {
1613 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1614 tmps = SvEND(sv) - 1;
1615 if (*tmps == *SvPVX_const(PL_rs)) {
1617 SvCUR_set(sv, SvCUR(sv) - 1);
1620 for (t1 = SvPVX_const(sv); *t1; t1++)
1621 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1622 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1624 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1625 (void)POPs; /* Unmatched wildcard? Chuck it... */
1628 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1629 const U8 *s = (const U8*)SvPVX_const(sv) + offset;
1630 const STRLEN len = SvCUR(sv) - offset;
1633 if (ckWARN(WARN_UTF8) &&
1634 !is_utf8_string_loc(s, len, &f))
1635 /* Emulate :encoding(utf8) warning in the same case. */
1636 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1637 "utf8 \"\\x%02X\" does not map to Unicode",
1638 f < (U8*)SvEND(sv) ? *f : 0);
1640 if (gimme == G_ARRAY) {
1641 if (SvLEN(sv) - SvCUR(sv) > 20) {
1642 SvPV_shrink_to_cur(sv);
1644 sv = sv_2mortal(NEWSV(58, 80));
1647 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1648 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1649 const STRLEN new_len
1650 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1651 SvPV_renew(sv, new_len);
1660 register PERL_CONTEXT *cx;
1661 I32 gimme = OP_GIMME(PL_op, -1);
1664 if (cxstack_ix >= 0)
1665 gimme = cxstack[cxstack_ix].blk_gimme;
1673 PUSHBLOCK(cx, CXt_BLOCK, SP);
1685 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1686 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1688 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1691 if (SvTYPE(hv) == SVt_PVHV) {
1692 if (PL_op->op_private & OPpLVAL_INTRO) {
1695 /* does the element we're localizing already exist? */
1697 /* can we determine whether it exists? */
1699 || mg_find((SV*)hv, PERL_MAGIC_env)
1700 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1701 /* Try to preserve the existenceness of a tied hash
1702 * element by using EXISTS and DELETE if possible.
1703 * Fallback to FETCH and STORE otherwise */
1704 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1705 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1706 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1708 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1711 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1712 svp = he ? &HeVAL(he) : 0;
1718 if (!svp || *svp == &PL_sv_undef) {
1722 DIE(aTHX_ PL_no_helem_sv, keysv);
1724 lv = sv_newmortal();
1725 sv_upgrade(lv, SVt_PVLV);
1727 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1728 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1729 LvTARG(lv) = SvREFCNT_inc(hv);
1734 if (PL_op->op_private & OPpLVAL_INTRO) {
1735 if (HvNAME_get(hv) && isGV(*svp))
1736 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1740 const char * const key = SvPV_const(keysv, keylen);
1741 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1743 save_helem(hv, keysv, svp);
1746 else if (PL_op->op_private & OPpDEREF)
1747 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1749 sv = (svp ? *svp : &PL_sv_undef);
1750 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1751 * Pushing the magical RHS on to the stack is useless, since
1752 * that magic is soon destined to be misled by the local(),
1753 * and thus the later pp_sassign() will fail to mg_get() the
1754 * old value. This should also cure problems with delayed
1755 * mg_get()s. GSAR 98-07-03 */
1756 if (!lval && SvGMAGICAL(sv))
1757 sv = sv_mortalcopy(sv);
1765 register PERL_CONTEXT *cx;
1770 if (PL_op->op_flags & OPf_SPECIAL) {
1771 cx = &cxstack[cxstack_ix];
1772 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1777 gimme = OP_GIMME(PL_op, -1);
1779 if (cxstack_ix >= 0)
1780 gimme = cxstack[cxstack_ix].blk_gimme;
1786 if (gimme == G_VOID)
1788 else if (gimme == G_SCALAR) {
1792 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1795 *MARK = sv_mortalcopy(TOPs);
1798 *MARK = &PL_sv_undef;
1802 else if (gimme == G_ARRAY) {
1803 /* in case LEAVE wipes old return values */
1805 for (mark = newsp + 1; mark <= SP; mark++) {
1806 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1807 *mark = sv_mortalcopy(*mark);
1808 TAINT_NOT; /* Each item is independent */
1812 PL_curpm = newpm; /* Don't pop $1 et al till now */
1822 register PERL_CONTEXT *cx;
1828 cx = &cxstack[cxstack_ix];
1829 if (CxTYPE(cx) != CXt_LOOP)
1830 DIE(aTHX_ "panic: pp_iter");
1832 itersvp = CxITERVAR(cx);
1833 av = cx->blk_loop.iterary;
1834 if (SvTYPE(av) != SVt_PVAV) {
1835 /* iterate ($min .. $max) */
1836 if (cx->blk_loop.iterlval) {
1837 /* string increment */
1838 register SV* cur = cx->blk_loop.iterlval;
1840 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1841 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1842 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1843 /* safe to reuse old SV */
1844 sv_setsv(*itersvp, cur);
1848 /* we need a fresh SV every time so that loop body sees a
1849 * completely new SV for closures/references to work as
1852 *itersvp = newSVsv(cur);
1853 SvREFCNT_dec(oldsv);
1855 if (strEQ(SvPVX_const(cur), max))
1856 sv_setiv(cur, 0); /* terminate next time */
1863 /* integer increment */
1864 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1867 /* don't risk potential race */
1868 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1869 /* safe to reuse old SV */
1870 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1874 /* we need a fresh SV every time so that loop body sees a
1875 * completely new SV for closures/references to work as they
1878 *itersvp = newSViv(cx->blk_loop.iterix++);
1879 SvREFCNT_dec(oldsv);
1885 if (PL_op->op_private & OPpITER_REVERSED) {
1886 /* In reverse, use itermax as the min :-) */
1887 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1890 if (SvMAGICAL(av) || AvREIFY(av)) {
1891 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1898 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1902 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1906 if (SvMAGICAL(av) || AvREIFY(av)) {
1907 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1914 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1918 if (sv && SvREFCNT(sv) == 0) {
1920 Perl_croak(aTHX_ "Use of freed value in iteration");
1927 if (av != PL_curstack && sv == &PL_sv_undef) {
1928 SV *lv = cx->blk_loop.iterlval;
1929 if (lv && SvREFCNT(lv) > 1) {
1934 SvREFCNT_dec(LvTARG(lv));
1936 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1937 sv_upgrade(lv, SVt_PVLV);
1939 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1941 LvTARG(lv) = SvREFCNT_inc(av);
1942 LvTARGOFF(lv) = cx->blk_loop.iterix;
1943 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1948 *itersvp = SvREFCNT_inc(sv);
1949 SvREFCNT_dec(oldsv);
1957 register PMOP *pm = cPMOP;
1973 register REGEXP *rx = PM_GETRE(pm);
1975 int force_on_match = 0;
1976 I32 oldsave = PL_savestack_ix;
1978 bool doutf8 = FALSE;
1979 #ifdef PERL_OLD_COPY_ON_WRITE
1984 /* known replacement string? */
1985 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1986 if (PL_op->op_flags & OPf_STACKED)
1988 else if (PL_op->op_private & OPpTARGET_MY)
1995 #ifdef PERL_OLD_COPY_ON_WRITE
1996 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1997 because they make integers such as 256 "false". */
1998 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2001 sv_force_normal_flags(TARG,0);
2004 #ifdef PERL_OLD_COPY_ON_WRITE
2008 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2009 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2010 DIE(aTHX_ PL_no_modify);
2013 s = SvPV_mutable(TARG, len);
2014 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2016 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2017 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2022 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2026 DIE(aTHX_ "panic: pp_subst");
2029 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2030 maxiters = 2 * slen + 10; /* We can match twice at each
2031 position, once with zero-length,
2032 second time with non-zero. */
2034 if (!rx->prelen && PL_curpm) {
2038 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2039 ? REXEC_COPY_STR : 0;
2041 r_flags |= REXEC_SCREAM;
2044 if (rx->reganch & RE_USE_INTUIT) {
2046 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2050 /* How to do it in subst? */
2051 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2053 && ((rx->reganch & ROPT_NOSCAN)
2054 || !((rx->reganch & RE_INTUIT_TAIL)
2055 && (r_flags & REXEC_SCREAM))))
2060 /* only replace once? */
2061 once = !(rpm->op_pmflags & PMf_GLOBAL);
2063 /* known replacement string? */
2065 /* replacement needing upgrading? */
2066 if (DO_UTF8(TARG) && !doutf8) {
2067 nsv = sv_newmortal();
2070 sv_recode_to_utf8(nsv, PL_encoding);
2072 sv_utf8_upgrade(nsv);
2073 c = SvPV_const(nsv, clen);
2077 c = SvPV_const(dstr, clen);
2078 doutf8 = DO_UTF8(dstr);
2086 /* can do inplace substitution? */
2088 #ifdef PERL_OLD_COPY_ON_WRITE
2091 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2092 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2093 && (!doutf8 || SvUTF8(TARG))) {
2094 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2095 r_flags | REXEC_CHECKED))
2099 LEAVE_SCOPE(oldsave);
2102 #ifdef PERL_OLD_COPY_ON_WRITE
2103 if (SvIsCOW(TARG)) {
2104 assert (!force_on_match);
2108 if (force_on_match) {
2110 s = SvPV_force(TARG, len);
2115 SvSCREAM_off(TARG); /* disable possible screamer */
2117 rxtainted |= RX_MATCH_TAINTED(rx);
2118 m = orig + rx->startp[0];
2119 d = orig + rx->endp[0];
2121 if (m - s > strend - d) { /* faster to shorten from end */
2123 Copy(c, m, clen, char);
2128 Move(d, m, i, char);
2132 SvCUR_set(TARG, m - s);
2134 else if ((i = m - s)) { /* faster from front */
2142 Copy(c, m, clen, char);
2147 Copy(c, d, clen, char);
2152 TAINT_IF(rxtainted & 1);
2158 if (iters++ > maxiters)
2159 DIE(aTHX_ "Substitution loop");
2160 rxtainted |= RX_MATCH_TAINTED(rx);
2161 m = rx->startp[0] + orig;
2164 Move(s, d, i, char);
2168 Copy(c, d, clen, char);
2171 s = rx->endp[0] + orig;
2172 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2174 /* don't match same null twice */
2175 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2178 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2179 Move(s, d, i+1, char); /* include the NUL */
2181 TAINT_IF(rxtainted & 1);
2183 PUSHs(sv_2mortal(newSViv((I32)iters)));
2185 (void)SvPOK_only_UTF8(TARG);
2186 TAINT_IF(rxtainted);
2187 if (SvSMAGICAL(TARG)) {
2195 LEAVE_SCOPE(oldsave);
2199 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2200 r_flags | REXEC_CHECKED))
2202 if (force_on_match) {
2204 s = SvPV_force(TARG, len);
2207 #ifdef PERL_OLD_COPY_ON_WRITE
2210 rxtainted |= RX_MATCH_TAINTED(rx);
2211 dstr = newSVpvn(m, s-m);
2216 register PERL_CONTEXT *cx;
2218 (void)ReREFCNT_inc(rx);
2220 RETURNOP(cPMOP->op_pmreplroot);
2222 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2224 if (iters++ > maxiters)
2225 DIE(aTHX_ "Substitution loop");
2226 rxtainted |= RX_MATCH_TAINTED(rx);
2227 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2232 strend = s + (strend - m);
2234 m = rx->startp[0] + orig;
2235 if (doutf8 && !SvUTF8(dstr))
2236 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2238 sv_catpvn(dstr, s, m-s);
2239 s = rx->endp[0] + orig;
2241 sv_catpvn(dstr, c, clen);
2244 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2245 TARG, NULL, r_flags));
2246 if (doutf8 && !DO_UTF8(TARG))
2247 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2249 sv_catpvn(dstr, s, strend - s);
2251 #ifdef PERL_OLD_COPY_ON_WRITE
2252 /* The match may make the string COW. If so, brilliant, because that's
2253 just saved us one malloc, copy and free - the regexp has donated
2254 the old buffer, and we malloc an entirely new one, rather than the
2255 regexp malloc()ing a buffer and copying our original, only for
2256 us to throw it away here during the substitution. */
2257 if (SvIsCOW(TARG)) {
2258 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2264 SvPV_set(TARG, SvPVX(dstr));
2265 SvCUR_set(TARG, SvCUR(dstr));
2266 SvLEN_set(TARG, SvLEN(dstr));
2267 doutf8 |= DO_UTF8(dstr);
2268 SvPV_set(dstr, (char*)0);
2271 TAINT_IF(rxtainted & 1);
2273 PUSHs(sv_2mortal(newSViv((I32)iters)));
2275 (void)SvPOK_only(TARG);
2278 TAINT_IF(rxtainted);
2281 LEAVE_SCOPE(oldsave);
2290 LEAVE_SCOPE(oldsave);
2299 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2300 ++*PL_markstack_ptr;
2301 LEAVE; /* exit inner scope */
2304 if (PL_stack_base + *PL_markstack_ptr > SP) {
2306 const I32 gimme = GIMME_V;
2308 LEAVE; /* exit outer scope */
2309 (void)POPMARK; /* pop src */
2310 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2311 (void)POPMARK; /* pop dst */
2312 SP = PL_stack_base + POPMARK; /* pop original mark */
2313 if (gimme == G_SCALAR) {
2314 if (PL_op->op_private & OPpGREP_LEX) {
2315 SV* const sv = sv_newmortal();
2316 sv_setiv(sv, items);
2324 else if (gimme == G_ARRAY)
2331 ENTER; /* enter inner scope */
2334 src = PL_stack_base[*PL_markstack_ptr];
2336 if (PL_op->op_private & OPpGREP_LEX)
2337 PAD_SVl(PL_op->op_targ) = src;
2341 RETURNOP(cLOGOP->op_other);
2352 register PERL_CONTEXT *cx;
2355 if (CxMULTICALL(&cxstack[cxstack_ix]))
2359 cxstack_ix++; /* temporarily protect top context */
2362 if (gimme == G_SCALAR) {
2365 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2367 *MARK = SvREFCNT_inc(TOPs);
2372 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2374 *MARK = sv_mortalcopy(sv);
2379 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2383 *MARK = &PL_sv_undef;
2387 else if (gimme == G_ARRAY) {
2388 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2389 if (!SvTEMP(*MARK)) {
2390 *MARK = sv_mortalcopy(*MARK);
2391 TAINT_NOT; /* Each item is independent */
2399 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2400 PL_curpm = newpm; /* ... and pop $1 et al */
2403 return cx->blk_sub.retop;
2406 /* This duplicates the above code because the above code must not
2407 * get any slower by more conditions */
2415 register PERL_CONTEXT *cx;
2418 if (CxMULTICALL(&cxstack[cxstack_ix]))
2422 cxstack_ix++; /* temporarily protect top context */
2426 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2427 /* We are an argument to a function or grep().
2428 * This kind of lvalueness was legal before lvalue
2429 * subroutines too, so be backward compatible:
2430 * cannot report errors. */
2432 /* Scalar context *is* possible, on the LHS of -> only,
2433 * as in f()->meth(). But this is not an lvalue. */
2434 if (gimme == G_SCALAR)
2436 if (gimme == G_ARRAY) {
2437 if (!CvLVALUE(cx->blk_sub.cv))
2438 goto temporise_array;
2439 EXTEND_MORTAL(SP - newsp);
2440 for (mark = newsp + 1; mark <= SP; mark++) {
2443 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2444 *mark = sv_mortalcopy(*mark);
2446 /* Can be a localized value subject to deletion. */
2447 PL_tmps_stack[++PL_tmps_ix] = *mark;
2448 (void)SvREFCNT_inc(*mark);
2453 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2454 /* Here we go for robustness, not for speed, so we change all
2455 * the refcounts so the caller gets a live guy. Cannot set
2456 * TEMP, so sv_2mortal is out of question. */
2457 if (!CvLVALUE(cx->blk_sub.cv)) {
2463 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2465 if (gimme == G_SCALAR) {
2469 /* Temporaries are bad unless they happen to be elements
2470 * of a tied hash or array */
2471 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2472 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2478 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2479 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2480 : "a readonly value" : "a temporary");
2482 else { /* Can be a localized value
2483 * subject to deletion. */
2484 PL_tmps_stack[++PL_tmps_ix] = *mark;
2485 (void)SvREFCNT_inc(*mark);
2488 else { /* Should not happen? */
2494 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2495 (MARK > SP ? "Empty array" : "Array"));
2499 else if (gimme == G_ARRAY) {
2500 EXTEND_MORTAL(SP - newsp);
2501 for (mark = newsp + 1; mark <= SP; mark++) {
2502 if (*mark != &PL_sv_undef
2503 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2504 /* Might be flattened array after $#array = */
2511 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2512 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2515 /* Can be a localized value subject to deletion. */
2516 PL_tmps_stack[++PL_tmps_ix] = *mark;
2517 (void)SvREFCNT_inc(*mark);
2523 if (gimme == G_SCALAR) {
2527 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2529 *MARK = SvREFCNT_inc(TOPs);
2534 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2536 *MARK = sv_mortalcopy(sv);
2541 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2545 *MARK = &PL_sv_undef;
2549 else if (gimme == G_ARRAY) {
2551 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2552 if (!SvTEMP(*MARK)) {
2553 *MARK = sv_mortalcopy(*MARK);
2554 TAINT_NOT; /* Each item is independent */
2563 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2564 PL_curpm = newpm; /* ... and pop $1 et al */
2567 return cx->blk_sub.retop;
2572 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2574 SV *dbsv = GvSVn(PL_DBsub);
2577 if (!PERLDB_SUB_NN) {
2580 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2581 || strEQ(GvNAME(gv), "END")
2582 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2583 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2584 && (gv = (GV*)*svp) ))) {
2585 /* Use GV from the stack as a fallback. */
2586 /* GV is potentially non-unique, or contain different CV. */
2587 SV * const tmp = newRV((SV*)cv);
2588 sv_setsv(dbsv, tmp);
2592 gv_efullname3(dbsv, gv, Nullch);
2596 const int type = SvTYPE(dbsv);
2597 if (type < SVt_PVIV && type != SVt_IV)
2598 sv_upgrade(dbsv, SVt_PVIV);
2599 (void)SvIOK_on(dbsv);
2600 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2604 PL_curcopdb = PL_curcop;
2605 cv = GvCV(PL_DBsub);
2615 register PERL_CONTEXT *cx;
2617 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2620 DIE(aTHX_ "Not a CODE reference");
2621 switch (SvTYPE(sv)) {
2622 /* This is overwhelming the most common case: */
2624 if (!(cv = GvCVu((GV*)sv)))
2625 cv = sv_2cv(sv, &stash, &gv, FALSE);
2635 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2637 SP = PL_stack_base + POPMARK;
2640 if (SvGMAGICAL(sv)) {
2644 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2647 sym = SvPV_nolen_const(sv);
2650 DIE(aTHX_ PL_no_usym, "a subroutine");
2651 if (PL_op->op_private & HINT_STRICT_REFS)
2652 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2653 cv = get_cv(sym, TRUE);
2658 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2659 tryAMAGICunDEREF(to_cv);
2662 if (SvTYPE(cv) == SVt_PVCV)
2667 DIE(aTHX_ "Not a CODE reference");
2668 /* This is the second most common case: */
2678 if (!CvROOT(cv) && !CvXSUB(cv)) {
2683 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2684 if (CvASSERTION(cv) && PL_DBassertion)
2685 sv_setiv(PL_DBassertion, 1);
2687 cv = get_db_sub(&sv, cv);
2688 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2689 DIE(aTHX_ "No DB::sub routine defined");
2692 if (!(CvXSUB(cv))) {
2693 /* This path taken at least 75% of the time */
2695 register I32 items = SP - MARK;
2696 AV* padlist = CvPADLIST(cv);
2697 PUSHBLOCK(cx, CXt_SUB, MARK);
2699 cx->blk_sub.retop = PL_op->op_next;
2701 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2702 * that eval'' ops within this sub know the correct lexical space.
2703 * Owing the speed considerations, we choose instead to search for
2704 * the cv using find_runcv() when calling doeval().
2706 if (CvDEPTH(cv) >= 2) {
2707 PERL_STACK_OVERFLOW_CHECK();
2708 pad_push(padlist, CvDEPTH(cv));
2711 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2716 DEBUG_S(PerlIO_printf(Perl_debug_log,
2717 "%p entersub preparing @_\n", thr));
2719 av = (AV*)PAD_SVl(0);
2721 /* @_ is normally not REAL--this should only ever
2722 * happen when DB::sub() calls things that modify @_ */
2727 cx->blk_sub.savearray = GvAV(PL_defgv);
2728 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2729 CX_CURPAD_SAVE(cx->blk_sub);
2730 cx->blk_sub.argarray = av;
2733 if (items > AvMAX(av) + 1) {
2734 SV **ary = AvALLOC(av);
2735 if (AvARRAY(av) != ary) {
2736 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2737 SvPV_set(av, (char*)ary);
2739 if (items > AvMAX(av) + 1) {
2740 AvMAX(av) = items - 1;
2741 Renew(ary,items,SV*);
2743 SvPV_set(av, (char*)ary);
2746 Copy(MARK,AvARRAY(av),items,SV*);
2747 AvFILLp(av) = items - 1;
2755 /* warning must come *after* we fully set up the context
2756 * stuff so that __WARN__ handlers can safely dounwind()
2759 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2760 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2761 sub_crush_depth(cv);
2763 DEBUG_S(PerlIO_printf(Perl_debug_log,
2764 "%p entersub returning %p\n", thr, CvSTART(cv)));
2766 RETURNOP(CvSTART(cv));
2769 #ifdef PERL_XSUB_OLDSTYLE
2770 if (CvOLDSTYLE(cv)) {
2771 I32 (*fp3)(int,int,int);
2773 register I32 items = SP - MARK;
2774 /* We dont worry to copy from @_. */
2779 PL_stack_sp = mark + 1;
2780 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2781 items = (*fp3)(CvXSUBANY(cv).any_i32,
2782 MARK - PL_stack_base + 1,
2784 PL_stack_sp = PL_stack_base + items;
2787 #endif /* PERL_XSUB_OLDSTYLE */
2789 I32 markix = TOPMARK;
2794 /* Need to copy @_ to stack. Alternative may be to
2795 * switch stack to @_, and copy return values
2796 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2797 AV * const av = GvAV(PL_defgv);
2798 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2801 /* Mark is at the end of the stack. */
2803 Copy(AvARRAY(av), SP + 1, items, SV*);
2808 /* We assume first XSUB in &DB::sub is the called one. */
2810 SAVEVPTR(PL_curcop);
2811 PL_curcop = PL_curcopdb;
2814 /* Do we need to open block here? XXXX */
2815 (void)(*CvXSUB(cv))(aTHX_ cv);
2817 /* Enforce some sanity in scalar context. */
2818 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2819 if (markix > PL_stack_sp - PL_stack_base)
2820 *(PL_stack_base + markix) = &PL_sv_undef;
2822 *(PL_stack_base + markix) = *PL_stack_sp;
2823 PL_stack_sp = PL_stack_base + markix;
2831 assert (0); /* Cannot get here. */
2832 /* This is deliberately moved here as spaghetti code to keep it out of the
2839 /* anonymous or undef'd function leaves us no recourse */
2840 if (CvANON(cv) || !(gv = CvGV(cv)))
2841 DIE(aTHX_ "Undefined subroutine called");
2843 /* autoloaded stub? */
2844 if (cv != GvCV(gv)) {
2847 /* should call AUTOLOAD now? */
2850 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2857 sub_name = sv_newmortal();
2858 gv_efullname3(sub_name, gv, Nullch);
2859 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2863 DIE(aTHX_ "Not a CODE reference");
2869 Perl_sub_crush_depth(pTHX_ CV *cv)
2872 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2874 SV* const tmpstr = sv_newmortal();
2875 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2876 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2885 SV* const elemsv = POPs;
2886 IV elem = SvIV(elemsv);
2888 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2889 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2892 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2893 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2895 elem -= PL_curcop->cop_arybase;
2896 if (SvTYPE(av) != SVt_PVAV)
2898 svp = av_fetch(av, elem, lval && !defer);
2900 #ifdef PERL_MALLOC_WRAP
2901 if (SvUOK(elemsv)) {
2902 const UV uv = SvUV(elemsv);
2903 elem = uv > IV_MAX ? IV_MAX : uv;
2905 else if (SvNOK(elemsv))
2906 elem = (IV)SvNV(elemsv);
2908 static const char oom_array_extend[] =
2909 "Out of memory during array extend"; /* Duplicated in av.c */
2910 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2913 if (!svp || *svp == &PL_sv_undef) {
2916 DIE(aTHX_ PL_no_aelem, elem);
2917 lv = sv_newmortal();
2918 sv_upgrade(lv, SVt_PVLV);
2920 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2921 LvTARG(lv) = SvREFCNT_inc(av);
2922 LvTARGOFF(lv) = elem;
2927 if (PL_op->op_private & OPpLVAL_INTRO)
2928 save_aelem(av, elem, svp);
2929 else if (PL_op->op_private & OPpDEREF)
2930 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2932 sv = (svp ? *svp : &PL_sv_undef);
2933 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2934 sv = sv_mortalcopy(sv);
2940 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2945 Perl_croak(aTHX_ PL_no_modify);
2946 if (SvTYPE(sv) < SVt_RV)
2947 sv_upgrade(sv, SVt_RV);
2948 else if (SvTYPE(sv) >= SVt_PV) {
2955 SvRV_set(sv, NEWSV(355,0));
2958 SvRV_set(sv, (SV*)newAV());
2961 SvRV_set(sv, (SV*)newHV());
2972 SV* const sv = TOPs;
2975 SV* const rsv = SvRV(sv);
2976 if (SvTYPE(rsv) == SVt_PVCV) {
2982 SETs(method_common(sv, Null(U32*)));
2989 SV* const sv = cSVOP_sv;
2990 U32 hash = SvSHARED_HASH(sv);
2992 XPUSHs(method_common(sv, &hash));
2997 S_method_common(pTHX_ SV* meth, U32* hashp)
3003 const char* packname = Nullch;
3004 SV *packsv = Nullsv;
3006 const char * const name = SvPV_const(meth, namelen);
3007 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3010 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3018 /* this isn't a reference */
3019 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3020 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3022 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3029 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3030 !(ob=(SV*)GvIO(iogv)))
3032 /* this isn't the name of a filehandle either */
3034 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3035 ? !isIDFIRST_utf8((U8*)packname)
3036 : !isIDFIRST(*packname)
3039 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3040 SvOK(sv) ? "without a package or object reference"
3041 : "on an undefined value");
3043 /* assume it's a package name */
3044 stash = gv_stashpvn(packname, packlen, FALSE);
3048 SV* ref = newSViv(PTR2IV(stash));
3049 hv_store(PL_stashcache, packname, packlen, ref, 0);
3053 /* it _is_ a filehandle name -- replace with a reference */
3054 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3057 /* if we got here, ob should be a reference or a glob */
3058 if (!ob || !(SvOBJECT(ob)
3059 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3062 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3066 stash = SvSTASH(ob);
3069 /* NOTE: stash may be null, hope hv_fetch_ent and
3070 gv_fetchmethod can cope (it seems they can) */
3072 /* shortcut for simple names */
3074 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3076 gv = (GV*)HeVAL(he);
3077 if (isGV(gv) && GvCV(gv) &&
3078 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3079 return (SV*)GvCV(gv);
3083 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3086 /* This code tries to figure out just what went wrong with
3087 gv_fetchmethod. It therefore needs to duplicate a lot of
3088 the internals of that function. We can't move it inside
3089 Perl_gv_fetchmethod_autoload(), however, since that would
3090 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3093 const char* leaf = name;
3094 const char* sep = Nullch;
3097 for (p = name; *p; p++) {
3099 sep = p, leaf = p + 1;
3100 else if (*p == ':' && *(p + 1) == ':')
3101 sep = p, leaf = p + 2;
3103 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3104 /* the method name is unqualified or starts with SUPER:: */
3105 bool need_strlen = 1;
3107 packname = CopSTASHPV(PL_curcop);
3110 HEK * const packhek = HvNAME_HEK(stash);
3112 packname = HEK_KEY(packhek);
3113 packlen = HEK_LEN(packhek);
3123 "Can't use anonymous symbol table for method lookup");
3125 else if (need_strlen)
3126 packlen = strlen(packname);
3130 /* the method name is qualified */
3132 packlen = sep - name;
3135 /* we're relying on gv_fetchmethod not autovivifying the stash */
3136 if (gv_stashpvn(packname, packlen, FALSE)) {
3138 "Can't locate object method \"%s\" via package \"%.*s\"",
3139 leaf, (int)packlen, packname);
3143 "Can't locate object method \"%s\" via package \"%.*s\""
3144 " (perhaps you forgot to load \"%.*s\"?)",
3145 leaf, (int)packlen, packname, (int)packlen, packname);
3148 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3153 * c-indentation-style: bsd
3155 * indent-tabs-mode: t
3158 * ex: set ts=8 sts=4 sw=4 noet: