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 ** const 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 * const 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 ** const svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1892 sv = svp ? *svp : Nullsv;
1895 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1899 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1903 if (SvMAGICAL(av) || AvREIFY(av)) {
1904 SV ** const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1905 sv = svp ? *svp : Nullsv;
1908 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1912 if (sv && SvIS_FREED(sv)) {
1914 Perl_croak(aTHX_ "Use of freed value in iteration");
1921 if (av != PL_curstack && sv == &PL_sv_undef) {
1922 SV *lv = cx->blk_loop.iterlval;
1923 if (lv && SvREFCNT(lv) > 1) {
1928 SvREFCNT_dec(LvTARG(lv));
1930 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1931 sv_upgrade(lv, SVt_PVLV);
1933 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1935 LvTARG(lv) = SvREFCNT_inc(av);
1936 LvTARGOFF(lv) = cx->blk_loop.iterix;
1937 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1942 *itersvp = SvREFCNT_inc(sv);
1943 SvREFCNT_dec(oldsv);
1951 register PMOP *pm = cPMOP;
1967 register REGEXP *rx = PM_GETRE(pm);
1969 int force_on_match = 0;
1970 const I32 oldsave = PL_savestack_ix;
1972 bool doutf8 = FALSE;
1973 #ifdef PERL_OLD_COPY_ON_WRITE
1978 /* known replacement string? */
1979 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1980 if (PL_op->op_flags & OPf_STACKED)
1982 else if (PL_op->op_private & OPpTARGET_MY)
1989 #ifdef PERL_OLD_COPY_ON_WRITE
1990 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1991 because they make integers such as 256 "false". */
1992 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1995 sv_force_normal_flags(TARG,0);
1998 #ifdef PERL_OLD_COPY_ON_WRITE
2002 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2003 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2004 DIE(aTHX_ PL_no_modify);
2007 s = SvPV_mutable(TARG, len);
2008 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2010 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2011 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2016 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2020 DIE(aTHX_ "panic: pp_subst");
2023 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2024 maxiters = 2 * slen + 10; /* We can match twice at each
2025 position, once with zero-length,
2026 second time with non-zero. */
2028 if (!rx->prelen && PL_curpm) {
2032 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2033 ? REXEC_COPY_STR : 0;
2035 r_flags |= REXEC_SCREAM;
2038 if (rx->reganch & RE_USE_INTUIT) {
2040 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2044 /* How to do it in subst? */
2045 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2047 && ((rx->reganch & ROPT_NOSCAN)
2048 || !((rx->reganch & RE_INTUIT_TAIL)
2049 && (r_flags & REXEC_SCREAM))))
2054 /* only replace once? */
2055 once = !(rpm->op_pmflags & PMf_GLOBAL);
2057 /* known replacement string? */
2059 /* replacement needing upgrading? */
2060 if (DO_UTF8(TARG) && !doutf8) {
2061 nsv = sv_newmortal();
2064 sv_recode_to_utf8(nsv, PL_encoding);
2066 sv_utf8_upgrade(nsv);
2067 c = SvPV_const(nsv, clen);
2071 c = SvPV_const(dstr, clen);
2072 doutf8 = DO_UTF8(dstr);
2080 /* can do inplace substitution? */
2082 #ifdef PERL_OLD_COPY_ON_WRITE
2085 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2086 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2087 && (!doutf8 || SvUTF8(TARG))) {
2088 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2089 r_flags | REXEC_CHECKED))
2093 LEAVE_SCOPE(oldsave);
2096 #ifdef PERL_OLD_COPY_ON_WRITE
2097 if (SvIsCOW(TARG)) {
2098 assert (!force_on_match);
2102 if (force_on_match) {
2104 s = SvPV_force(TARG, len);
2109 SvSCREAM_off(TARG); /* disable possible screamer */
2111 rxtainted |= RX_MATCH_TAINTED(rx);
2112 m = orig + rx->startp[0];
2113 d = orig + rx->endp[0];
2115 if (m - s > strend - d) { /* faster to shorten from end */
2117 Copy(c, m, clen, char);
2122 Move(d, m, i, char);
2126 SvCUR_set(TARG, m - s);
2128 else if ((i = m - s)) { /* faster from front */
2136 Copy(c, m, clen, char);
2141 Copy(c, d, clen, char);
2146 TAINT_IF(rxtainted & 1);
2152 if (iters++ > maxiters)
2153 DIE(aTHX_ "Substitution loop");
2154 rxtainted |= RX_MATCH_TAINTED(rx);
2155 m = rx->startp[0] + orig;
2158 Move(s, d, i, char);
2162 Copy(c, d, clen, char);
2165 s = rx->endp[0] + orig;
2166 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2168 /* don't match same null twice */
2169 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2172 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2173 Move(s, d, i+1, char); /* include the NUL */
2175 TAINT_IF(rxtainted & 1);
2177 PUSHs(sv_2mortal(newSViv((I32)iters)));
2179 (void)SvPOK_only_UTF8(TARG);
2180 TAINT_IF(rxtainted);
2181 if (SvSMAGICAL(TARG)) {
2189 LEAVE_SCOPE(oldsave);
2193 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2194 r_flags | REXEC_CHECKED))
2196 if (force_on_match) {
2198 s = SvPV_force(TARG, len);
2201 #ifdef PERL_OLD_COPY_ON_WRITE
2204 rxtainted |= RX_MATCH_TAINTED(rx);
2205 dstr = newSVpvn(m, s-m);
2210 register PERL_CONTEXT *cx;
2212 (void)ReREFCNT_inc(rx);
2214 RETURNOP(cPMOP->op_pmreplroot);
2216 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2218 if (iters++ > maxiters)
2219 DIE(aTHX_ "Substitution loop");
2220 rxtainted |= RX_MATCH_TAINTED(rx);
2221 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2226 strend = s + (strend - m);
2228 m = rx->startp[0] + orig;
2229 if (doutf8 && !SvUTF8(dstr))
2230 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2232 sv_catpvn(dstr, s, m-s);
2233 s = rx->endp[0] + orig;
2235 sv_catpvn(dstr, c, clen);
2238 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2239 TARG, NULL, r_flags));
2240 if (doutf8 && !DO_UTF8(TARG))
2241 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2243 sv_catpvn(dstr, s, strend - s);
2245 #ifdef PERL_OLD_COPY_ON_WRITE
2246 /* The match may make the string COW. If so, brilliant, because that's
2247 just saved us one malloc, copy and free - the regexp has donated
2248 the old buffer, and we malloc an entirely new one, rather than the
2249 regexp malloc()ing a buffer and copying our original, only for
2250 us to throw it away here during the substitution. */
2251 if (SvIsCOW(TARG)) {
2252 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2258 SvPV_set(TARG, SvPVX(dstr));
2259 SvCUR_set(TARG, SvCUR(dstr));
2260 SvLEN_set(TARG, SvLEN(dstr));
2261 doutf8 |= DO_UTF8(dstr);
2262 SvPV_set(dstr, (char*)0);
2265 TAINT_IF(rxtainted & 1);
2267 PUSHs(sv_2mortal(newSViv((I32)iters)));
2269 (void)SvPOK_only(TARG);
2272 TAINT_IF(rxtainted);
2275 LEAVE_SCOPE(oldsave);
2284 LEAVE_SCOPE(oldsave);
2293 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2294 ++*PL_markstack_ptr;
2295 LEAVE; /* exit inner scope */
2298 if (PL_stack_base + *PL_markstack_ptr > SP) {
2300 const I32 gimme = GIMME_V;
2302 LEAVE; /* exit outer scope */
2303 (void)POPMARK; /* pop src */
2304 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2305 (void)POPMARK; /* pop dst */
2306 SP = PL_stack_base + POPMARK; /* pop original mark */
2307 if (gimme == G_SCALAR) {
2308 if (PL_op->op_private & OPpGREP_LEX) {
2309 SV* const sv = sv_newmortal();
2310 sv_setiv(sv, items);
2318 else if (gimme == G_ARRAY)
2325 ENTER; /* enter inner scope */
2328 src = PL_stack_base[*PL_markstack_ptr];
2330 if (PL_op->op_private & OPpGREP_LEX)
2331 PAD_SVl(PL_op->op_targ) = src;
2335 RETURNOP(cLOGOP->op_other);
2346 register PERL_CONTEXT *cx;
2349 if (CxMULTICALL(&cxstack[cxstack_ix]))
2353 cxstack_ix++; /* temporarily protect top context */
2356 if (gimme == G_SCALAR) {
2359 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2361 *MARK = SvREFCNT_inc(TOPs);
2366 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2368 *MARK = sv_mortalcopy(sv);
2373 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2377 *MARK = &PL_sv_undef;
2381 else if (gimme == G_ARRAY) {
2382 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2383 if (!SvTEMP(*MARK)) {
2384 *MARK = sv_mortalcopy(*MARK);
2385 TAINT_NOT; /* Each item is independent */
2393 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2394 PL_curpm = newpm; /* ... and pop $1 et al */
2397 return cx->blk_sub.retop;
2400 /* This duplicates the above code because the above code must not
2401 * get any slower by more conditions */
2409 register PERL_CONTEXT *cx;
2412 if (CxMULTICALL(&cxstack[cxstack_ix]))
2416 cxstack_ix++; /* temporarily protect top context */
2420 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2421 /* We are an argument to a function or grep().
2422 * This kind of lvalueness was legal before lvalue
2423 * subroutines too, so be backward compatible:
2424 * cannot report errors. */
2426 /* Scalar context *is* possible, on the LHS of -> only,
2427 * as in f()->meth(). But this is not an lvalue. */
2428 if (gimme == G_SCALAR)
2430 if (gimme == G_ARRAY) {
2431 if (!CvLVALUE(cx->blk_sub.cv))
2432 goto temporise_array;
2433 EXTEND_MORTAL(SP - newsp);
2434 for (mark = newsp + 1; mark <= SP; mark++) {
2437 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2438 *mark = sv_mortalcopy(*mark);
2440 /* Can be a localized value subject to deletion. */
2441 PL_tmps_stack[++PL_tmps_ix] = *mark;
2442 (void)SvREFCNT_inc(*mark);
2447 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2448 /* Here we go for robustness, not for speed, so we change all
2449 * the refcounts so the caller gets a live guy. Cannot set
2450 * TEMP, so sv_2mortal is out of question. */
2451 if (!CvLVALUE(cx->blk_sub.cv)) {
2457 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2459 if (gimme == G_SCALAR) {
2463 /* Temporaries are bad unless they happen to be elements
2464 * of a tied hash or array */
2465 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2466 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2472 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2473 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2474 : "a readonly value" : "a temporary");
2476 else { /* Can be a localized value
2477 * subject to deletion. */
2478 PL_tmps_stack[++PL_tmps_ix] = *mark;
2479 (void)SvREFCNT_inc(*mark);
2482 else { /* Should not happen? */
2488 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2489 (MARK > SP ? "Empty array" : "Array"));
2493 else if (gimme == G_ARRAY) {
2494 EXTEND_MORTAL(SP - newsp);
2495 for (mark = newsp + 1; mark <= SP; mark++) {
2496 if (*mark != &PL_sv_undef
2497 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2498 /* Might be flattened array after $#array = */
2505 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2506 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2509 /* Can be a localized value subject to deletion. */
2510 PL_tmps_stack[++PL_tmps_ix] = *mark;
2511 (void)SvREFCNT_inc(*mark);
2517 if (gimme == G_SCALAR) {
2521 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2523 *MARK = SvREFCNT_inc(TOPs);
2528 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2530 *MARK = sv_mortalcopy(sv);
2535 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2539 *MARK = &PL_sv_undef;
2543 else if (gimme == G_ARRAY) {
2545 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2546 if (!SvTEMP(*MARK)) {
2547 *MARK = sv_mortalcopy(*MARK);
2548 TAINT_NOT; /* Each item is independent */
2557 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2558 PL_curpm = newpm; /* ... and pop $1 et al */
2561 return cx->blk_sub.retop;
2566 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2568 SV * const dbsv = GvSVn(PL_DBsub);
2571 if (!PERLDB_SUB_NN) {
2574 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2575 || strEQ(GvNAME(gv), "END")
2576 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2577 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2578 && (gv = (GV*)*svp) ))) {
2579 /* Use GV from the stack as a fallback. */
2580 /* GV is potentially non-unique, or contain different CV. */
2581 SV * const tmp = newRV((SV*)cv);
2582 sv_setsv(dbsv, tmp);
2586 gv_efullname3(dbsv, gv, Nullch);
2590 const int type = SvTYPE(dbsv);
2591 if (type < SVt_PVIV && type != SVt_IV)
2592 sv_upgrade(dbsv, SVt_PVIV);
2593 (void)SvIOK_on(dbsv);
2594 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2598 PL_curcopdb = PL_curcop;
2599 cv = GvCV(PL_DBsub);
2609 register PERL_CONTEXT *cx;
2611 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2614 DIE(aTHX_ "Not a CODE reference");
2615 switch (SvTYPE(sv)) {
2616 /* This is overwhelming the most common case: */
2618 if (!(cv = GvCVu((GV*)sv)))
2619 cv = sv_2cv(sv, &stash, &gv, FALSE);
2629 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2631 SP = PL_stack_base + POPMARK;
2634 if (SvGMAGICAL(sv)) {
2638 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2641 sym = SvPV_nolen_const(sv);
2644 DIE(aTHX_ PL_no_usym, "a subroutine");
2645 if (PL_op->op_private & HINT_STRICT_REFS)
2646 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2647 cv = get_cv(sym, TRUE);
2652 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2653 tryAMAGICunDEREF(to_cv);
2656 if (SvTYPE(cv) == SVt_PVCV)
2661 DIE(aTHX_ "Not a CODE reference");
2662 /* This is the second most common case: */
2672 if (!CvROOT(cv) && !CvXSUB(cv)) {
2677 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2678 if (CvASSERTION(cv) && PL_DBassertion)
2679 sv_setiv(PL_DBassertion, 1);
2681 cv = get_db_sub(&sv, cv);
2682 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2683 DIE(aTHX_ "No DB::sub routine defined");
2686 if (!(CvXSUB(cv))) {
2687 /* This path taken at least 75% of the time */
2689 register I32 items = SP - MARK;
2690 AV* const padlist = CvPADLIST(cv);
2691 PUSHBLOCK(cx, CXt_SUB, MARK);
2693 cx->blk_sub.retop = PL_op->op_next;
2695 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2696 * that eval'' ops within this sub know the correct lexical space.
2697 * Owing the speed considerations, we choose instead to search for
2698 * the cv using find_runcv() when calling doeval().
2700 if (CvDEPTH(cv) >= 2) {
2701 PERL_STACK_OVERFLOW_CHECK();
2702 pad_push(padlist, CvDEPTH(cv));
2705 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2708 AV* const av = (AV*)PAD_SVl(0);
2710 /* @_ is normally not REAL--this should only ever
2711 * happen when DB::sub() calls things that modify @_ */
2716 cx->blk_sub.savearray = GvAV(PL_defgv);
2717 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2718 CX_CURPAD_SAVE(cx->blk_sub);
2719 cx->blk_sub.argarray = av;
2722 if (items > AvMAX(av) + 1) {
2723 SV **ary = AvALLOC(av);
2724 if (AvARRAY(av) != ary) {
2725 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2726 SvPV_set(av, (char*)ary);
2728 if (items > AvMAX(av) + 1) {
2729 AvMAX(av) = items - 1;
2730 Renew(ary,items,SV*);
2732 SvPV_set(av, (char*)ary);
2735 Copy(MARK,AvARRAY(av),items,SV*);
2736 AvFILLp(av) = items - 1;
2744 /* warning must come *after* we fully set up the context
2745 * stuff so that __WARN__ handlers can safely dounwind()
2748 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2749 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2750 sub_crush_depth(cv);
2752 DEBUG_S(PerlIO_printf(Perl_debug_log,
2753 "%p entersub returning %p\n", thr, CvSTART(cv)));
2755 RETURNOP(CvSTART(cv));
2758 #ifdef PERL_XSUB_OLDSTYLE
2759 if (CvOLDSTYLE(cv)) {
2760 I32 (*fp3)(int,int,int);
2762 register I32 items = SP - MARK;
2763 /* We dont worry to copy from @_. */
2768 PL_stack_sp = mark + 1;
2769 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2770 items = (*fp3)(CvXSUBANY(cv).any_i32,
2771 MARK - PL_stack_base + 1,
2773 PL_stack_sp = PL_stack_base + items;
2776 #endif /* PERL_XSUB_OLDSTYLE */
2778 I32 markix = TOPMARK;
2783 /* Need to copy @_ to stack. Alternative may be to
2784 * switch stack to @_, and copy return values
2785 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2786 AV * const av = GvAV(PL_defgv);
2787 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2790 /* Mark is at the end of the stack. */
2792 Copy(AvARRAY(av), SP + 1, items, SV*);
2797 /* We assume first XSUB in &DB::sub is the called one. */
2799 SAVEVPTR(PL_curcop);
2800 PL_curcop = PL_curcopdb;
2803 /* Do we need to open block here? XXXX */
2804 (void)(*CvXSUB(cv))(aTHX_ cv);
2806 /* Enforce some sanity in scalar context. */
2807 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2808 if (markix > PL_stack_sp - PL_stack_base)
2809 *(PL_stack_base + markix) = &PL_sv_undef;
2811 *(PL_stack_base + markix) = *PL_stack_sp;
2812 PL_stack_sp = PL_stack_base + markix;
2820 assert (0); /* Cannot get here. */
2821 /* This is deliberately moved here as spaghetti code to keep it out of the
2828 /* anonymous or undef'd function leaves us no recourse */
2829 if (CvANON(cv) || !(gv = CvGV(cv)))
2830 DIE(aTHX_ "Undefined subroutine called");
2832 /* autoloaded stub? */
2833 if (cv != GvCV(gv)) {
2836 /* should call AUTOLOAD now? */
2839 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2846 sub_name = sv_newmortal();
2847 gv_efullname3(sub_name, gv, Nullch);
2848 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2852 DIE(aTHX_ "Not a CODE reference");
2858 Perl_sub_crush_depth(pTHX_ CV *cv)
2861 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2863 SV* const tmpstr = sv_newmortal();
2864 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2865 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2874 SV* const elemsv = POPs;
2875 IV elem = SvIV(elemsv);
2876 AV* const av = (AV*)POPs;
2877 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2878 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2881 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2882 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2884 elem -= PL_curcop->cop_arybase;
2885 if (SvTYPE(av) != SVt_PVAV)
2887 svp = av_fetch(av, elem, lval && !defer);
2889 #ifdef PERL_MALLOC_WRAP
2890 if (SvUOK(elemsv)) {
2891 const UV uv = SvUV(elemsv);
2892 elem = uv > IV_MAX ? IV_MAX : uv;
2894 else if (SvNOK(elemsv))
2895 elem = (IV)SvNV(elemsv);
2897 static const char oom_array_extend[] =
2898 "Out of memory during array extend"; /* Duplicated in av.c */
2899 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2902 if (!svp || *svp == &PL_sv_undef) {
2905 DIE(aTHX_ PL_no_aelem, elem);
2906 lv = sv_newmortal();
2907 sv_upgrade(lv, SVt_PVLV);
2909 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2910 LvTARG(lv) = SvREFCNT_inc(av);
2911 LvTARGOFF(lv) = elem;
2916 if (PL_op->op_private & OPpLVAL_INTRO)
2917 save_aelem(av, elem, svp);
2918 else if (PL_op->op_private & OPpDEREF)
2919 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2921 sv = (svp ? *svp : &PL_sv_undef);
2922 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2923 sv = sv_mortalcopy(sv);
2929 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2934 Perl_croak(aTHX_ PL_no_modify);
2935 if (SvTYPE(sv) < SVt_RV)
2936 sv_upgrade(sv, SVt_RV);
2937 else if (SvTYPE(sv) >= SVt_PV) {
2944 SvRV_set(sv, NEWSV(355,0));
2947 SvRV_set(sv, (SV*)newAV());
2950 SvRV_set(sv, (SV*)newHV());
2961 SV* const sv = TOPs;
2964 SV* const rsv = SvRV(sv);
2965 if (SvTYPE(rsv) == SVt_PVCV) {
2971 SETs(method_common(sv, Null(U32*)));
2978 SV* const sv = cSVOP_sv;
2979 U32 hash = SvSHARED_HASH(sv);
2981 XPUSHs(method_common(sv, &hash));
2986 S_method_common(pTHX_ SV* meth, U32* hashp)
2992 const char* packname = Nullch;
2993 SV *packsv = Nullsv;
2995 const char * const name = SvPV_const(meth, namelen);
2996 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2999 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3007 /* this isn't a reference */
3008 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3009 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3011 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3018 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3019 !(ob=(SV*)GvIO(iogv)))
3021 /* this isn't the name of a filehandle either */
3023 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3024 ? !isIDFIRST_utf8((U8*)packname)
3025 : !isIDFIRST(*packname)
3028 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3029 SvOK(sv) ? "without a package or object reference"
3030 : "on an undefined value");
3032 /* assume it's a package name */
3033 stash = gv_stashpvn(packname, packlen, FALSE);
3037 SV* ref = newSViv(PTR2IV(stash));
3038 hv_store(PL_stashcache, packname, packlen, ref, 0);
3042 /* it _is_ a filehandle name -- replace with a reference */
3043 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3046 /* if we got here, ob should be a reference or a glob */
3047 if (!ob || !(SvOBJECT(ob)
3048 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3051 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3055 stash = SvSTASH(ob);
3058 /* NOTE: stash may be null, hope hv_fetch_ent and
3059 gv_fetchmethod can cope (it seems they can) */
3061 /* shortcut for simple names */
3063 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3065 gv = (GV*)HeVAL(he);
3066 if (isGV(gv) && GvCV(gv) &&
3067 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3068 return (SV*)GvCV(gv);
3072 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3075 /* This code tries to figure out just what went wrong with
3076 gv_fetchmethod. It therefore needs to duplicate a lot of
3077 the internals of that function. We can't move it inside
3078 Perl_gv_fetchmethod_autoload(), however, since that would
3079 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3082 const char* leaf = name;
3083 const char* sep = Nullch;
3086 for (p = name; *p; p++) {
3088 sep = p, leaf = p + 1;
3089 else if (*p == ':' && *(p + 1) == ':')
3090 sep = p, leaf = p + 2;
3092 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3093 /* the method name is unqualified or starts with SUPER:: */
3094 bool need_strlen = 1;
3096 packname = CopSTASHPV(PL_curcop);
3099 HEK * const packhek = HvNAME_HEK(stash);
3101 packname = HEK_KEY(packhek);
3102 packlen = HEK_LEN(packhek);
3112 "Can't use anonymous symbol table for method lookup");
3114 else if (need_strlen)
3115 packlen = strlen(packname);
3119 /* the method name is qualified */
3121 packlen = sep - name;
3124 /* we're relying on gv_fetchmethod not autovivifying the stash */
3125 if (gv_stashpvn(packname, packlen, FALSE)) {
3127 "Can't locate object method \"%s\" via package \"%.*s\"",
3128 leaf, (int)packlen, packname);
3132 "Can't locate object method \"%s\" via package \"%.*s\""
3133 " (perhaps you forgot to load \"%.*s\"?)",
3134 leaf, (int)packlen, packname, (int)packlen, packname);
3137 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3142 * c-indentation-style: bsd
3144 * indent-tabs-mode: t
3147 * ex: set ts=8 sts=4 sw=4 noet: