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) {
114 SV * const temp = left;
115 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);
153 bool rcopied = FALSE;
155 if (TARG == right && right != left) {
156 /* mg_get(right) may happen here ... */
157 rpv = SvPV_const(right, rlen);
158 rbyte = !DO_UTF8(right);
159 right = sv_2mortal(newSVpvn(rpv, rlen));
160 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
166 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
167 lbyte = !DO_UTF8(left);
168 sv_setpvn(TARG, lpv, llen);
174 else { /* TARG == left */
176 SvGETMAGIC(left); /* or mg_get(left) may happen here */
178 if (left == right && ckWARN(WARN_UNINITIALIZED))
179 report_uninit(right);
180 sv_setpvn(left, "", 0);
182 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
183 lbyte = !DO_UTF8(left);
188 /* or mg_get(right) may happen here */
190 rpv = SvPV_const(right, rlen);
191 rbyte = !DO_UTF8(right);
193 if (lbyte != rbyte) {
195 sv_utf8_upgrade_nomg(TARG);
198 right = sv_2mortal(newSVpvn(rpv, rlen));
199 sv_utf8_upgrade_nomg(right);
200 rpv = SvPV_const(right, rlen);
203 sv_catpvn_nomg(TARG, rpv, rlen);
214 if (PL_op->op_flags & OPf_MOD) {
215 if (PL_op->op_private & OPpLVAL_INTRO)
216 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
217 if (PL_op->op_private & OPpDEREF) {
219 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
228 tryAMAGICunTARGET(iter, 0);
229 PL_last_in_gv = (GV*)(*PL_stack_sp--);
230 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
231 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
232 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
235 XPUSHs((SV*)PL_last_in_gv);
238 PL_last_in_gv = (GV*)(*PL_stack_sp--);
241 return do_readline();
246 dSP; tryAMAGICbinSET(eq,0);
247 #ifndef NV_PRESERVES_UV
248 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
250 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
254 #ifdef PERL_PRESERVE_IVUV
257 /* Unless the left argument is integer in range we are going
258 to have to use NV maths. Hence only attempt to coerce the
259 right argument if we know the left is integer. */
262 const bool auvok = SvUOK(TOPm1s);
263 const bool buvok = SvUOK(TOPs);
265 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
266 /* Casting IV to UV before comparison isn't going to matter
267 on 2s complement. On 1s complement or sign&magnitude
268 (if we have any of them) it could to make negative zero
269 differ from normal zero. As I understand it. (Need to
270 check - is negative zero implementation defined behaviour
272 const UV buv = SvUVX(POPs);
273 const UV auv = SvUVX(TOPs);
275 SETs(boolSV(auv == buv));
278 { /* ## Mixed IV,UV ## */
282 /* == is commutative so doesn't matter which is left or right */
284 /* top of stack (b) is the iv */
293 /* As uv is a UV, it's >0, so it cannot be == */
297 /* we know iv is >= 0 */
298 SETs(boolSV((UV)iv == SvUVX(uvp)));
306 SETs(boolSV(TOPn == value));
314 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
315 DIE(aTHX_ PL_no_modify);
316 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
317 && SvIVX(TOPs) != IV_MAX)
319 SvIV_set(TOPs, SvIVX(TOPs) + 1);
320 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
322 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
334 if (PL_op->op_type == OP_OR)
336 RETURNOP(cLOGOP->op_other);
343 register SV* sv = NULL;
344 bool defined = FALSE;
345 const int op_type = PL_op->op_type;
347 if(op_type == OP_DOR || op_type == OP_DORASSIGN) {
349 if (!sv || !SvANY(sv)) {
350 if (op_type == OP_DOR)
352 RETURNOP(cLOGOP->op_other);
354 } else if (op_type == OP_DEFINED) {
356 if (!sv || !SvANY(sv))
359 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
361 switch (SvTYPE(sv)) {
363 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
367 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
371 if (CvROOT(sv) || CvXSUB(sv))
380 if(op_type == OP_DOR || op_type == OP_DORASSIGN) {
383 if(op_type == OP_DOR)
385 RETURNOP(cLOGOP->op_other);
387 /* assuming OP_DEFINED */
395 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
396 useleft = USE_LEFT(TOPm1s);
397 #ifdef PERL_PRESERVE_IVUV
398 /* We must see if we can perform the addition with integers if possible,
399 as the integer code detects overflow while the NV code doesn't.
400 If either argument hasn't had a numeric conversion yet attempt to get
401 the IV. It's important to do this now, rather than just assuming that
402 it's not IOK as a PV of "9223372036854775806" may not take well to NV
403 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
404 integer in case the second argument is IV=9223372036854775806
405 We can (now) rely on sv_2iv to do the right thing, only setting the
406 public IOK flag if the value in the NV (or PV) slot is truly integer.
408 A side effect is that this also aggressively prefers integer maths over
409 fp maths for integer values.
411 How to detect overflow?
413 C 99 section 6.2.6.1 says
415 The range of nonnegative values of a signed integer type is a subrange
416 of the corresponding unsigned integer type, and the representation of
417 the same value in each type is the same. A computation involving
418 unsigned operands can never overflow, because a result that cannot be
419 represented by the resulting unsigned integer type is reduced modulo
420 the number that is one greater than the largest value that can be
421 represented by the resulting type.
425 which I read as "unsigned ints wrap."
427 signed integer overflow seems to be classed as "exception condition"
429 If an exceptional condition occurs during the evaluation of an
430 expression (that is, if the result is not mathematically defined or not
431 in the range of representable values for its type), the behavior is
434 (6.5, the 5th paragraph)
436 I had assumed that on 2s complement machines signed arithmetic would
437 wrap, hence coded pp_add and pp_subtract on the assumption that
438 everything perl builds on would be happy. After much wailing and
439 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
440 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
441 unsigned code below is actually shorter than the old code. :-)
446 /* Unless the left argument is integer in range we are going to have to
447 use NV maths. Hence only attempt to coerce the right argument if
448 we know the left is integer. */
456 /* left operand is undef, treat as zero. + 0 is identity,
457 Could SETi or SETu right now, but space optimise by not adding
458 lots of code to speed up what is probably a rarish case. */
460 /* Left operand is defined, so is it IV? */
463 if ((auvok = SvUOK(TOPm1s)))
466 register const IV aiv = SvIVX(TOPm1s);
469 auvok = 1; /* Now acting as a sign flag. */
470 } else { /* 2s complement assumption for IV_MIN */
478 bool result_good = 0;
481 bool buvok = SvUOK(TOPs);
486 register const IV biv = SvIVX(TOPs);
493 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
494 else "IV" now, independent of how it came in.
495 if a, b represents positive, A, B negative, a maps to -A etc
500 all UV maths. negate result if A negative.
501 add if signs same, subtract if signs differ. */
507 /* Must get smaller */
513 /* result really should be -(auv-buv). as its negation
514 of true value, need to swap our result flag */
531 if (result <= (UV)IV_MIN)
534 /* result valid, but out of range for IV. */
539 } /* Overflow, drop through to NVs. */
546 /* left operand is undef, treat as zero. + 0.0 is identity. */
550 SETn( value + TOPn );
558 AV *av = PL_op->op_flags & OPf_SPECIAL ?
559 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
560 const U32 lval = PL_op->op_flags & OPf_MOD;
561 SV** const svp = av_fetch(av, PL_op->op_private, lval);
562 SV *sv = (svp ? *svp : &PL_sv_undef);
564 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
565 sv = sv_mortalcopy(sv);
574 do_join(TARG, *MARK, MARK, SP);
585 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
586 * will be enough to hold an OP*.
588 SV* const sv = sv_newmortal();
589 sv_upgrade(sv, SVt_PVLV);
591 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
599 /* Oversized hot code. */
603 dVAR; dSP; dMARK; dORIGMARK;
607 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
609 if (gv && (io = GvIO(gv))
610 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
613 if (MARK == ORIGMARK) {
614 /* If using default handle then we need to make space to
615 * pass object as 1st arg, so move other args up ...
619 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
623 *MARK = SvTIED_obj((SV*)io, mg);
626 call_method("PRINT", G_SCALAR);
634 if (!(io = GvIO(gv))) {
635 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
636 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
638 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
639 report_evil_fh(gv, io, PL_op->op_type);
640 SETERRNO(EBADF,RMS_IFI);
643 else if (!(fp = IoOFP(io))) {
644 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
646 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
647 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
648 report_evil_fh(gv, io, PL_op->op_type);
650 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
655 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
657 if (!do_print(*MARK, fp))
661 if (!do_print(PL_ofs_sv, fp)) { /* $, */
670 if (!do_print(*MARK, fp))
678 if (PL_ors_sv && SvOK(PL_ors_sv))
679 if (!do_print(PL_ors_sv, fp)) /* $\ */
682 if (IoFLAGS(io) & IOf_FLUSH)
683 if (PerlIO_flush(fp) == EOF)
693 XPUSHs(&PL_sv_undef);
704 tryAMAGICunDEREF(to_av);
707 if (SvTYPE(av) != SVt_PVAV)
708 DIE(aTHX_ "Not an ARRAY reference");
709 if (PL_op->op_flags & OPf_REF) {
714 if (GIMME == G_SCALAR)
715 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
719 else if (PL_op->op_flags & OPf_MOD
720 && PL_op->op_private & OPpLVAL_INTRO)
721 Perl_croak(aTHX_ PL_no_localize_ref);
724 if (SvTYPE(sv) == SVt_PVAV) {
726 if (PL_op->op_flags & OPf_REF) {
731 if (GIMME == G_SCALAR)
732 Perl_croak(aTHX_ "Can't return array to lvalue"
741 if (SvTYPE(sv) != SVt_PVGV) {
742 if (SvGMAGICAL(sv)) {
748 if (PL_op->op_flags & OPf_REF ||
749 PL_op->op_private & HINT_STRICT_REFS)
750 DIE(aTHX_ PL_no_usym, "an ARRAY");
751 if (ckWARN(WARN_UNINITIALIZED))
753 if (GIMME == G_ARRAY) {
759 if ((PL_op->op_flags & OPf_SPECIAL) &&
760 !(PL_op->op_flags & OPf_MOD))
762 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
764 && (!is_gv_magical_sv(sv,0)
765 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
771 if (PL_op->op_private & HINT_STRICT_REFS)
772 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
773 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
780 if (PL_op->op_private & OPpLVAL_INTRO)
782 if (PL_op->op_flags & OPf_REF) {
787 if (GIMME == G_SCALAR)
788 Perl_croak(aTHX_ "Can't return array to lvalue"
796 if (GIMME == G_ARRAY) {
797 const I32 maxarg = AvFILL(av) + 1;
798 (void)POPs; /* XXXX May be optimized away? */
800 if (SvRMAGICAL(av)) {
802 for (i=0; i < (U32)maxarg; i++) {
803 SV ** const svp = av_fetch(av, i, FALSE);
804 /* See note in pp_helem, and bug id #27839 */
806 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
811 Copy(AvARRAY(av), SP+1, maxarg, SV*);
815 else if (GIMME_V == G_SCALAR) {
817 const I32 maxarg = AvFILL(av) + 1;
827 const I32 gimme = GIMME_V;
828 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
832 tryAMAGICunDEREF(to_hv);
835 if (SvTYPE(hv) != SVt_PVHV)
836 DIE(aTHX_ "Not a HASH reference");
837 if (PL_op->op_flags & OPf_REF) {
842 if (gimme != G_ARRAY)
843 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
847 else if (PL_op->op_flags & OPf_MOD
848 && PL_op->op_private & OPpLVAL_INTRO)
849 Perl_croak(aTHX_ PL_no_localize_ref);
852 if (SvTYPE(sv) == SVt_PVHV) {
854 if (PL_op->op_flags & OPf_REF) {
859 if (gimme != G_ARRAY)
860 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
868 if (SvTYPE(sv) != SVt_PVGV) {
869 if (SvGMAGICAL(sv)) {
875 if (PL_op->op_flags & OPf_REF ||
876 PL_op->op_private & HINT_STRICT_REFS)
877 DIE(aTHX_ PL_no_usym, "a HASH");
878 if (ckWARN(WARN_UNINITIALIZED))
880 if (gimme == G_ARRAY) {
886 if ((PL_op->op_flags & OPf_SPECIAL) &&
887 !(PL_op->op_flags & OPf_MOD))
889 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
891 && (!is_gv_magical_sv(sv,0)
892 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
898 if (PL_op->op_private & HINT_STRICT_REFS)
899 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
900 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
907 if (PL_op->op_private & OPpLVAL_INTRO)
909 if (PL_op->op_flags & OPf_REF) {
914 if (gimme != G_ARRAY)
915 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
922 if (gimme == G_ARRAY) { /* array wanted */
923 *PL_stack_sp = (SV*)hv;
926 else if (gimme == G_SCALAR) {
928 TARG = Perl_hv_scalar(aTHX_ hv);
935 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
941 if (ckWARN(WARN_MISC)) {
943 if (relem == firstrelem &&
945 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
946 SvTYPE(SvRV(*relem)) == SVt_PVHV))
948 err = "Reference found where even-sized list expected";
951 err = "Odd number of elements in hash assignment";
952 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
955 tmpstr = NEWSV(29,0);
956 didstore = hv_store_ent(hash,*relem,tmpstr,0);
957 if (SvMAGICAL(hash)) {
958 if (SvSMAGICAL(tmpstr))
970 SV **lastlelem = PL_stack_sp;
971 SV **lastrelem = PL_stack_base + POPMARK;
972 SV **firstrelem = PL_stack_base + POPMARK + 1;
973 SV **firstlelem = lastrelem + 1;
986 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
989 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
992 /* If there's a common identifier on both sides we have to take
993 * special care that assigning the identifier on the left doesn't
994 * clobber a value on the right that's used later in the list.
996 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
997 EXTEND_MORTAL(lastrelem - firstrelem + 1);
998 for (relem = firstrelem; relem <= lastrelem; relem++) {
1000 TAINT_NOT; /* Each item is independent */
1001 *relem = sv_mortalcopy(sv);
1011 while (lelem <= lastlelem) {
1012 TAINT_NOT; /* Each item stands on its own, taintwise. */
1014 switch (SvTYPE(sv)) {
1017 magic = SvMAGICAL(ary) != 0;
1019 av_extend(ary, lastrelem - relem);
1021 while (relem <= lastrelem) { /* gobble up all the rest */
1024 sv = newSVsv(*relem);
1026 didstore = av_store(ary,i++,sv);
1036 case SVt_PVHV: { /* normal hash */
1040 magic = SvMAGICAL(hash) != 0;
1042 firsthashrelem = relem;
1044 while (relem < lastrelem) { /* gobble up all the rest */
1049 sv = &PL_sv_no, relem++;
1050 tmpstr = NEWSV(29,0);
1052 sv_setsv(tmpstr,*relem); /* value */
1053 *(relem++) = tmpstr;
1054 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1055 /* key overwrites an existing entry */
1057 didstore = hv_store_ent(hash,sv,tmpstr,0);
1059 if (SvSMAGICAL(tmpstr))
1066 if (relem == lastrelem) {
1067 do_oddball(hash, relem, firstrelem);
1073 if (SvIMMORTAL(sv)) {
1074 if (relem <= lastrelem)
1078 if (relem <= lastrelem) {
1079 sv_setsv(sv, *relem);
1083 sv_setsv(sv, &PL_sv_undef);
1088 if (PL_delaymagic & ~DM_DELAY) {
1089 if (PL_delaymagic & DM_UID) {
1090 #ifdef HAS_SETRESUID
1091 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1092 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1095 # ifdef HAS_SETREUID
1096 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1097 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1100 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1101 (void)setruid(PL_uid);
1102 PL_delaymagic &= ~DM_RUID;
1104 # endif /* HAS_SETRUID */
1106 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1107 (void)seteuid(PL_euid);
1108 PL_delaymagic &= ~DM_EUID;
1110 # endif /* HAS_SETEUID */
1111 if (PL_delaymagic & DM_UID) {
1112 if (PL_uid != PL_euid)
1113 DIE(aTHX_ "No setreuid available");
1114 (void)PerlProc_setuid(PL_uid);
1116 # endif /* HAS_SETREUID */
1117 #endif /* HAS_SETRESUID */
1118 PL_uid = PerlProc_getuid();
1119 PL_euid = PerlProc_geteuid();
1121 if (PL_delaymagic & DM_GID) {
1122 #ifdef HAS_SETRESGID
1123 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1124 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1127 # ifdef HAS_SETREGID
1128 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1129 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1132 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1133 (void)setrgid(PL_gid);
1134 PL_delaymagic &= ~DM_RGID;
1136 # endif /* HAS_SETRGID */
1138 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1139 (void)setegid(PL_egid);
1140 PL_delaymagic &= ~DM_EGID;
1142 # endif /* HAS_SETEGID */
1143 if (PL_delaymagic & DM_GID) {
1144 if (PL_gid != PL_egid)
1145 DIE(aTHX_ "No setregid available");
1146 (void)PerlProc_setgid(PL_gid);
1148 # endif /* HAS_SETREGID */
1149 #endif /* HAS_SETRESGID */
1150 PL_gid = PerlProc_getgid();
1151 PL_egid = PerlProc_getegid();
1153 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1157 if (gimme == G_VOID)
1158 SP = firstrelem - 1;
1159 else if (gimme == G_SCALAR) {
1162 SETi(lastrelem - firstrelem + 1 - duplicates);
1169 /* Removes from the stack the entries which ended up as
1170 * duplicated keys in the hash (fix for [perl #24380]) */
1171 Move(firsthashrelem + duplicates,
1172 firsthashrelem, duplicates, SV**);
1173 lastrelem -= duplicates;
1178 SP = firstrelem + (lastlelem - firstlelem);
1179 lelem = firstlelem + (relem - firstrelem);
1181 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1189 register PMOP * const pm = cPMOP;
1190 SV * const rv = sv_newmortal();
1191 SV * const sv = newSVrv(rv, "Regexp");
1192 if (pm->op_pmdynflags & PMdf_TAINTED)
1194 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1201 register PMOP *pm = cPMOP;
1203 register const char *t;
1204 register const char *s;
1207 I32 r_flags = REXEC_CHECKED;
1208 const char *truebase; /* Start of string */
1209 register REGEXP *rx = PM_GETRE(pm);
1211 const I32 gimme = GIMME;
1214 const I32 oldsave = PL_savestack_ix;
1215 I32 update_minmatch = 1;
1216 I32 had_zerolen = 0;
1218 if (PL_op->op_flags & OPf_STACKED)
1220 else if (PL_op->op_private & OPpTARGET_MY)
1227 PUTBACK; /* EVAL blocks need stack_sp. */
1228 s = SvPV_const(TARG, len);
1230 DIE(aTHX_ "panic: pp_match");
1232 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1233 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1236 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1238 /* PMdf_USED is set after a ?? matches once */
1239 if (pm->op_pmdynflags & PMdf_USED) {
1241 if (gimme == G_ARRAY)
1246 /* empty pattern special-cased to use last successful pattern if possible */
1247 if (!rx->prelen && PL_curpm) {
1252 if (rx->minlen > (I32)len)
1257 /* XXXX What part of this is needed with true \G-support? */
1258 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1260 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1261 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1262 if (mg && mg->mg_len >= 0) {
1263 if (!(rx->reganch & ROPT_GPOS_SEEN))
1264 rx->endp[0] = rx->startp[0] = mg->mg_len;
1265 else if (rx->reganch & ROPT_ANCH_GPOS) {
1266 r_flags |= REXEC_IGNOREPOS;
1267 rx->endp[0] = rx->startp[0] = mg->mg_len;
1269 minmatch = (mg->mg_flags & MGf_MINMATCH);
1270 update_minmatch = 0;
1274 if ((!global && rx->nparens)
1275 || SvTEMP(TARG) || PL_sawampersand)
1276 r_flags |= REXEC_COPY_STR;
1278 r_flags |= REXEC_SCREAM;
1281 if (global && rx->startp[0] != -1) {
1282 t = s = rx->endp[0] + truebase;
1283 if ((s + rx->minlen) > strend)
1285 if (update_minmatch++)
1286 minmatch = had_zerolen;
1288 if (rx->reganch & RE_USE_INTUIT &&
1289 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1290 /* FIXME - can PL_bostr be made const char *? */
1291 PL_bostr = (char *)truebase;
1292 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1296 if ( (rx->reganch & ROPT_CHECK_ALL)
1298 && ((rx->reganch & ROPT_NOSCAN)
1299 || !((rx->reganch & RE_INTUIT_TAIL)
1300 && (r_flags & REXEC_SCREAM)))
1301 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1304 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1307 if (dynpm->op_pmflags & PMf_ONCE)
1308 dynpm->op_pmdynflags |= PMdf_USED;
1317 RX_MATCH_TAINTED_on(rx);
1318 TAINT_IF(RX_MATCH_TAINTED(rx));
1319 if (gimme == G_ARRAY) {
1320 const I32 nparens = rx->nparens;
1321 I32 i = (global && !nparens) ? 1 : 0;
1323 SPAGAIN; /* EVAL blocks could move the stack. */
1324 EXTEND(SP, nparens + i);
1325 EXTEND_MORTAL(nparens + i);
1326 for (i = !i; i <= nparens; i++) {
1327 PUSHs(sv_newmortal());
1328 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1329 const I32 len = rx->endp[i] - rx->startp[i];
1330 s = rx->startp[i] + truebase;
1331 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1332 len < 0 || len > strend - s)
1333 DIE(aTHX_ "panic: pp_match start/end pointers");
1334 sv_setpvn(*SP, s, len);
1335 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1340 if (dynpm->op_pmflags & PMf_CONTINUE) {
1342 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1343 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1345 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1346 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1348 if (rx->startp[0] != -1) {
1349 mg->mg_len = rx->endp[0];
1350 if (rx->startp[0] == rx->endp[0])
1351 mg->mg_flags |= MGf_MINMATCH;
1353 mg->mg_flags &= ~MGf_MINMATCH;
1356 had_zerolen = (rx->startp[0] != -1
1357 && rx->startp[0] == rx->endp[0]);
1358 PUTBACK; /* EVAL blocks may use stack */
1359 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1364 LEAVE_SCOPE(oldsave);
1370 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1371 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1373 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1374 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1376 if (rx->startp[0] != -1) {
1377 mg->mg_len = rx->endp[0];
1378 if (rx->startp[0] == rx->endp[0])
1379 mg->mg_flags |= MGf_MINMATCH;
1381 mg->mg_flags &= ~MGf_MINMATCH;
1384 LEAVE_SCOPE(oldsave);
1388 yup: /* Confirmed by INTUIT */
1390 RX_MATCH_TAINTED_on(rx);
1391 TAINT_IF(RX_MATCH_TAINTED(rx));
1393 if (dynpm->op_pmflags & PMf_ONCE)
1394 dynpm->op_pmdynflags |= PMdf_USED;
1395 if (RX_MATCH_COPIED(rx))
1396 Safefree(rx->subbeg);
1397 RX_MATCH_COPIED_off(rx);
1398 rx->subbeg = Nullch;
1400 /* FIXME - should rx->subbeg be const char *? */
1401 rx->subbeg = (char *) truebase;
1402 rx->startp[0] = s - truebase;
1403 if (RX_MATCH_UTF8(rx)) {
1404 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1405 rx->endp[0] = t - truebase;
1408 rx->endp[0] = s - truebase + rx->minlen;
1410 rx->sublen = strend - truebase;
1413 if (PL_sawampersand) {
1415 #ifdef PERL_OLD_COPY_ON_WRITE
1416 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1418 PerlIO_printf(Perl_debug_log,
1419 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1420 (int) SvTYPE(TARG), truebase, t,
1423 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1424 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1425 assert (SvPOKp(rx->saved_copy));
1430 rx->subbeg = savepvn(t, strend - t);
1431 #ifdef PERL_OLD_COPY_ON_WRITE
1432 rx->saved_copy = Nullsv;
1435 rx->sublen = strend - t;
1436 RX_MATCH_COPIED_on(rx);
1437 off = rx->startp[0] = s - t;
1438 rx->endp[0] = off + rx->minlen;
1440 else { /* startp/endp are used by @- @+. */
1441 rx->startp[0] = s - truebase;
1442 rx->endp[0] = s - truebase + rx->minlen;
1444 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1445 LEAVE_SCOPE(oldsave);
1450 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1451 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1452 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1457 LEAVE_SCOPE(oldsave);
1458 if (gimme == G_ARRAY)
1464 Perl_do_readline(pTHX)
1466 dVAR; dSP; dTARGETSTACKED;
1471 register IO * const io = GvIO(PL_last_in_gv);
1472 register const I32 type = PL_op->op_type;
1473 const I32 gimme = GIMME_V;
1476 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1478 XPUSHs(SvTIED_obj((SV*)io, mg));
1481 call_method("READLINE", gimme);
1484 if (gimme == G_SCALAR) {
1486 SvSetSV_nosteal(TARG, result);
1495 if (IoFLAGS(io) & IOf_ARGV) {
1496 if (IoFLAGS(io) & IOf_START) {
1498 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1499 IoFLAGS(io) &= ~IOf_START;
1500 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1501 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1502 SvSETMAGIC(GvSV(PL_last_in_gv));
1507 fp = nextargv(PL_last_in_gv);
1508 if (!fp) { /* Note: fp != IoIFP(io) */
1509 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1512 else if (type == OP_GLOB)
1513 fp = Perl_start_glob(aTHX_ POPs, io);
1515 else if (type == OP_GLOB)
1517 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1518 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1522 if ((!io || !(IoFLAGS(io) & IOf_START))
1523 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1525 if (type == OP_GLOB)
1526 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1527 "glob failed (can't start child: %s)",
1530 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1532 if (gimme == G_SCALAR) {
1533 /* undef TARG, and push that undefined value */
1534 if (type != OP_RCATLINE) {
1535 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1543 if (gimme == G_SCALAR) {
1547 SvUPGRADE(sv, SVt_PV);
1548 tmplen = SvLEN(sv); /* remember if already alloced */
1549 if (!tmplen && !SvREADONLY(sv))
1550 Sv_Grow(sv, 80); /* try short-buffering it */
1552 if (type == OP_RCATLINE && SvOK(sv)) {
1554 SvPV_force_nolen(sv);
1560 sv = sv_2mortal(NEWSV(57, 80));
1564 /* This should not be marked tainted if the fp is marked clean */
1565 #define MAYBE_TAINT_LINE(io, sv) \
1566 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1571 /* delay EOF state for a snarfed empty file */
1572 #define SNARF_EOF(gimme,rs,io,sv) \
1573 (gimme != G_SCALAR || SvCUR(sv) \
1574 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1578 if (!sv_gets(sv, fp, offset)
1580 || SNARF_EOF(gimme, PL_rs, io, sv)
1581 || PerlIO_error(fp)))
1583 PerlIO_clearerr(fp);
1584 if (IoFLAGS(io) & IOf_ARGV) {
1585 fp = nextargv(PL_last_in_gv);
1588 (void)do_close(PL_last_in_gv, FALSE);
1590 else if (type == OP_GLOB) {
1591 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1592 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1593 "glob failed (child exited with status %d%s)",
1594 (int)(STATUS_CURRENT >> 8),
1595 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1598 if (gimme == G_SCALAR) {
1599 if (type != OP_RCATLINE) {
1600 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1606 MAYBE_TAINT_LINE(io, sv);
1609 MAYBE_TAINT_LINE(io, sv);
1611 IoFLAGS(io) |= IOf_NOLINE;
1615 if (type == OP_GLOB) {
1619 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1620 tmps = SvEND(sv) - 1;
1621 if (*tmps == *SvPVX_const(PL_rs)) {
1623 SvCUR_set(sv, SvCUR(sv) - 1);
1626 for (t1 = SvPVX_const(sv); *t1; t1++)
1627 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1628 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1630 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1631 (void)POPs; /* Unmatched wildcard? Chuck it... */
1634 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1635 const U8 *s = (const U8*)SvPVX_const(sv) + offset;
1636 const STRLEN len = SvCUR(sv) - offset;
1639 if (ckWARN(WARN_UTF8) &&
1640 !is_utf8_string_loc(s, len, &f))
1641 /* Emulate :encoding(utf8) warning in the same case. */
1642 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1643 "utf8 \"\\x%02X\" does not map to Unicode",
1644 f < (U8*)SvEND(sv) ? *f : 0);
1646 if (gimme == G_ARRAY) {
1647 if (SvLEN(sv) - SvCUR(sv) > 20) {
1648 SvPV_shrink_to_cur(sv);
1650 sv = sv_2mortal(NEWSV(58, 80));
1653 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1654 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1655 const STRLEN new_len
1656 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1657 SvPV_renew(sv, new_len);
1666 register PERL_CONTEXT *cx;
1667 I32 gimme = OP_GIMME(PL_op, -1);
1670 if (cxstack_ix >= 0)
1671 gimme = cxstack[cxstack_ix].blk_gimme;
1679 PUSHBLOCK(cx, CXt_BLOCK, SP);
1691 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1692 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1694 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1697 if (SvTYPE(hv) == SVt_PVHV) {
1698 if (PL_op->op_private & OPpLVAL_INTRO) {
1701 /* does the element we're localizing already exist? */
1703 /* can we determine whether it exists? */
1705 || mg_find((SV*)hv, PERL_MAGIC_env)
1706 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1707 /* Try to preserve the existenceness of a tied hash
1708 * element by using EXISTS and DELETE if possible.
1709 * Fallback to FETCH and STORE otherwise */
1710 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1711 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1712 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1714 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1717 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1718 svp = he ? &HeVAL(he) : 0;
1724 if (!svp || *svp == &PL_sv_undef) {
1728 DIE(aTHX_ PL_no_helem_sv, keysv);
1730 lv = sv_newmortal();
1731 sv_upgrade(lv, SVt_PVLV);
1733 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1734 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1735 LvTARG(lv) = SvREFCNT_inc(hv);
1740 if (PL_op->op_private & OPpLVAL_INTRO) {
1741 if (HvNAME_get(hv) && isGV(*svp))
1742 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1746 const char * const key = SvPV_const(keysv, keylen);
1747 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1749 save_helem(hv, keysv, svp);
1752 else if (PL_op->op_private & OPpDEREF)
1753 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1755 sv = (svp ? *svp : &PL_sv_undef);
1756 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1757 * Pushing the magical RHS on to the stack is useless, since
1758 * that magic is soon destined to be misled by the local(),
1759 * and thus the later pp_sassign() will fail to mg_get() the
1760 * old value. This should also cure problems with delayed
1761 * mg_get()s. GSAR 98-07-03 */
1762 if (!lval && SvGMAGICAL(sv))
1763 sv = sv_mortalcopy(sv);
1771 register PERL_CONTEXT *cx;
1776 if (PL_op->op_flags & OPf_SPECIAL) {
1777 cx = &cxstack[cxstack_ix];
1778 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1783 gimme = OP_GIMME(PL_op, -1);
1785 if (cxstack_ix >= 0)
1786 gimme = cxstack[cxstack_ix].blk_gimme;
1792 if (gimme == G_VOID)
1794 else if (gimme == G_SCALAR) {
1798 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1801 *MARK = sv_mortalcopy(TOPs);
1804 *MARK = &PL_sv_undef;
1808 else if (gimme == G_ARRAY) {
1809 /* in case LEAVE wipes old return values */
1811 for (mark = newsp + 1; mark <= SP; mark++) {
1812 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1813 *mark = sv_mortalcopy(*mark);
1814 TAINT_NOT; /* Each item is independent */
1818 PL_curpm = newpm; /* Don't pop $1 et al till now */
1828 register PERL_CONTEXT *cx;
1834 cx = &cxstack[cxstack_ix];
1835 if (CxTYPE(cx) != CXt_LOOP)
1836 DIE(aTHX_ "panic: pp_iter");
1838 itersvp = CxITERVAR(cx);
1839 av = cx->blk_loop.iterary;
1840 if (SvTYPE(av) != SVt_PVAV) {
1841 /* iterate ($min .. $max) */
1842 if (cx->blk_loop.iterlval) {
1843 /* string increment */
1844 register SV* cur = cx->blk_loop.iterlval;
1846 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1847 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1848 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1849 /* safe to reuse old SV */
1850 sv_setsv(*itersvp, cur);
1854 /* we need a fresh SV every time so that loop body sees a
1855 * completely new SV for closures/references to work as
1858 *itersvp = newSVsv(cur);
1859 SvREFCNT_dec(oldsv);
1861 if (strEQ(SvPVX_const(cur), max))
1862 sv_setiv(cur, 0); /* terminate next time */
1869 /* integer increment */
1870 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1873 /* don't risk potential race */
1874 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1875 /* safe to reuse old SV */
1876 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1880 /* we need a fresh SV every time so that loop body sees a
1881 * completely new SV for closures/references to work as they
1884 *itersvp = newSViv(cx->blk_loop.iterix++);
1885 SvREFCNT_dec(oldsv);
1891 if (PL_op->op_private & OPpITER_REVERSED) {
1892 /* In reverse, use itermax as the min :-) */
1893 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1896 if (SvMAGICAL(av) || AvREIFY(av)) {
1897 SV ** const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1898 sv = svp ? *svp : Nullsv;
1901 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1905 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1909 if (SvMAGICAL(av) || AvREIFY(av)) {
1910 SV ** const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1911 sv = svp ? *svp : Nullsv;
1914 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1918 if (sv && SvIS_FREED(sv)) {
1920 Perl_croak(aTHX_ "Use of freed value in iteration");
1927 if (av != PL_curstack && sv == &PL_sv_undef) {
1928 SV *lv = cx->blk_loop.iterlval;
1929 if (lv && SvREFCNT(lv) > 1) {
1934 SvREFCNT_dec(LvTARG(lv));
1936 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1937 sv_upgrade(lv, SVt_PVLV);
1939 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1941 LvTARG(lv) = SvREFCNT_inc(av);
1942 LvTARGOFF(lv) = cx->blk_loop.iterix;
1943 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1948 *itersvp = SvREFCNT_inc(sv);
1949 SvREFCNT_dec(oldsv);
1957 register PMOP *pm = cPMOP;
1973 register REGEXP *rx = PM_GETRE(pm);
1975 int force_on_match = 0;
1976 const I32 oldsave = PL_savestack_ix;
1978 bool doutf8 = FALSE;
1979 #ifdef PERL_OLD_COPY_ON_WRITE
1984 /* known replacement string? */
1985 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1986 if (PL_op->op_flags & OPf_STACKED)
1988 else if (PL_op->op_private & OPpTARGET_MY)
1995 #ifdef PERL_OLD_COPY_ON_WRITE
1996 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1997 because they make integers such as 256 "false". */
1998 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2001 sv_force_normal_flags(TARG,0);
2004 #ifdef PERL_OLD_COPY_ON_WRITE
2008 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2009 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2010 DIE(aTHX_ PL_no_modify);
2013 s = SvPV_mutable(TARG, len);
2014 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2016 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2017 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2022 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2026 DIE(aTHX_ "panic: pp_subst");
2029 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2030 maxiters = 2 * slen + 10; /* We can match twice at each
2031 position, once with zero-length,
2032 second time with non-zero. */
2034 if (!rx->prelen && PL_curpm) {
2038 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2039 ? REXEC_COPY_STR : 0;
2041 r_flags |= REXEC_SCREAM;
2044 if (rx->reganch & RE_USE_INTUIT) {
2046 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2050 /* How to do it in subst? */
2051 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2053 && ((rx->reganch & ROPT_NOSCAN)
2054 || !((rx->reganch & RE_INTUIT_TAIL)
2055 && (r_flags & REXEC_SCREAM))))
2060 /* only replace once? */
2061 once = !(rpm->op_pmflags & PMf_GLOBAL);
2063 /* known replacement string? */
2065 /* replacement needing upgrading? */
2066 if (DO_UTF8(TARG) && !doutf8) {
2067 nsv = sv_newmortal();
2070 sv_recode_to_utf8(nsv, PL_encoding);
2072 sv_utf8_upgrade(nsv);
2073 c = SvPV_const(nsv, clen);
2077 c = SvPV_const(dstr, clen);
2078 doutf8 = DO_UTF8(dstr);
2086 /* can do inplace substitution? */
2088 #ifdef PERL_OLD_COPY_ON_WRITE
2091 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2092 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2093 && (!doutf8 || SvUTF8(TARG))) {
2094 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2095 r_flags | REXEC_CHECKED))
2099 LEAVE_SCOPE(oldsave);
2102 #ifdef PERL_OLD_COPY_ON_WRITE
2103 if (SvIsCOW(TARG)) {
2104 assert (!force_on_match);
2108 if (force_on_match) {
2110 s = SvPV_force(TARG, len);
2115 SvSCREAM_off(TARG); /* disable possible screamer */
2117 rxtainted |= RX_MATCH_TAINTED(rx);
2118 m = orig + rx->startp[0];
2119 d = orig + rx->endp[0];
2121 if (m - s > strend - d) { /* faster to shorten from end */
2123 Copy(c, m, clen, char);
2128 Move(d, m, i, char);
2132 SvCUR_set(TARG, m - s);
2134 else if ((i = m - s)) { /* faster from front */
2142 Copy(c, m, clen, char);
2147 Copy(c, d, clen, char);
2152 TAINT_IF(rxtainted & 1);
2158 if (iters++ > maxiters)
2159 DIE(aTHX_ "Substitution loop");
2160 rxtainted |= RX_MATCH_TAINTED(rx);
2161 m = rx->startp[0] + orig;
2164 Move(s, d, i, char);
2168 Copy(c, d, clen, char);
2171 s = rx->endp[0] + orig;
2172 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2174 /* don't match same null twice */
2175 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2178 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2179 Move(s, d, i+1, char); /* include the NUL */
2181 TAINT_IF(rxtainted & 1);
2183 PUSHs(sv_2mortal(newSViv((I32)iters)));
2185 (void)SvPOK_only_UTF8(TARG);
2186 TAINT_IF(rxtainted);
2187 if (SvSMAGICAL(TARG)) {
2195 LEAVE_SCOPE(oldsave);
2199 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2200 r_flags | REXEC_CHECKED))
2202 if (force_on_match) {
2204 s = SvPV_force(TARG, len);
2207 #ifdef PERL_OLD_COPY_ON_WRITE
2210 rxtainted |= RX_MATCH_TAINTED(rx);
2211 dstr = newSVpvn(m, s-m);
2216 register PERL_CONTEXT *cx;
2218 (void)ReREFCNT_inc(rx);
2220 RETURNOP(cPMOP->op_pmreplroot);
2222 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2224 if (iters++ > maxiters)
2225 DIE(aTHX_ "Substitution loop");
2226 rxtainted |= RX_MATCH_TAINTED(rx);
2227 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2232 strend = s + (strend - m);
2234 m = rx->startp[0] + orig;
2235 if (doutf8 && !SvUTF8(dstr))
2236 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2238 sv_catpvn(dstr, s, m-s);
2239 s = rx->endp[0] + orig;
2241 sv_catpvn(dstr, c, clen);
2244 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2245 TARG, NULL, r_flags));
2246 if (doutf8 && !DO_UTF8(TARG))
2247 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2249 sv_catpvn(dstr, s, strend - s);
2251 #ifdef PERL_OLD_COPY_ON_WRITE
2252 /* The match may make the string COW. If so, brilliant, because that's
2253 just saved us one malloc, copy and free - the regexp has donated
2254 the old buffer, and we malloc an entirely new one, rather than the
2255 regexp malloc()ing a buffer and copying our original, only for
2256 us to throw it away here during the substitution. */
2257 if (SvIsCOW(TARG)) {
2258 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2264 SvPV_set(TARG, SvPVX(dstr));
2265 SvCUR_set(TARG, SvCUR(dstr));
2266 SvLEN_set(TARG, SvLEN(dstr));
2267 doutf8 |= DO_UTF8(dstr);
2268 SvPV_set(dstr, (char*)0);
2271 TAINT_IF(rxtainted & 1);
2273 PUSHs(sv_2mortal(newSViv((I32)iters)));
2275 (void)SvPOK_only(TARG);
2278 TAINT_IF(rxtainted);
2281 LEAVE_SCOPE(oldsave);
2290 LEAVE_SCOPE(oldsave);
2299 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2300 ++*PL_markstack_ptr;
2301 LEAVE; /* exit inner scope */
2304 if (PL_stack_base + *PL_markstack_ptr > SP) {
2306 const I32 gimme = GIMME_V;
2308 LEAVE; /* exit outer scope */
2309 (void)POPMARK; /* pop src */
2310 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2311 (void)POPMARK; /* pop dst */
2312 SP = PL_stack_base + POPMARK; /* pop original mark */
2313 if (gimme == G_SCALAR) {
2314 if (PL_op->op_private & OPpGREP_LEX) {
2315 SV* const sv = sv_newmortal();
2316 sv_setiv(sv, items);
2324 else if (gimme == G_ARRAY)
2331 ENTER; /* enter inner scope */
2334 src = PL_stack_base[*PL_markstack_ptr];
2336 if (PL_op->op_private & OPpGREP_LEX)
2337 PAD_SVl(PL_op->op_targ) = src;
2341 RETURNOP(cLOGOP->op_other);
2352 register PERL_CONTEXT *cx;
2355 if (CxMULTICALL(&cxstack[cxstack_ix]))
2359 cxstack_ix++; /* temporarily protect top context */
2362 if (gimme == G_SCALAR) {
2365 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2367 *MARK = SvREFCNT_inc(TOPs);
2372 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2374 *MARK = sv_mortalcopy(sv);
2379 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2383 *MARK = &PL_sv_undef;
2387 else if (gimme == G_ARRAY) {
2388 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2389 if (!SvTEMP(*MARK)) {
2390 *MARK = sv_mortalcopy(*MARK);
2391 TAINT_NOT; /* Each item is independent */
2399 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2400 PL_curpm = newpm; /* ... and pop $1 et al */
2403 return cx->blk_sub.retop;
2406 /* This duplicates the above code because the above code must not
2407 * get any slower by more conditions */
2415 register PERL_CONTEXT *cx;
2418 if (CxMULTICALL(&cxstack[cxstack_ix]))
2422 cxstack_ix++; /* temporarily protect top context */
2426 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2427 /* We are an argument to a function or grep().
2428 * This kind of lvalueness was legal before lvalue
2429 * subroutines too, so be backward compatible:
2430 * cannot report errors. */
2432 /* Scalar context *is* possible, on the LHS of -> only,
2433 * as in f()->meth(). But this is not an lvalue. */
2434 if (gimme == G_SCALAR)
2436 if (gimme == G_ARRAY) {
2437 if (!CvLVALUE(cx->blk_sub.cv))
2438 goto temporise_array;
2439 EXTEND_MORTAL(SP - newsp);
2440 for (mark = newsp + 1; mark <= SP; mark++) {
2443 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2444 *mark = sv_mortalcopy(*mark);
2446 /* Can be a localized value subject to deletion. */
2447 PL_tmps_stack[++PL_tmps_ix] = *mark;
2448 (void)SvREFCNT_inc(*mark);
2453 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2454 /* Here we go for robustness, not for speed, so we change all
2455 * the refcounts so the caller gets a live guy. Cannot set
2456 * TEMP, so sv_2mortal is out of question. */
2457 if (!CvLVALUE(cx->blk_sub.cv)) {
2463 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2465 if (gimme == G_SCALAR) {
2469 /* Temporaries are bad unless they happen to be elements
2470 * of a tied hash or array */
2471 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2472 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2478 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2479 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2480 : "a readonly value" : "a temporary");
2482 else { /* Can be a localized value
2483 * subject to deletion. */
2484 PL_tmps_stack[++PL_tmps_ix] = *mark;
2485 (void)SvREFCNT_inc(*mark);
2488 else { /* Should not happen? */
2494 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2495 (MARK > SP ? "Empty array" : "Array"));
2499 else if (gimme == G_ARRAY) {
2500 EXTEND_MORTAL(SP - newsp);
2501 for (mark = newsp + 1; mark <= SP; mark++) {
2502 if (*mark != &PL_sv_undef
2503 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2504 /* Might be flattened array after $#array = */
2511 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2512 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2515 /* Can be a localized value subject to deletion. */
2516 PL_tmps_stack[++PL_tmps_ix] = *mark;
2517 (void)SvREFCNT_inc(*mark);
2523 if (gimme == G_SCALAR) {
2527 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2529 *MARK = SvREFCNT_inc(TOPs);
2534 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2536 *MARK = sv_mortalcopy(sv);
2541 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2545 *MARK = &PL_sv_undef;
2549 else if (gimme == G_ARRAY) {
2551 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2552 if (!SvTEMP(*MARK)) {
2553 *MARK = sv_mortalcopy(*MARK);
2554 TAINT_NOT; /* Each item is independent */
2563 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2564 PL_curpm = newpm; /* ... and pop $1 et al */
2567 return cx->blk_sub.retop;
2572 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2574 SV * const dbsv = GvSVn(PL_DBsub);
2577 if (!PERLDB_SUB_NN) {
2580 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2581 || strEQ(GvNAME(gv), "END")
2582 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2583 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2584 && (gv = (GV*)*svp) ))) {
2585 /* Use GV from the stack as a fallback. */
2586 /* GV is potentially non-unique, or contain different CV. */
2587 SV * const tmp = newRV((SV*)cv);
2588 sv_setsv(dbsv, tmp);
2592 gv_efullname3(dbsv, gv, Nullch);
2596 const int type = SvTYPE(dbsv);
2597 if (type < SVt_PVIV && type != SVt_IV)
2598 sv_upgrade(dbsv, SVt_PVIV);
2599 (void)SvIOK_on(dbsv);
2600 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2604 PL_curcopdb = PL_curcop;
2605 cv = GvCV(PL_DBsub);
2615 register PERL_CONTEXT *cx;
2617 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2620 DIE(aTHX_ "Not a CODE reference");
2621 switch (SvTYPE(sv)) {
2622 /* This is overwhelming the most common case: */
2624 if (!(cv = GvCVu((GV*)sv)))
2625 cv = sv_2cv(sv, &stash, &gv, FALSE);
2635 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2637 SP = PL_stack_base + POPMARK;
2640 if (SvGMAGICAL(sv)) {
2644 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2647 sym = SvPV_nolen_const(sv);
2650 DIE(aTHX_ PL_no_usym, "a subroutine");
2651 if (PL_op->op_private & HINT_STRICT_REFS)
2652 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2653 cv = get_cv(sym, TRUE);
2658 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2659 tryAMAGICunDEREF(to_cv);
2662 if (SvTYPE(cv) == SVt_PVCV)
2667 DIE(aTHX_ "Not a CODE reference");
2668 /* This is the second most common case: */
2678 if (!CvROOT(cv) && !CvXSUB(cv)) {
2683 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2684 if (CvASSERTION(cv) && PL_DBassertion)
2685 sv_setiv(PL_DBassertion, 1);
2687 cv = get_db_sub(&sv, cv);
2688 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2689 DIE(aTHX_ "No DB::sub routine defined");
2692 if (!(CvXSUB(cv))) {
2693 /* This path taken at least 75% of the time */
2695 register I32 items = SP - MARK;
2696 AV* const padlist = CvPADLIST(cv);
2697 PUSHBLOCK(cx, CXt_SUB, MARK);
2699 cx->blk_sub.retop = PL_op->op_next;
2701 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2702 * that eval'' ops within this sub know the correct lexical space.
2703 * Owing the speed considerations, we choose instead to search for
2704 * the cv using find_runcv() when calling doeval().
2706 if (CvDEPTH(cv) >= 2) {
2707 PERL_STACK_OVERFLOW_CHECK();
2708 pad_push(padlist, CvDEPTH(cv));
2711 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2714 AV* const av = (AV*)PAD_SVl(0);
2716 /* @_ is normally not REAL--this should only ever
2717 * happen when DB::sub() calls things that modify @_ */
2722 cx->blk_sub.savearray = GvAV(PL_defgv);
2723 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2724 CX_CURPAD_SAVE(cx->blk_sub);
2725 cx->blk_sub.argarray = av;
2728 if (items > AvMAX(av) + 1) {
2729 SV **ary = AvALLOC(av);
2730 if (AvARRAY(av) != ary) {
2731 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2732 SvPV_set(av, (char*)ary);
2734 if (items > AvMAX(av) + 1) {
2735 AvMAX(av) = items - 1;
2736 Renew(ary,items,SV*);
2738 SvPV_set(av, (char*)ary);
2741 Copy(MARK,AvARRAY(av),items,SV*);
2742 AvFILLp(av) = items - 1;
2750 /* warning must come *after* we fully set up the context
2751 * stuff so that __WARN__ handlers can safely dounwind()
2754 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2755 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2756 sub_crush_depth(cv);
2758 DEBUG_S(PerlIO_printf(Perl_debug_log,
2759 "%p entersub returning %p\n", thr, CvSTART(cv)));
2761 RETURNOP(CvSTART(cv));
2764 #ifdef PERL_XSUB_OLDSTYLE
2765 if (CvOLDSTYLE(cv)) {
2766 I32 (*fp3)(int,int,int);
2768 register I32 items = SP - MARK;
2769 /* We dont worry to copy from @_. */
2774 PL_stack_sp = mark + 1;
2775 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2776 items = (*fp3)(CvXSUBANY(cv).any_i32,
2777 MARK - PL_stack_base + 1,
2779 PL_stack_sp = PL_stack_base + items;
2782 #endif /* PERL_XSUB_OLDSTYLE */
2784 I32 markix = TOPMARK;
2789 /* Need to copy @_ to stack. Alternative may be to
2790 * switch stack to @_, and copy return values
2791 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2792 AV * const av = GvAV(PL_defgv);
2793 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2796 /* Mark is at the end of the stack. */
2798 Copy(AvARRAY(av), SP + 1, items, SV*);
2803 /* We assume first XSUB in &DB::sub is the called one. */
2805 SAVEVPTR(PL_curcop);
2806 PL_curcop = PL_curcopdb;
2809 /* Do we need to open block here? XXXX */
2810 (void)(*CvXSUB(cv))(aTHX_ cv);
2812 /* Enforce some sanity in scalar context. */
2813 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2814 if (markix > PL_stack_sp - PL_stack_base)
2815 *(PL_stack_base + markix) = &PL_sv_undef;
2817 *(PL_stack_base + markix) = *PL_stack_sp;
2818 PL_stack_sp = PL_stack_base + markix;
2826 assert (0); /* Cannot get here. */
2827 /* This is deliberately moved here as spaghetti code to keep it out of the
2834 /* anonymous or undef'd function leaves us no recourse */
2835 if (CvANON(cv) || !(gv = CvGV(cv)))
2836 DIE(aTHX_ "Undefined subroutine called");
2838 /* autoloaded stub? */
2839 if (cv != GvCV(gv)) {
2842 /* should call AUTOLOAD now? */
2845 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2852 sub_name = sv_newmortal();
2853 gv_efullname3(sub_name, gv, Nullch);
2854 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2858 DIE(aTHX_ "Not a CODE reference");
2864 Perl_sub_crush_depth(pTHX_ CV *cv)
2867 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2869 SV* const tmpstr = sv_newmortal();
2870 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2871 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2880 SV* const elemsv = POPs;
2881 IV elem = SvIV(elemsv);
2882 AV* const av = (AV*)POPs;
2883 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2884 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2887 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2888 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2890 elem -= PL_curcop->cop_arybase;
2891 if (SvTYPE(av) != SVt_PVAV)
2893 svp = av_fetch(av, elem, lval && !defer);
2895 #ifdef PERL_MALLOC_WRAP
2896 if (SvUOK(elemsv)) {
2897 const UV uv = SvUV(elemsv);
2898 elem = uv > IV_MAX ? IV_MAX : uv;
2900 else if (SvNOK(elemsv))
2901 elem = (IV)SvNV(elemsv);
2903 static const char oom_array_extend[] =
2904 "Out of memory during array extend"; /* Duplicated in av.c */
2905 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2908 if (!svp || *svp == &PL_sv_undef) {
2911 DIE(aTHX_ PL_no_aelem, elem);
2912 lv = sv_newmortal();
2913 sv_upgrade(lv, SVt_PVLV);
2915 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2916 LvTARG(lv) = SvREFCNT_inc(av);
2917 LvTARGOFF(lv) = elem;
2922 if (PL_op->op_private & OPpLVAL_INTRO)
2923 save_aelem(av, elem, svp);
2924 else if (PL_op->op_private & OPpDEREF)
2925 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2927 sv = (svp ? *svp : &PL_sv_undef);
2928 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2929 sv = sv_mortalcopy(sv);
2935 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2940 Perl_croak(aTHX_ PL_no_modify);
2941 if (SvTYPE(sv) < SVt_RV)
2942 sv_upgrade(sv, SVt_RV);
2943 else if (SvTYPE(sv) >= SVt_PV) {
2950 SvRV_set(sv, NEWSV(355,0));
2953 SvRV_set(sv, (SV*)newAV());
2956 SvRV_set(sv, (SV*)newHV());
2967 SV* const sv = TOPs;
2970 SV* const rsv = SvRV(sv);
2971 if (SvTYPE(rsv) == SVt_PVCV) {
2977 SETs(method_common(sv, Null(U32*)));
2984 SV* const sv = cSVOP_sv;
2985 U32 hash = SvSHARED_HASH(sv);
2987 XPUSHs(method_common(sv, &hash));
2992 S_method_common(pTHX_ SV* meth, U32* hashp)
2998 const char* packname = Nullch;
2999 SV *packsv = Nullsv;
3001 const char * const name = SvPV_const(meth, namelen);
3002 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3005 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3013 /* this isn't a reference */
3014 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3015 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3017 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3024 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3025 !(ob=(SV*)GvIO(iogv)))
3027 /* this isn't the name of a filehandle either */
3029 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3030 ? !isIDFIRST_utf8((U8*)packname)
3031 : !isIDFIRST(*packname)
3034 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3035 SvOK(sv) ? "without a package or object reference"
3036 : "on an undefined value");
3038 /* assume it's a package name */
3039 stash = gv_stashpvn(packname, packlen, FALSE);
3043 SV* ref = newSViv(PTR2IV(stash));
3044 hv_store(PL_stashcache, packname, packlen, ref, 0);
3048 /* it _is_ a filehandle name -- replace with a reference */
3049 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3052 /* if we got here, ob should be a reference or a glob */
3053 if (!ob || !(SvOBJECT(ob)
3054 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3057 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3061 stash = SvSTASH(ob);
3064 /* NOTE: stash may be null, hope hv_fetch_ent and
3065 gv_fetchmethod can cope (it seems they can) */
3067 /* shortcut for simple names */
3069 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3071 gv = (GV*)HeVAL(he);
3072 if (isGV(gv) && GvCV(gv) &&
3073 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3074 return (SV*)GvCV(gv);
3078 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3081 /* This code tries to figure out just what went wrong with
3082 gv_fetchmethod. It therefore needs to duplicate a lot of
3083 the internals of that function. We can't move it inside
3084 Perl_gv_fetchmethod_autoload(), however, since that would
3085 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3088 const char* leaf = name;
3089 const char* sep = Nullch;
3092 for (p = name; *p; p++) {
3094 sep = p, leaf = p + 1;
3095 else if (*p == ':' && *(p + 1) == ':')
3096 sep = p, leaf = p + 2;
3098 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3099 /* the method name is unqualified or starts with SUPER:: */
3100 bool need_strlen = 1;
3102 packname = CopSTASHPV(PL_curcop);
3105 HEK * const packhek = HvNAME_HEK(stash);
3107 packname = HEK_KEY(packhek);
3108 packlen = HEK_LEN(packhek);
3118 "Can't use anonymous symbol table for method lookup");
3120 else if (need_strlen)
3121 packlen = strlen(packname);
3125 /* the method name is qualified */
3127 packlen = sep - name;
3130 /* we're relying on gv_fetchmethod not autovivifying the stash */
3131 if (gv_stashpvn(packname, packlen, FALSE)) {
3133 "Can't locate object method \"%s\" via package \"%.*s\"",
3134 leaf, (int)packlen, packname);
3138 "Can't locate object method \"%s\" via package \"%.*s\""
3139 " (perhaps you forgot to load \"%.*s\"?)",
3140 leaf, (int)packlen, packname, (int)packlen, packname);
3143 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3148 * c-indentation-style: bsd
3150 * indent-tabs-mode: t
3153 * ex: set ts=8 sts=4 sw=4 noet: