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);
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))
349 switch (SvTYPE(sv)) {
351 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
355 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
359 if (CvROOT(sv) || CvXSUB(sv))
368 if(op_type == OP_DOR || op_type == OP_DORASSIGN) {
371 if(op_type == OP_DOR)
373 RETURNOP(cLOGOP->op_other);
374 } else if (op_type == OP_DEFINED) {
383 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
384 useleft = USE_LEFT(TOPm1s);
385 #ifdef PERL_PRESERVE_IVUV
386 /* We must see if we can perform the addition with integers if possible,
387 as the integer code detects overflow while the NV code doesn't.
388 If either argument hasn't had a numeric conversion yet attempt to get
389 the IV. It's important to do this now, rather than just assuming that
390 it's not IOK as a PV of "9223372036854775806" may not take well to NV
391 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
392 integer in case the second argument is IV=9223372036854775806
393 We can (now) rely on sv_2iv to do the right thing, only setting the
394 public IOK flag if the value in the NV (or PV) slot is truly integer.
396 A side effect is that this also aggressively prefers integer maths over
397 fp maths for integer values.
399 How to detect overflow?
401 C 99 section 6.2.6.1 says
403 The range of nonnegative values of a signed integer type is a subrange
404 of the corresponding unsigned integer type, and the representation of
405 the same value in each type is the same. A computation involving
406 unsigned operands can never overflow, because a result that cannot be
407 represented by the resulting unsigned integer type is reduced modulo
408 the number that is one greater than the largest value that can be
409 represented by the resulting type.
413 which I read as "unsigned ints wrap."
415 signed integer overflow seems to be classed as "exception condition"
417 If an exceptional condition occurs during the evaluation of an
418 expression (that is, if the result is not mathematically defined or not
419 in the range of representable values for its type), the behavior is
422 (6.5, the 5th paragraph)
424 I had assumed that on 2s complement machines signed arithmetic would
425 wrap, hence coded pp_add and pp_subtract on the assumption that
426 everything perl builds on would be happy. After much wailing and
427 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
428 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
429 unsigned code below is actually shorter than the old code. :-)
434 /* Unless the left argument is integer in range we are going to have to
435 use NV maths. Hence only attempt to coerce the right argument if
436 we know the left is integer. */
444 /* left operand is undef, treat as zero. + 0 is identity,
445 Could SETi or SETu right now, but space optimise by not adding
446 lots of code to speed up what is probably a rarish case. */
448 /* Left operand is defined, so is it IV? */
451 if ((auvok = SvUOK(TOPm1s)))
454 register const IV aiv = SvIVX(TOPm1s);
457 auvok = 1; /* Now acting as a sign flag. */
458 } else { /* 2s complement assumption for IV_MIN */
466 bool result_good = 0;
469 bool buvok = SvUOK(TOPs);
474 register const IV biv = SvIVX(TOPs);
481 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
482 else "IV" now, independent of how it came in.
483 if a, b represents positive, A, B negative, a maps to -A etc
488 all UV maths. negate result if A negative.
489 add if signs same, subtract if signs differ. */
495 /* Must get smaller */
501 /* result really should be -(auv-buv). as its negation
502 of true value, need to swap our result flag */
519 if (result <= (UV)IV_MIN)
522 /* result valid, but out of range for IV. */
527 } /* Overflow, drop through to NVs. */
534 /* left operand is undef, treat as zero. + 0.0 is identity. */
538 SETn( value + TOPn );
546 AV *av = PL_op->op_flags & OPf_SPECIAL ?
547 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
548 const U32 lval = PL_op->op_flags & OPf_MOD;
549 SV** svp = av_fetch(av, PL_op->op_private, lval);
550 SV *sv = (svp ? *svp : &PL_sv_undef);
552 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
553 sv = sv_mortalcopy(sv);
562 do_join(TARG, *MARK, MARK, SP);
573 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
574 * will be enough to hold an OP*.
576 SV* const sv = sv_newmortal();
577 sv_upgrade(sv, SVt_PVLV);
579 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
587 /* Oversized hot code. */
591 dVAR; dSP; dMARK; dORIGMARK;
597 if (PL_op->op_flags & OPf_STACKED)
602 if (gv && (io = GvIO(gv))
603 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
606 if (MARK == ORIGMARK) {
607 /* If using default handle then we need to make space to
608 * pass object as 1st arg, so move other args up ...
612 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
616 *MARK = SvTIED_obj((SV*)io, mg);
619 call_method("PRINT", G_SCALAR);
627 if (!(io = GvIO(gv))) {
628 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
629 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
631 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
632 report_evil_fh(gv, io, PL_op->op_type);
633 SETERRNO(EBADF,RMS_IFI);
636 else if (!(fp = IoOFP(io))) {
637 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
639 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
640 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
641 report_evil_fh(gv, io, PL_op->op_type);
643 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
648 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
650 if (!do_print(*MARK, fp))
654 if (!do_print(PL_ofs_sv, fp)) { /* $, */
663 if (!do_print(*MARK, fp))
671 if (PL_ors_sv && SvOK(PL_ors_sv))
672 if (!do_print(PL_ors_sv, fp)) /* $\ */
675 if (IoFLAGS(io) & IOf_FLUSH)
676 if (PerlIO_flush(fp) == EOF)
686 XPUSHs(&PL_sv_undef);
697 tryAMAGICunDEREF(to_av);
700 if (SvTYPE(av) != SVt_PVAV)
701 DIE(aTHX_ "Not an ARRAY reference");
702 if (PL_op->op_flags & OPf_REF) {
707 if (GIMME == G_SCALAR)
708 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
712 else if (PL_op->op_flags & OPf_MOD
713 && PL_op->op_private & OPpLVAL_INTRO)
714 Perl_croak(aTHX_ PL_no_localize_ref);
717 if (SvTYPE(sv) == SVt_PVAV) {
719 if (PL_op->op_flags & OPf_REF) {
724 if (GIMME == G_SCALAR)
725 Perl_croak(aTHX_ "Can't return array to lvalue"
734 if (SvTYPE(sv) != SVt_PVGV) {
735 if (SvGMAGICAL(sv)) {
741 if (PL_op->op_flags & OPf_REF ||
742 PL_op->op_private & HINT_STRICT_REFS)
743 DIE(aTHX_ PL_no_usym, "an ARRAY");
744 if (ckWARN(WARN_UNINITIALIZED))
746 if (GIMME == G_ARRAY) {
752 if ((PL_op->op_flags & OPf_SPECIAL) &&
753 !(PL_op->op_flags & OPf_MOD))
755 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
757 && (!is_gv_magical_sv(sv,0)
758 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
764 if (PL_op->op_private & HINT_STRICT_REFS)
765 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
766 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
773 if (PL_op->op_private & OPpLVAL_INTRO)
775 if (PL_op->op_flags & OPf_REF) {
780 if (GIMME == G_SCALAR)
781 Perl_croak(aTHX_ "Can't return array to lvalue"
789 if (GIMME == G_ARRAY) {
790 const I32 maxarg = AvFILL(av) + 1;
791 (void)POPs; /* XXXX May be optimized away? */
793 if (SvRMAGICAL(av)) {
795 for (i=0; i < (U32)maxarg; i++) {
796 SV **svp = av_fetch(av, i, FALSE);
797 /* See note in pp_helem, and bug id #27839 */
799 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
804 Copy(AvARRAY(av), SP+1, maxarg, SV*);
808 else if (GIMME_V == G_SCALAR) {
810 const I32 maxarg = AvFILL(av) + 1;
820 const I32 gimme = GIMME_V;
821 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
825 tryAMAGICunDEREF(to_hv);
828 if (SvTYPE(hv) != SVt_PVHV)
829 DIE(aTHX_ "Not a HASH reference");
830 if (PL_op->op_flags & OPf_REF) {
835 if (gimme != G_ARRAY)
836 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
840 else if (PL_op->op_flags & OPf_MOD
841 && PL_op->op_private & OPpLVAL_INTRO)
842 Perl_croak(aTHX_ PL_no_localize_ref);
845 if (SvTYPE(sv) == SVt_PVHV) {
847 if (PL_op->op_flags & OPf_REF) {
852 if (gimme != G_ARRAY)
853 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
861 if (SvTYPE(sv) != SVt_PVGV) {
862 if (SvGMAGICAL(sv)) {
868 if (PL_op->op_flags & OPf_REF ||
869 PL_op->op_private & HINT_STRICT_REFS)
870 DIE(aTHX_ PL_no_usym, "a HASH");
871 if (ckWARN(WARN_UNINITIALIZED))
873 if (gimme == G_ARRAY) {
879 if ((PL_op->op_flags & OPf_SPECIAL) &&
880 !(PL_op->op_flags & OPf_MOD))
882 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
884 && (!is_gv_magical_sv(sv,0)
885 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
891 if (PL_op->op_private & HINT_STRICT_REFS)
892 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
893 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
900 if (PL_op->op_private & OPpLVAL_INTRO)
902 if (PL_op->op_flags & OPf_REF) {
907 if (gimme != G_ARRAY)
908 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
915 if (gimme == G_ARRAY) { /* array wanted */
916 *PL_stack_sp = (SV*)hv;
919 else if (gimme == G_SCALAR) {
921 TARG = Perl_hv_scalar(aTHX_ hv);
928 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
934 if (ckWARN(WARN_MISC)) {
936 if (relem == firstrelem &&
938 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
939 SvTYPE(SvRV(*relem)) == SVt_PVHV))
941 err = "Reference found where even-sized list expected";
944 err = "Odd number of elements in hash assignment";
945 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
948 tmpstr = NEWSV(29,0);
949 didstore = hv_store_ent(hash,*relem,tmpstr,0);
950 if (SvMAGICAL(hash)) {
951 if (SvSMAGICAL(tmpstr))
963 SV **lastlelem = PL_stack_sp;
964 SV **lastrelem = PL_stack_base + POPMARK;
965 SV **firstrelem = PL_stack_base + POPMARK + 1;
966 SV **firstlelem = lastrelem + 1;
979 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
982 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
985 /* If there's a common identifier on both sides we have to take
986 * special care that assigning the identifier on the left doesn't
987 * clobber a value on the right that's used later in the list.
989 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
990 EXTEND_MORTAL(lastrelem - firstrelem + 1);
991 for (relem = firstrelem; relem <= lastrelem; relem++) {
993 TAINT_NOT; /* Each item is independent */
994 *relem = sv_mortalcopy(sv);
1004 while (lelem <= lastlelem) {
1005 TAINT_NOT; /* Each item stands on its own, taintwise. */
1007 switch (SvTYPE(sv)) {
1010 magic = SvMAGICAL(ary) != 0;
1012 av_extend(ary, lastrelem - relem);
1014 while (relem <= lastrelem) { /* gobble up all the rest */
1017 sv = newSVsv(*relem);
1019 didstore = av_store(ary,i++,sv);
1029 case SVt_PVHV: { /* normal hash */
1033 magic = SvMAGICAL(hash) != 0;
1035 firsthashrelem = relem;
1037 while (relem < lastrelem) { /* gobble up all the rest */
1042 sv = &PL_sv_no, relem++;
1043 tmpstr = NEWSV(29,0);
1045 sv_setsv(tmpstr,*relem); /* value */
1046 *(relem++) = tmpstr;
1047 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1048 /* key overwrites an existing entry */
1050 didstore = hv_store_ent(hash,sv,tmpstr,0);
1052 if (SvSMAGICAL(tmpstr))
1059 if (relem == lastrelem) {
1060 do_oddball(hash, relem, firstrelem);
1066 if (SvIMMORTAL(sv)) {
1067 if (relem <= lastrelem)
1071 if (relem <= lastrelem) {
1072 sv_setsv(sv, *relem);
1076 sv_setsv(sv, &PL_sv_undef);
1081 if (PL_delaymagic & ~DM_DELAY) {
1082 if (PL_delaymagic & DM_UID) {
1083 #ifdef HAS_SETRESUID
1084 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1085 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1088 # ifdef HAS_SETREUID
1089 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1090 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1093 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1094 (void)setruid(PL_uid);
1095 PL_delaymagic &= ~DM_RUID;
1097 # endif /* HAS_SETRUID */
1099 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1100 (void)seteuid(PL_euid);
1101 PL_delaymagic &= ~DM_EUID;
1103 # endif /* HAS_SETEUID */
1104 if (PL_delaymagic & DM_UID) {
1105 if (PL_uid != PL_euid)
1106 DIE(aTHX_ "No setreuid available");
1107 (void)PerlProc_setuid(PL_uid);
1109 # endif /* HAS_SETREUID */
1110 #endif /* HAS_SETRESUID */
1111 PL_uid = PerlProc_getuid();
1112 PL_euid = PerlProc_geteuid();
1114 if (PL_delaymagic & DM_GID) {
1115 #ifdef HAS_SETRESGID
1116 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1117 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1120 # ifdef HAS_SETREGID
1121 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1122 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1125 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1126 (void)setrgid(PL_gid);
1127 PL_delaymagic &= ~DM_RGID;
1129 # endif /* HAS_SETRGID */
1131 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1132 (void)setegid(PL_egid);
1133 PL_delaymagic &= ~DM_EGID;
1135 # endif /* HAS_SETEGID */
1136 if (PL_delaymagic & DM_GID) {
1137 if (PL_gid != PL_egid)
1138 DIE(aTHX_ "No setregid available");
1139 (void)PerlProc_setgid(PL_gid);
1141 # endif /* HAS_SETREGID */
1142 #endif /* HAS_SETRESGID */
1143 PL_gid = PerlProc_getgid();
1144 PL_egid = PerlProc_getegid();
1146 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1150 if (gimme == G_VOID)
1151 SP = firstrelem - 1;
1152 else if (gimme == G_SCALAR) {
1155 SETi(lastrelem - firstrelem + 1 - duplicates);
1162 /* Removes from the stack the entries which ended up as
1163 * duplicated keys in the hash (fix for [perl #24380]) */
1164 Move(firsthashrelem + duplicates,
1165 firsthashrelem, duplicates, SV**);
1166 lastrelem -= duplicates;
1171 SP = firstrelem + (lastlelem - firstlelem);
1172 lelem = firstlelem + (relem - firstrelem);
1174 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1182 register PMOP * const pm = cPMOP;
1183 SV * const rv = sv_newmortal();
1184 SV * const sv = newSVrv(rv, "Regexp");
1185 if (pm->op_pmdynflags & PMdf_TAINTED)
1187 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1194 register PMOP *pm = cPMOP;
1196 register const char *t;
1197 register const char *s;
1200 I32 r_flags = REXEC_CHECKED;
1201 const char *truebase; /* Start of string */
1202 register REGEXP *rx = PM_GETRE(pm);
1204 const I32 gimme = GIMME;
1207 const I32 oldsave = PL_savestack_ix;
1208 I32 update_minmatch = 1;
1209 I32 had_zerolen = 0;
1211 if (PL_op->op_flags & OPf_STACKED)
1213 else if (PL_op->op_private & OPpTARGET_MY)
1220 PUTBACK; /* EVAL blocks need stack_sp. */
1221 s = SvPV_const(TARG, len);
1223 DIE(aTHX_ "panic: pp_match");
1225 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1226 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1229 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1231 /* PMdf_USED is set after a ?? matches once */
1232 if (pm->op_pmdynflags & PMdf_USED) {
1234 if (gimme == G_ARRAY)
1239 /* empty pattern special-cased to use last successful pattern if possible */
1240 if (!rx->prelen && PL_curpm) {
1245 if (rx->minlen > (I32)len)
1250 /* XXXX What part of this is needed with true \G-support? */
1251 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1253 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1254 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1255 if (mg && mg->mg_len >= 0) {
1256 if (!(rx->reganch & ROPT_GPOS_SEEN))
1257 rx->endp[0] = rx->startp[0] = mg->mg_len;
1258 else if (rx->reganch & ROPT_ANCH_GPOS) {
1259 r_flags |= REXEC_IGNOREPOS;
1260 rx->endp[0] = rx->startp[0] = mg->mg_len;
1262 minmatch = (mg->mg_flags & MGf_MINMATCH);
1263 update_minmatch = 0;
1267 if ((!global && rx->nparens)
1268 || SvTEMP(TARG) || PL_sawampersand)
1269 r_flags |= REXEC_COPY_STR;
1271 r_flags |= REXEC_SCREAM;
1274 if (global && rx->startp[0] != -1) {
1275 t = s = rx->endp[0] + truebase;
1276 if ((s + rx->minlen) > strend)
1278 if (update_minmatch++)
1279 minmatch = had_zerolen;
1281 if (rx->reganch & RE_USE_INTUIT &&
1282 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1283 /* FIXME - can PL_bostr be made const char *? */
1284 PL_bostr = (char *)truebase;
1285 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1289 if ( (rx->reganch & ROPT_CHECK_ALL)
1291 && ((rx->reganch & ROPT_NOSCAN)
1292 || !((rx->reganch & RE_INTUIT_TAIL)
1293 && (r_flags & REXEC_SCREAM)))
1294 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1297 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1300 if (dynpm->op_pmflags & PMf_ONCE)
1301 dynpm->op_pmdynflags |= PMdf_USED;
1310 RX_MATCH_TAINTED_on(rx);
1311 TAINT_IF(RX_MATCH_TAINTED(rx));
1312 if (gimme == G_ARRAY) {
1313 const I32 nparens = rx->nparens;
1314 I32 i = (global && !nparens) ? 1 : 0;
1316 SPAGAIN; /* EVAL blocks could move the stack. */
1317 EXTEND(SP, nparens + i);
1318 EXTEND_MORTAL(nparens + i);
1319 for (i = !i; i <= nparens; i++) {
1320 PUSHs(sv_newmortal());
1321 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1322 const I32 len = rx->endp[i] - rx->startp[i];
1323 s = rx->startp[i] + truebase;
1324 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1325 len < 0 || len > strend - s)
1326 DIE(aTHX_ "panic: pp_match start/end pointers");
1327 sv_setpvn(*SP, s, len);
1328 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1333 if (dynpm->op_pmflags & PMf_CONTINUE) {
1335 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1336 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1338 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1339 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1341 if (rx->startp[0] != -1) {
1342 mg->mg_len = rx->endp[0];
1343 if (rx->startp[0] == rx->endp[0])
1344 mg->mg_flags |= MGf_MINMATCH;
1346 mg->mg_flags &= ~MGf_MINMATCH;
1349 had_zerolen = (rx->startp[0] != -1
1350 && rx->startp[0] == rx->endp[0]);
1351 PUTBACK; /* EVAL blocks may use stack */
1352 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1357 LEAVE_SCOPE(oldsave);
1363 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1364 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1366 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1367 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1369 if (rx->startp[0] != -1) {
1370 mg->mg_len = rx->endp[0];
1371 if (rx->startp[0] == rx->endp[0])
1372 mg->mg_flags |= MGf_MINMATCH;
1374 mg->mg_flags &= ~MGf_MINMATCH;
1377 LEAVE_SCOPE(oldsave);
1381 yup: /* Confirmed by INTUIT */
1383 RX_MATCH_TAINTED_on(rx);
1384 TAINT_IF(RX_MATCH_TAINTED(rx));
1386 if (dynpm->op_pmflags & PMf_ONCE)
1387 dynpm->op_pmdynflags |= PMdf_USED;
1388 if (RX_MATCH_COPIED(rx))
1389 Safefree(rx->subbeg);
1390 RX_MATCH_COPIED_off(rx);
1391 rx->subbeg = Nullch;
1393 /* FIXME - should rx->subbeg be const char *? */
1394 rx->subbeg = (char *) truebase;
1395 rx->startp[0] = s - truebase;
1396 if (RX_MATCH_UTF8(rx)) {
1397 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1398 rx->endp[0] = t - truebase;
1401 rx->endp[0] = s - truebase + rx->minlen;
1403 rx->sublen = strend - truebase;
1406 if (PL_sawampersand) {
1408 #ifdef PERL_OLD_COPY_ON_WRITE
1409 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1411 PerlIO_printf(Perl_debug_log,
1412 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1413 (int) SvTYPE(TARG), truebase, t,
1416 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1417 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1418 assert (SvPOKp(rx->saved_copy));
1423 rx->subbeg = savepvn(t, strend - t);
1424 #ifdef PERL_OLD_COPY_ON_WRITE
1425 rx->saved_copy = Nullsv;
1428 rx->sublen = strend - t;
1429 RX_MATCH_COPIED_on(rx);
1430 off = rx->startp[0] = s - t;
1431 rx->endp[0] = off + rx->minlen;
1433 else { /* startp/endp are used by @- @+. */
1434 rx->startp[0] = s - truebase;
1435 rx->endp[0] = s - truebase + rx->minlen;
1437 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1438 LEAVE_SCOPE(oldsave);
1443 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1444 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1445 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1450 LEAVE_SCOPE(oldsave);
1451 if (gimme == G_ARRAY)
1457 Perl_do_readline(pTHX)
1459 dVAR; dSP; dTARGETSTACKED;
1464 register IO * const io = GvIO(PL_last_in_gv);
1465 register const I32 type = PL_op->op_type;
1466 const I32 gimme = GIMME_V;
1469 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1471 XPUSHs(SvTIED_obj((SV*)io, mg));
1474 call_method("READLINE", gimme);
1477 if (gimme == G_SCALAR) {
1479 SvSetSV_nosteal(TARG, result);
1488 if (IoFLAGS(io) & IOf_ARGV) {
1489 if (IoFLAGS(io) & IOf_START) {
1491 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1492 IoFLAGS(io) &= ~IOf_START;
1493 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1494 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1495 SvSETMAGIC(GvSV(PL_last_in_gv));
1500 fp = nextargv(PL_last_in_gv);
1501 if (!fp) { /* Note: fp != IoIFP(io) */
1502 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1505 else if (type == OP_GLOB)
1506 fp = Perl_start_glob(aTHX_ POPs, io);
1508 else if (type == OP_GLOB)
1510 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1511 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1515 if ((!io || !(IoFLAGS(io) & IOf_START))
1516 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1518 if (type == OP_GLOB)
1519 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1520 "glob failed (can't start child: %s)",
1523 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1525 if (gimme == G_SCALAR) {
1526 /* undef TARG, and push that undefined value */
1527 if (type != OP_RCATLINE) {
1528 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1536 if (gimme == G_SCALAR) {
1540 SvUPGRADE(sv, SVt_PV);
1541 tmplen = SvLEN(sv); /* remember if already alloced */
1542 if (!tmplen && !SvREADONLY(sv))
1543 Sv_Grow(sv, 80); /* try short-buffering it */
1545 if (type == OP_RCATLINE && SvOK(sv)) {
1547 SvPV_force_nolen(sv);
1553 sv = sv_2mortal(NEWSV(57, 80));
1557 /* This should not be marked tainted if the fp is marked clean */
1558 #define MAYBE_TAINT_LINE(io, sv) \
1559 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1564 /* delay EOF state for a snarfed empty file */
1565 #define SNARF_EOF(gimme,rs,io,sv) \
1566 (gimme != G_SCALAR || SvCUR(sv) \
1567 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1571 if (!sv_gets(sv, fp, offset)
1573 || SNARF_EOF(gimme, PL_rs, io, sv)
1574 || PerlIO_error(fp)))
1576 PerlIO_clearerr(fp);
1577 if (IoFLAGS(io) & IOf_ARGV) {
1578 fp = nextargv(PL_last_in_gv);
1581 (void)do_close(PL_last_in_gv, FALSE);
1583 else if (type == OP_GLOB) {
1584 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1585 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1586 "glob failed (child exited with status %d%s)",
1587 (int)(STATUS_CURRENT >> 8),
1588 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1591 if (gimme == G_SCALAR) {
1592 if (type != OP_RCATLINE) {
1593 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1599 MAYBE_TAINT_LINE(io, sv);
1602 MAYBE_TAINT_LINE(io, sv);
1604 IoFLAGS(io) |= IOf_NOLINE;
1608 if (type == OP_GLOB) {
1612 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1613 tmps = SvEND(sv) - 1;
1614 if (*tmps == *SvPVX_const(PL_rs)) {
1616 SvCUR_set(sv, SvCUR(sv) - 1);
1619 for (t1 = SvPVX_const(sv); *t1; t1++)
1620 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1621 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1623 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1624 (void)POPs; /* Unmatched wildcard? Chuck it... */
1627 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1628 const U8 *s = (const U8*)SvPVX_const(sv) + offset;
1629 const STRLEN len = SvCUR(sv) - offset;
1632 if (ckWARN(WARN_UTF8) &&
1633 !is_utf8_string_loc(s, len, &f))
1634 /* Emulate :encoding(utf8) warning in the same case. */
1635 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1636 "utf8 \"\\x%02X\" does not map to Unicode",
1637 f < (U8*)SvEND(sv) ? *f : 0);
1639 if (gimme == G_ARRAY) {
1640 if (SvLEN(sv) - SvCUR(sv) > 20) {
1641 SvPV_shrink_to_cur(sv);
1643 sv = sv_2mortal(NEWSV(58, 80));
1646 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1647 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1648 const STRLEN new_len
1649 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1650 SvPV_renew(sv, new_len);
1659 register PERL_CONTEXT *cx;
1660 I32 gimme = OP_GIMME(PL_op, -1);
1663 if (cxstack_ix >= 0)
1664 gimme = cxstack[cxstack_ix].blk_gimme;
1672 PUSHBLOCK(cx, CXt_BLOCK, SP);
1684 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1685 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1687 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1690 if (SvTYPE(hv) == SVt_PVHV) {
1691 if (PL_op->op_private & OPpLVAL_INTRO) {
1694 /* does the element we're localizing already exist? */
1696 /* can we determine whether it exists? */
1698 || mg_find((SV*)hv, PERL_MAGIC_env)
1699 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1700 /* Try to preserve the existenceness of a tied hash
1701 * element by using EXISTS and DELETE if possible.
1702 * Fallback to FETCH and STORE otherwise */
1703 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1704 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1705 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1707 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1710 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1711 svp = he ? &HeVAL(he) : 0;
1717 if (!svp || *svp == &PL_sv_undef) {
1721 DIE(aTHX_ PL_no_helem_sv, keysv);
1723 lv = sv_newmortal();
1724 sv_upgrade(lv, SVt_PVLV);
1726 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1727 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1728 LvTARG(lv) = SvREFCNT_inc(hv);
1733 if (PL_op->op_private & OPpLVAL_INTRO) {
1734 if (HvNAME_get(hv) && isGV(*svp))
1735 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1739 const char * const key = SvPV_const(keysv, keylen);
1740 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1742 save_helem(hv, keysv, svp);
1745 else if (PL_op->op_private & OPpDEREF)
1746 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1748 sv = (svp ? *svp : &PL_sv_undef);
1749 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1750 * Pushing the magical RHS on to the stack is useless, since
1751 * that magic is soon destined to be misled by the local(),
1752 * and thus the later pp_sassign() will fail to mg_get() the
1753 * old value. This should also cure problems with delayed
1754 * mg_get()s. GSAR 98-07-03 */
1755 if (!lval && SvGMAGICAL(sv))
1756 sv = sv_mortalcopy(sv);
1764 register PERL_CONTEXT *cx;
1769 if (PL_op->op_flags & OPf_SPECIAL) {
1770 cx = &cxstack[cxstack_ix];
1771 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1776 gimme = OP_GIMME(PL_op, -1);
1778 if (cxstack_ix >= 0)
1779 gimme = cxstack[cxstack_ix].blk_gimme;
1785 if (gimme == G_VOID)
1787 else if (gimme == G_SCALAR) {
1791 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1794 *MARK = sv_mortalcopy(TOPs);
1797 *MARK = &PL_sv_undef;
1801 else if (gimme == G_ARRAY) {
1802 /* in case LEAVE wipes old return values */
1804 for (mark = newsp + 1; mark <= SP; mark++) {
1805 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1806 *mark = sv_mortalcopy(*mark);
1807 TAINT_NOT; /* Each item is independent */
1811 PL_curpm = newpm; /* Don't pop $1 et al till now */
1821 register PERL_CONTEXT *cx;
1827 cx = &cxstack[cxstack_ix];
1828 if (CxTYPE(cx) != CXt_LOOP)
1829 DIE(aTHX_ "panic: pp_iter");
1831 itersvp = CxITERVAR(cx);
1832 av = cx->blk_loop.iterary;
1833 if (SvTYPE(av) != SVt_PVAV) {
1834 /* iterate ($min .. $max) */
1835 if (cx->blk_loop.iterlval) {
1836 /* string increment */
1837 register SV* cur = cx->blk_loop.iterlval;
1839 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1840 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1841 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1842 /* safe to reuse old SV */
1843 sv_setsv(*itersvp, cur);
1847 /* we need a fresh SV every time so that loop body sees a
1848 * completely new SV for closures/references to work as
1851 *itersvp = newSVsv(cur);
1852 SvREFCNT_dec(oldsv);
1854 if (strEQ(SvPVX_const(cur), max))
1855 sv_setiv(cur, 0); /* terminate next time */
1862 /* integer increment */
1863 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1866 /* don't risk potential race */
1867 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1868 /* safe to reuse old SV */
1869 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1873 /* we need a fresh SV every time so that loop body sees a
1874 * completely new SV for closures/references to work as they
1877 *itersvp = newSViv(cx->blk_loop.iterix++);
1878 SvREFCNT_dec(oldsv);
1884 if (PL_op->op_private & OPpITER_REVERSED) {
1885 /* In reverse, use itermax as the min :-) */
1886 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1889 if (SvMAGICAL(av) || AvREIFY(av)) {
1890 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1897 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1901 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1905 if (SvMAGICAL(av) || AvREIFY(av)) {
1906 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1913 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1917 if (sv && SvREFCNT(sv) == 0) {
1919 Perl_croak(aTHX_ "Use of freed value in iteration");
1926 if (av != PL_curstack && sv == &PL_sv_undef) {
1927 SV *lv = cx->blk_loop.iterlval;
1928 if (lv && SvREFCNT(lv) > 1) {
1933 SvREFCNT_dec(LvTARG(lv));
1935 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1936 sv_upgrade(lv, SVt_PVLV);
1938 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1940 LvTARG(lv) = SvREFCNT_inc(av);
1941 LvTARGOFF(lv) = cx->blk_loop.iterix;
1942 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1947 *itersvp = SvREFCNT_inc(sv);
1948 SvREFCNT_dec(oldsv);
1956 register PMOP *pm = cPMOP;
1972 register REGEXP *rx = PM_GETRE(pm);
1974 int force_on_match = 0;
1975 I32 oldsave = PL_savestack_ix;
1977 bool doutf8 = FALSE;
1978 #ifdef PERL_OLD_COPY_ON_WRITE
1983 /* known replacement string? */
1984 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1985 if (PL_op->op_flags & OPf_STACKED)
1987 else if (PL_op->op_private & OPpTARGET_MY)
1994 #ifdef PERL_OLD_COPY_ON_WRITE
1995 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1996 because they make integers such as 256 "false". */
1997 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2000 sv_force_normal_flags(TARG,0);
2003 #ifdef PERL_OLD_COPY_ON_WRITE
2007 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2008 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2009 DIE(aTHX_ PL_no_modify);
2012 s = SvPV_mutable(TARG, len);
2013 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2015 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2016 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2021 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2025 DIE(aTHX_ "panic: pp_subst");
2028 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2029 maxiters = 2 * slen + 10; /* We can match twice at each
2030 position, once with zero-length,
2031 second time with non-zero. */
2033 if (!rx->prelen && PL_curpm) {
2037 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2038 ? REXEC_COPY_STR : 0;
2040 r_flags |= REXEC_SCREAM;
2043 if (rx->reganch & RE_USE_INTUIT) {
2045 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2049 /* How to do it in subst? */
2050 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2052 && ((rx->reganch & ROPT_NOSCAN)
2053 || !((rx->reganch & RE_INTUIT_TAIL)
2054 && (r_flags & REXEC_SCREAM))))
2059 /* only replace once? */
2060 once = !(rpm->op_pmflags & PMf_GLOBAL);
2062 /* known replacement string? */
2064 /* replacement needing upgrading? */
2065 if (DO_UTF8(TARG) && !doutf8) {
2066 nsv = sv_newmortal();
2069 sv_recode_to_utf8(nsv, PL_encoding);
2071 sv_utf8_upgrade(nsv);
2072 c = SvPV_const(nsv, clen);
2076 c = SvPV_const(dstr, clen);
2077 doutf8 = DO_UTF8(dstr);
2085 /* can do inplace substitution? */
2087 #ifdef PERL_OLD_COPY_ON_WRITE
2090 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2091 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2092 && (!doutf8 || SvUTF8(TARG))) {
2093 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2094 r_flags | REXEC_CHECKED))
2098 LEAVE_SCOPE(oldsave);
2101 #ifdef PERL_OLD_COPY_ON_WRITE
2102 if (SvIsCOW(TARG)) {
2103 assert (!force_on_match);
2107 if (force_on_match) {
2109 s = SvPV_force(TARG, len);
2114 SvSCREAM_off(TARG); /* disable possible screamer */
2116 rxtainted |= RX_MATCH_TAINTED(rx);
2117 m = orig + rx->startp[0];
2118 d = orig + rx->endp[0];
2120 if (m - s > strend - d) { /* faster to shorten from end */
2122 Copy(c, m, clen, char);
2127 Move(d, m, i, char);
2131 SvCUR_set(TARG, m - s);
2133 else if ((i = m - s)) { /* faster from front */
2141 Copy(c, m, clen, char);
2146 Copy(c, d, clen, char);
2151 TAINT_IF(rxtainted & 1);
2157 if (iters++ > maxiters)
2158 DIE(aTHX_ "Substitution loop");
2159 rxtainted |= RX_MATCH_TAINTED(rx);
2160 m = rx->startp[0] + orig;
2163 Move(s, d, i, char);
2167 Copy(c, d, clen, char);
2170 s = rx->endp[0] + orig;
2171 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2173 /* don't match same null twice */
2174 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2177 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2178 Move(s, d, i+1, char); /* include the NUL */
2180 TAINT_IF(rxtainted & 1);
2182 PUSHs(sv_2mortal(newSViv((I32)iters)));
2184 (void)SvPOK_only_UTF8(TARG);
2185 TAINT_IF(rxtainted);
2186 if (SvSMAGICAL(TARG)) {
2194 LEAVE_SCOPE(oldsave);
2198 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2199 r_flags | REXEC_CHECKED))
2201 if (force_on_match) {
2203 s = SvPV_force(TARG, len);
2206 #ifdef PERL_OLD_COPY_ON_WRITE
2209 rxtainted |= RX_MATCH_TAINTED(rx);
2210 dstr = newSVpvn(m, s-m);
2215 register PERL_CONTEXT *cx;
2217 (void)ReREFCNT_inc(rx);
2219 RETURNOP(cPMOP->op_pmreplroot);
2221 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2223 if (iters++ > maxiters)
2224 DIE(aTHX_ "Substitution loop");
2225 rxtainted |= RX_MATCH_TAINTED(rx);
2226 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2231 strend = s + (strend - m);
2233 m = rx->startp[0] + orig;
2234 if (doutf8 && !SvUTF8(dstr))
2235 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2237 sv_catpvn(dstr, s, m-s);
2238 s = rx->endp[0] + orig;
2240 sv_catpvn(dstr, c, clen);
2243 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2244 TARG, NULL, r_flags));
2245 if (doutf8 && !DO_UTF8(TARG))
2246 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2248 sv_catpvn(dstr, s, strend - s);
2250 #ifdef PERL_OLD_COPY_ON_WRITE
2251 /* The match may make the string COW. If so, brilliant, because that's
2252 just saved us one malloc, copy and free - the regexp has donated
2253 the old buffer, and we malloc an entirely new one, rather than the
2254 regexp malloc()ing a buffer and copying our original, only for
2255 us to throw it away here during the substitution. */
2256 if (SvIsCOW(TARG)) {
2257 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2263 SvPV_set(TARG, SvPVX(dstr));
2264 SvCUR_set(TARG, SvCUR(dstr));
2265 SvLEN_set(TARG, SvLEN(dstr));
2266 doutf8 |= DO_UTF8(dstr);
2267 SvPV_set(dstr, (char*)0);
2270 TAINT_IF(rxtainted & 1);
2272 PUSHs(sv_2mortal(newSViv((I32)iters)));
2274 (void)SvPOK_only(TARG);
2277 TAINT_IF(rxtainted);
2280 LEAVE_SCOPE(oldsave);
2289 LEAVE_SCOPE(oldsave);
2298 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2299 ++*PL_markstack_ptr;
2300 LEAVE; /* exit inner scope */
2303 if (PL_stack_base + *PL_markstack_ptr > SP) {
2305 const I32 gimme = GIMME_V;
2307 LEAVE; /* exit outer scope */
2308 (void)POPMARK; /* pop src */
2309 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2310 (void)POPMARK; /* pop dst */
2311 SP = PL_stack_base + POPMARK; /* pop original mark */
2312 if (gimme == G_SCALAR) {
2313 if (PL_op->op_private & OPpGREP_LEX) {
2314 SV* const sv = sv_newmortal();
2315 sv_setiv(sv, items);
2323 else if (gimme == G_ARRAY)
2330 ENTER; /* enter inner scope */
2333 src = PL_stack_base[*PL_markstack_ptr];
2335 if (PL_op->op_private & OPpGREP_LEX)
2336 PAD_SVl(PL_op->op_targ) = src;
2340 RETURNOP(cLOGOP->op_other);
2351 register PERL_CONTEXT *cx;
2354 if (CxMULTICALL(&cxstack[cxstack_ix]))
2358 cxstack_ix++; /* temporarily protect top context */
2361 if (gimme == G_SCALAR) {
2364 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2366 *MARK = SvREFCNT_inc(TOPs);
2371 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2373 *MARK = sv_mortalcopy(sv);
2378 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2382 *MARK = &PL_sv_undef;
2386 else if (gimme == G_ARRAY) {
2387 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2388 if (!SvTEMP(*MARK)) {
2389 *MARK = sv_mortalcopy(*MARK);
2390 TAINT_NOT; /* Each item is independent */
2398 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2399 PL_curpm = newpm; /* ... and pop $1 et al */
2402 return cx->blk_sub.retop;
2405 /* This duplicates the above code because the above code must not
2406 * get any slower by more conditions */
2414 register PERL_CONTEXT *cx;
2417 if (CxMULTICALL(&cxstack[cxstack_ix]))
2421 cxstack_ix++; /* temporarily protect top context */
2425 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2426 /* We are an argument to a function or grep().
2427 * This kind of lvalueness was legal before lvalue
2428 * subroutines too, so be backward compatible:
2429 * cannot report errors. */
2431 /* Scalar context *is* possible, on the LHS of -> only,
2432 * as in f()->meth(). But this is not an lvalue. */
2433 if (gimme == G_SCALAR)
2435 if (gimme == G_ARRAY) {
2436 if (!CvLVALUE(cx->blk_sub.cv))
2437 goto temporise_array;
2438 EXTEND_MORTAL(SP - newsp);
2439 for (mark = newsp + 1; mark <= SP; mark++) {
2442 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2443 *mark = sv_mortalcopy(*mark);
2445 /* Can be a localized value subject to deletion. */
2446 PL_tmps_stack[++PL_tmps_ix] = *mark;
2447 (void)SvREFCNT_inc(*mark);
2452 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2453 /* Here we go for robustness, not for speed, so we change all
2454 * the refcounts so the caller gets a live guy. Cannot set
2455 * TEMP, so sv_2mortal is out of question. */
2456 if (!CvLVALUE(cx->blk_sub.cv)) {
2462 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2464 if (gimme == G_SCALAR) {
2468 /* Temporaries are bad unless they happen to be elements
2469 * of a tied hash or array */
2470 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2471 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2477 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2478 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2479 : "a readonly value" : "a temporary");
2481 else { /* Can be a localized value
2482 * subject to deletion. */
2483 PL_tmps_stack[++PL_tmps_ix] = *mark;
2484 (void)SvREFCNT_inc(*mark);
2487 else { /* Should not happen? */
2493 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2494 (MARK > SP ? "Empty array" : "Array"));
2498 else if (gimme == G_ARRAY) {
2499 EXTEND_MORTAL(SP - newsp);
2500 for (mark = newsp + 1; mark <= SP; mark++) {
2501 if (*mark != &PL_sv_undef
2502 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2503 /* Might be flattened array after $#array = */
2510 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2511 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2514 /* Can be a localized value subject to deletion. */
2515 PL_tmps_stack[++PL_tmps_ix] = *mark;
2516 (void)SvREFCNT_inc(*mark);
2522 if (gimme == G_SCALAR) {
2526 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2528 *MARK = SvREFCNT_inc(TOPs);
2533 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2535 *MARK = sv_mortalcopy(sv);
2540 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2544 *MARK = &PL_sv_undef;
2548 else if (gimme == G_ARRAY) {
2550 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2551 if (!SvTEMP(*MARK)) {
2552 *MARK = sv_mortalcopy(*MARK);
2553 TAINT_NOT; /* Each item is independent */
2562 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2563 PL_curpm = newpm; /* ... and pop $1 et al */
2566 return cx->blk_sub.retop;
2571 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2573 SV *dbsv = GvSVn(PL_DBsub);
2576 if (!PERLDB_SUB_NN) {
2579 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2580 || strEQ(GvNAME(gv), "END")
2581 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2582 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2583 && (gv = (GV*)*svp) ))) {
2584 /* Use GV from the stack as a fallback. */
2585 /* GV is potentially non-unique, or contain different CV. */
2586 SV * const tmp = newRV((SV*)cv);
2587 sv_setsv(dbsv, tmp);
2591 gv_efullname3(dbsv, gv, Nullch);
2595 const int type = SvTYPE(dbsv);
2596 if (type < SVt_PVIV && type != SVt_IV)
2597 sv_upgrade(dbsv, SVt_PVIV);
2598 (void)SvIOK_on(dbsv);
2599 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2603 PL_curcopdb = PL_curcop;
2604 cv = GvCV(PL_DBsub);
2614 register PERL_CONTEXT *cx;
2616 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2619 DIE(aTHX_ "Not a CODE reference");
2620 switch (SvTYPE(sv)) {
2621 /* This is overwhelming the most common case: */
2623 if (!(cv = GvCVu((GV*)sv)))
2624 cv = sv_2cv(sv, &stash, &gv, FALSE);
2634 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2636 SP = PL_stack_base + POPMARK;
2639 if (SvGMAGICAL(sv)) {
2643 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2646 sym = SvPV_nolen_const(sv);
2649 DIE(aTHX_ PL_no_usym, "a subroutine");
2650 if (PL_op->op_private & HINT_STRICT_REFS)
2651 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2652 cv = get_cv(sym, TRUE);
2657 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2658 tryAMAGICunDEREF(to_cv);
2661 if (SvTYPE(cv) == SVt_PVCV)
2666 DIE(aTHX_ "Not a CODE reference");
2667 /* This is the second most common case: */
2677 if (!CvROOT(cv) && !CvXSUB(cv)) {
2682 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2683 if (CvASSERTION(cv) && PL_DBassertion)
2684 sv_setiv(PL_DBassertion, 1);
2686 cv = get_db_sub(&sv, cv);
2687 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2688 DIE(aTHX_ "No DB::sub routine defined");
2691 if (!(CvXSUB(cv))) {
2692 /* This path taken at least 75% of the time */
2694 register I32 items = SP - MARK;
2695 AV* padlist = CvPADLIST(cv);
2696 PUSHBLOCK(cx, CXt_SUB, MARK);
2698 cx->blk_sub.retop = PL_op->op_next;
2700 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2701 * that eval'' ops within this sub know the correct lexical space.
2702 * Owing the speed considerations, we choose instead to search for
2703 * the cv using find_runcv() when calling doeval().
2705 if (CvDEPTH(cv) >= 2) {
2706 PERL_STACK_OVERFLOW_CHECK();
2707 pad_push(padlist, CvDEPTH(cv));
2710 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2715 DEBUG_S(PerlIO_printf(Perl_debug_log,
2716 "%p entersub preparing @_\n", thr));
2718 av = (AV*)PAD_SVl(0);
2720 /* @_ is normally not REAL--this should only ever
2721 * happen when DB::sub() calls things that modify @_ */
2726 cx->blk_sub.savearray = GvAV(PL_defgv);
2727 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2728 CX_CURPAD_SAVE(cx->blk_sub);
2729 cx->blk_sub.argarray = av;
2732 if (items > AvMAX(av) + 1) {
2733 SV **ary = AvALLOC(av);
2734 if (AvARRAY(av) != ary) {
2735 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2736 SvPV_set(av, (char*)ary);
2738 if (items > AvMAX(av) + 1) {
2739 AvMAX(av) = items - 1;
2740 Renew(ary,items,SV*);
2742 SvPV_set(av, (char*)ary);
2745 Copy(MARK,AvARRAY(av),items,SV*);
2746 AvFILLp(av) = items - 1;
2754 /* warning must come *after* we fully set up the context
2755 * stuff so that __WARN__ handlers can safely dounwind()
2758 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2759 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2760 sub_crush_depth(cv);
2762 DEBUG_S(PerlIO_printf(Perl_debug_log,
2763 "%p entersub returning %p\n", thr, CvSTART(cv)));
2765 RETURNOP(CvSTART(cv));
2768 #ifdef PERL_XSUB_OLDSTYLE
2769 if (CvOLDSTYLE(cv)) {
2770 I32 (*fp3)(int,int,int);
2772 register I32 items = SP - MARK;
2773 /* We dont worry to copy from @_. */
2778 PL_stack_sp = mark + 1;
2779 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2780 items = (*fp3)(CvXSUBANY(cv).any_i32,
2781 MARK - PL_stack_base + 1,
2783 PL_stack_sp = PL_stack_base + items;
2786 #endif /* PERL_XSUB_OLDSTYLE */
2788 I32 markix = TOPMARK;
2793 /* Need to copy @_ to stack. Alternative may be to
2794 * switch stack to @_, and copy return values
2795 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2796 AV * const av = GvAV(PL_defgv);
2797 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2800 /* Mark is at the end of the stack. */
2802 Copy(AvARRAY(av), SP + 1, items, SV*);
2807 /* We assume first XSUB in &DB::sub is the called one. */
2809 SAVEVPTR(PL_curcop);
2810 PL_curcop = PL_curcopdb;
2813 /* Do we need to open block here? XXXX */
2814 (void)(*CvXSUB(cv))(aTHX_ cv);
2816 /* Enforce some sanity in scalar context. */
2817 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2818 if (markix > PL_stack_sp - PL_stack_base)
2819 *(PL_stack_base + markix) = &PL_sv_undef;
2821 *(PL_stack_base + markix) = *PL_stack_sp;
2822 PL_stack_sp = PL_stack_base + markix;
2830 assert (0); /* Cannot get here. */
2831 /* This is deliberately moved here as spaghetti code to keep it out of the
2838 /* anonymous or undef'd function leaves us no recourse */
2839 if (CvANON(cv) || !(gv = CvGV(cv)))
2840 DIE(aTHX_ "Undefined subroutine called");
2842 /* autoloaded stub? */
2843 if (cv != GvCV(gv)) {
2846 /* should call AUTOLOAD now? */
2849 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2856 sub_name = sv_newmortal();
2857 gv_efullname3(sub_name, gv, Nullch);
2858 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2862 DIE(aTHX_ "Not a CODE reference");
2868 Perl_sub_crush_depth(pTHX_ CV *cv)
2871 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2873 SV* const tmpstr = sv_newmortal();
2874 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2875 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2884 SV* const elemsv = POPs;
2885 IV elem = SvIV(elemsv);
2887 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2888 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2891 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2892 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2894 elem -= PL_curcop->cop_arybase;
2895 if (SvTYPE(av) != SVt_PVAV)
2897 svp = av_fetch(av, elem, lval && !defer);
2899 #ifdef PERL_MALLOC_WRAP
2900 if (SvUOK(elemsv)) {
2901 const UV uv = SvUV(elemsv);
2902 elem = uv > IV_MAX ? IV_MAX : uv;
2904 else if (SvNOK(elemsv))
2905 elem = (IV)SvNV(elemsv);
2907 static const char oom_array_extend[] =
2908 "Out of memory during array extend"; /* Duplicated in av.c */
2909 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2912 if (!svp || *svp == &PL_sv_undef) {
2915 DIE(aTHX_ PL_no_aelem, elem);
2916 lv = sv_newmortal();
2917 sv_upgrade(lv, SVt_PVLV);
2919 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2920 LvTARG(lv) = SvREFCNT_inc(av);
2921 LvTARGOFF(lv) = elem;
2926 if (PL_op->op_private & OPpLVAL_INTRO)
2927 save_aelem(av, elem, svp);
2928 else if (PL_op->op_private & OPpDEREF)
2929 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2931 sv = (svp ? *svp : &PL_sv_undef);
2932 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2933 sv = sv_mortalcopy(sv);
2939 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2944 Perl_croak(aTHX_ PL_no_modify);
2945 if (SvTYPE(sv) < SVt_RV)
2946 sv_upgrade(sv, SVt_RV);
2947 else if (SvTYPE(sv) >= SVt_PV) {
2954 SvRV_set(sv, NEWSV(355,0));
2957 SvRV_set(sv, (SV*)newAV());
2960 SvRV_set(sv, (SV*)newHV());
2971 SV* const sv = TOPs;
2974 SV* const rsv = SvRV(sv);
2975 if (SvTYPE(rsv) == SVt_PVCV) {
2981 SETs(method_common(sv, Null(U32*)));
2988 SV* const sv = cSVOP_sv;
2989 U32 hash = SvSHARED_HASH(sv);
2991 XPUSHs(method_common(sv, &hash));
2996 S_method_common(pTHX_ SV* meth, U32* hashp)
3002 const char* packname = Nullch;
3003 SV *packsv = Nullsv;
3005 const char * const name = SvPV_const(meth, namelen);
3006 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3009 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3017 /* this isn't a reference */
3018 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3019 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3021 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3028 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3029 !(ob=(SV*)GvIO(iogv)))
3031 /* this isn't the name of a filehandle either */
3033 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3034 ? !isIDFIRST_utf8((U8*)packname)
3035 : !isIDFIRST(*packname)
3038 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3039 SvOK(sv) ? "without a package or object reference"
3040 : "on an undefined value");
3042 /* assume it's a package name */
3043 stash = gv_stashpvn(packname, packlen, FALSE);
3047 SV* ref = newSViv(PTR2IV(stash));
3048 hv_store(PL_stashcache, packname, packlen, ref, 0);
3052 /* it _is_ a filehandle name -- replace with a reference */
3053 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3056 /* if we got here, ob should be a reference or a glob */
3057 if (!ob || !(SvOBJECT(ob)
3058 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3061 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3065 stash = SvSTASH(ob);
3068 /* NOTE: stash may be null, hope hv_fetch_ent and
3069 gv_fetchmethod can cope (it seems they can) */
3071 /* shortcut for simple names */
3073 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3075 gv = (GV*)HeVAL(he);
3076 if (isGV(gv) && GvCV(gv) &&
3077 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3078 return (SV*)GvCV(gv);
3082 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3085 /* This code tries to figure out just what went wrong with
3086 gv_fetchmethod. It therefore needs to duplicate a lot of
3087 the internals of that function. We can't move it inside
3088 Perl_gv_fetchmethod_autoload(), however, since that would
3089 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3092 const char* leaf = name;
3093 const char* sep = Nullch;
3096 for (p = name; *p; p++) {
3098 sep = p, leaf = p + 1;
3099 else if (*p == ':' && *(p + 1) == ':')
3100 sep = p, leaf = p + 2;
3102 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3103 /* the method name is unqualified or starts with SUPER:: */
3104 bool need_strlen = 1;
3106 packname = CopSTASHPV(PL_curcop);
3109 HEK * const packhek = HvNAME_HEK(stash);
3111 packname = HEK_KEY(packhek);
3112 packlen = HEK_LEN(packhek);
3122 "Can't use anonymous symbol table for method lookup");
3124 else if (need_strlen)
3125 packlen = strlen(packname);
3129 /* the method name is qualified */
3131 packlen = sep - name;
3134 /* we're relying on gv_fetchmethod not autovivifying the stash */
3135 if (gv_stashpvn(packname, packlen, FALSE)) {
3137 "Can't locate object method \"%s\" via package \"%.*s\"",
3138 leaf, (int)packlen, packname);
3142 "Can't locate object method \"%s\" via package \"%.*s\""
3143 " (perhaps you forgot to load \"%.*s\"?)",
3144 leaf, (int)packlen, packname, (int)packlen, packname);
3147 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3152 * c-indentation-style: bsd
3154 * indent-tabs-mode: t
3157 * ex: set ts=8 sts=4 sw=4 noet: