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(GvSV(cGVOP_gv));
72 PL_curcop = (COP*)PL_op;
78 PUSHMARK(PL_stack_sp);
93 XPUSHs((SV*)cGVOP_gv);
104 RETURNOP(cLOGOP->op_other);
112 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
114 temp = left; left = right; right = temp;
116 if (PL_tainting && PL_tainted && !SvTAINTED(left))
118 SvSetMagicSV(right, left);
127 RETURNOP(cLOGOP->op_other);
129 RETURNOP(cLOGOP->op_next);
135 TAINT_NOT; /* Each statement is presumed innocent */
136 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
138 oldsave = PL_scopestack[PL_scopestack_ix - 1];
139 LEAVE_SCOPE(oldsave);
145 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
150 const char *rpv = SvPV_const(right, rlen); /* mg_get(right) happens here */
151 const bool rbyte = !DO_UTF8(right);
152 bool rcopied = FALSE;
154 if (TARG == right && right != left) {
155 right = sv_2mortal(newSVpvn(rpv, rlen));
156 rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
162 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
163 lbyte = !DO_UTF8(left);
164 sv_setpvn(TARG, lpv, llen);
170 else { /* TARG == left */
172 if (SvGMAGICAL(left))
173 mg_get(left); /* or mg_get(left) may happen here */
175 sv_setpvn(left, "", 0);
176 (void)SvPV_nomg(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(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 */
324 RETURNOP(cLOGOP->op_other);
330 /* Most of this is lifted straight from pp_defined */
332 register SV* const sv = TOPs;
334 if (!sv || !SvANY(sv)) {
336 RETURNOP(cLOGOP->op_other);
339 switch (SvTYPE(sv)) {
341 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
345 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
349 if (CvROOT(sv) || CvXSUB(sv))
360 RETURNOP(cLOGOP->op_other);
365 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
366 useleft = USE_LEFT(TOPm1s);
367 #ifdef PERL_PRESERVE_IVUV
368 /* We must see if we can perform the addition with integers if possible,
369 as the integer code detects overflow while the NV code doesn't.
370 If either argument hasn't had a numeric conversion yet attempt to get
371 the IV. It's important to do this now, rather than just assuming that
372 it's not IOK as a PV of "9223372036854775806" may not take well to NV
373 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
374 integer in case the second argument is IV=9223372036854775806
375 We can (now) rely on sv_2iv to do the right thing, only setting the
376 public IOK flag if the value in the NV (or PV) slot is truly integer.
378 A side effect is that this also aggressively prefers integer maths over
379 fp maths for integer values.
381 How to detect overflow?
383 C 99 section 6.2.6.1 says
385 The range of nonnegative values of a signed integer type is a subrange
386 of the corresponding unsigned integer type, and the representation of
387 the same value in each type is the same. A computation involving
388 unsigned operands can never overflow, because a result that cannot be
389 represented by the resulting unsigned integer type is reduced modulo
390 the number that is one greater than the largest value that can be
391 represented by the resulting type.
395 which I read as "unsigned ints wrap."
397 signed integer overflow seems to be classed as "exception condition"
399 If an exceptional condition occurs during the evaluation of an
400 expression (that is, if the result is not mathematically defined or not
401 in the range of representable values for its type), the behavior is
404 (6.5, the 5th paragraph)
406 I had assumed that on 2s complement machines signed arithmetic would
407 wrap, hence coded pp_add and pp_subtract on the assumption that
408 everything perl builds on would be happy. After much wailing and
409 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
410 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
411 unsigned code below is actually shorter than the old code. :-)
416 /* Unless the left argument is integer in range we are going to have to
417 use NV maths. Hence only attempt to coerce the right argument if
418 we know the left is integer. */
426 /* left operand is undef, treat as zero. + 0 is identity,
427 Could SETi or SETu right now, but space optimise by not adding
428 lots of code to speed up what is probably a rarish case. */
430 /* Left operand is defined, so is it IV? */
433 if ((auvok = SvUOK(TOPm1s)))
436 register const IV aiv = SvIVX(TOPm1s);
439 auvok = 1; /* Now acting as a sign flag. */
440 } else { /* 2s complement assumption for IV_MIN */
448 bool result_good = 0;
451 bool buvok = SvUOK(TOPs);
456 register const IV biv = SvIVX(TOPs);
463 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
464 else "IV" now, independent of how it came in.
465 if a, b represents positive, A, B negative, a maps to -A etc
470 all UV maths. negate result if A negative.
471 add if signs same, subtract if signs differ. */
477 /* Must get smaller */
483 /* result really should be -(auv-buv). as its negation
484 of true value, need to swap our result flag */
501 if (result <= (UV)IV_MIN)
504 /* result valid, but out of range for IV. */
509 } /* Overflow, drop through to NVs. */
516 /* left operand is undef, treat as zero. + 0.0 is identity. */
520 SETn( value + TOPn );
528 AV *av = PL_op->op_flags & OPf_SPECIAL ?
529 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
530 const U32 lval = PL_op->op_flags & OPf_MOD;
531 SV** svp = av_fetch(av, PL_op->op_private, lval);
532 SV *sv = (svp ? *svp : &PL_sv_undef);
534 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
535 sv = sv_mortalcopy(sv);
544 do_join(TARG, *MARK, MARK, SP);
555 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
556 * will be enough to hold an OP*.
558 SV* sv = sv_newmortal();
559 sv_upgrade(sv, SVt_PVLV);
561 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
569 /* Oversized hot code. */
573 dVAR; dSP; dMARK; dORIGMARK;
579 if (PL_op->op_flags & OPf_STACKED)
584 if (gv && (io = GvIO(gv))
585 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
588 if (MARK == ORIGMARK) {
589 /* If using default handle then we need to make space to
590 * pass object as 1st arg, so move other args up ...
594 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
598 *MARK = SvTIED_obj((SV*)io, mg);
601 call_method("PRINT", G_SCALAR);
609 if (!(io = GvIO(gv))) {
610 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
611 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
613 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
614 report_evil_fh(gv, io, PL_op->op_type);
615 SETERRNO(EBADF,RMS_IFI);
618 else if (!(fp = IoOFP(io))) {
619 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
621 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
622 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
623 report_evil_fh(gv, io, PL_op->op_type);
625 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
630 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
632 if (!do_print(*MARK, fp))
636 if (!do_print(PL_ofs_sv, fp)) { /* $, */
645 if (!do_print(*MARK, fp))
653 if (PL_ors_sv && SvOK(PL_ors_sv))
654 if (!do_print(PL_ors_sv, fp)) /* $\ */
657 if (IoFLAGS(io) & IOf_FLUSH)
658 if (PerlIO_flush(fp) == EOF)
679 tryAMAGICunDEREF(to_av);
682 if (SvTYPE(av) != SVt_PVAV)
683 DIE(aTHX_ "Not an ARRAY reference");
684 if (PL_op->op_flags & OPf_REF) {
689 if (GIMME == G_SCALAR)
690 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
694 else if (PL_op->op_flags & OPf_MOD
695 && PL_op->op_private & OPpLVAL_INTRO)
696 Perl_croak(aTHX_ PL_no_localize_ref);
699 if (SvTYPE(sv) == SVt_PVAV) {
701 if (PL_op->op_flags & OPf_REF) {
706 if (GIMME == G_SCALAR)
707 Perl_croak(aTHX_ "Can't return array to lvalue"
716 if (SvTYPE(sv) != SVt_PVGV) {
717 if (SvGMAGICAL(sv)) {
723 if (PL_op->op_flags & OPf_REF ||
724 PL_op->op_private & HINT_STRICT_REFS)
725 DIE(aTHX_ PL_no_usym, "an ARRAY");
726 if (ckWARN(WARN_UNINITIALIZED))
728 if (GIMME == G_ARRAY) {
734 if ((PL_op->op_flags & OPf_SPECIAL) &&
735 !(PL_op->op_flags & OPf_MOD))
737 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
739 && (!is_gv_magical_sv(sv,0)
740 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
746 if (PL_op->op_private & HINT_STRICT_REFS)
747 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
748 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
755 if (PL_op->op_private & OPpLVAL_INTRO)
757 if (PL_op->op_flags & OPf_REF) {
762 if (GIMME == G_SCALAR)
763 Perl_croak(aTHX_ "Can't return array to lvalue"
771 if (GIMME == G_ARRAY) {
772 const I32 maxarg = AvFILL(av) + 1;
773 (void)POPs; /* XXXX May be optimized away? */
775 if (SvRMAGICAL(av)) {
777 for (i=0; i < (U32)maxarg; i++) {
778 SV **svp = av_fetch(av, i, FALSE);
779 /* See note in pp_helem, and bug id #27839 */
781 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
786 Copy(AvARRAY(av), SP+1, maxarg, SV*);
790 else if (GIMME_V == G_SCALAR) {
792 const I32 maxarg = AvFILL(av) + 1;
802 const I32 gimme = GIMME_V;
803 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
807 tryAMAGICunDEREF(to_hv);
810 if (SvTYPE(hv) != SVt_PVHV)
811 DIE(aTHX_ "Not a HASH reference");
812 if (PL_op->op_flags & OPf_REF) {
817 if (gimme != G_ARRAY)
818 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
822 else if (PL_op->op_flags & OPf_MOD
823 && PL_op->op_private & OPpLVAL_INTRO)
824 Perl_croak(aTHX_ PL_no_localize_ref);
827 if (SvTYPE(sv) == SVt_PVHV) {
829 if (PL_op->op_flags & OPf_REF) {
834 if (gimme != G_ARRAY)
835 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
843 if (SvTYPE(sv) != SVt_PVGV) {
844 if (SvGMAGICAL(sv)) {
850 if (PL_op->op_flags & OPf_REF ||
851 PL_op->op_private & HINT_STRICT_REFS)
852 DIE(aTHX_ PL_no_usym, "a HASH");
853 if (ckWARN(WARN_UNINITIALIZED))
855 if (gimme == G_ARRAY) {
861 if ((PL_op->op_flags & OPf_SPECIAL) &&
862 !(PL_op->op_flags & OPf_MOD))
864 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
866 && (!is_gv_magical_sv(sv,0)
867 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
873 if (PL_op->op_private & HINT_STRICT_REFS)
874 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
875 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
882 if (PL_op->op_private & OPpLVAL_INTRO)
884 if (PL_op->op_flags & OPf_REF) {
889 if (gimme != G_ARRAY)
890 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
897 if (gimme == G_ARRAY) { /* array wanted */
898 *PL_stack_sp = (SV*)hv;
901 else if (gimme == G_SCALAR) {
903 TARG = Perl_hv_scalar(aTHX_ hv);
910 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
916 if (ckWARN(WARN_MISC)) {
918 if (relem == firstrelem &&
920 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
921 SvTYPE(SvRV(*relem)) == SVt_PVHV))
923 err = "Reference found where even-sized list expected";
926 err = "Odd number of elements in hash assignment";
927 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
930 tmpstr = NEWSV(29,0);
931 didstore = hv_store_ent(hash,*relem,tmpstr,0);
932 if (SvMAGICAL(hash)) {
933 if (SvSMAGICAL(tmpstr))
945 SV **lastlelem = PL_stack_sp;
946 SV **lastrelem = PL_stack_base + POPMARK;
947 SV **firstrelem = PL_stack_base + POPMARK + 1;
948 SV **firstlelem = lastrelem + 1;
961 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
964 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
967 /* If there's a common identifier on both sides we have to take
968 * special care that assigning the identifier on the left doesn't
969 * clobber a value on the right that's used later in the list.
971 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
972 EXTEND_MORTAL(lastrelem - firstrelem + 1);
973 for (relem = firstrelem; relem <= lastrelem; relem++) {
976 TAINT_NOT; /* Each item is independent */
977 *relem = sv_mortalcopy(sv);
987 while (lelem <= lastlelem) {
988 TAINT_NOT; /* Each item stands on its own, taintwise. */
990 switch (SvTYPE(sv)) {
993 magic = SvMAGICAL(ary) != 0;
995 av_extend(ary, lastrelem - relem);
997 while (relem <= lastrelem) { /* gobble up all the rest */
1000 sv = newSVsv(*relem);
1002 didstore = av_store(ary,i++,sv);
1012 case SVt_PVHV: { /* normal hash */
1016 magic = SvMAGICAL(hash) != 0;
1018 firsthashrelem = relem;
1020 while (relem < lastrelem) { /* gobble up all the rest */
1025 sv = &PL_sv_no, relem++;
1026 tmpstr = NEWSV(29,0);
1028 sv_setsv(tmpstr,*relem); /* value */
1029 *(relem++) = tmpstr;
1030 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1031 /* key overwrites an existing entry */
1033 didstore = hv_store_ent(hash,sv,tmpstr,0);
1035 if (SvSMAGICAL(tmpstr))
1042 if (relem == lastrelem) {
1043 do_oddball(hash, relem, firstrelem);
1049 if (SvIMMORTAL(sv)) {
1050 if (relem <= lastrelem)
1054 if (relem <= lastrelem) {
1055 sv_setsv(sv, *relem);
1059 sv_setsv(sv, &PL_sv_undef);
1064 if (PL_delaymagic & ~DM_DELAY) {
1065 if (PL_delaymagic & DM_UID) {
1066 #ifdef HAS_SETRESUID
1067 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1068 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1071 # ifdef HAS_SETREUID
1072 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1073 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1076 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1077 (void)setruid(PL_uid);
1078 PL_delaymagic &= ~DM_RUID;
1080 # endif /* HAS_SETRUID */
1082 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1083 (void)seteuid(PL_euid);
1084 PL_delaymagic &= ~DM_EUID;
1086 # endif /* HAS_SETEUID */
1087 if (PL_delaymagic & DM_UID) {
1088 if (PL_uid != PL_euid)
1089 DIE(aTHX_ "No setreuid available");
1090 (void)PerlProc_setuid(PL_uid);
1092 # endif /* HAS_SETREUID */
1093 #endif /* HAS_SETRESUID */
1094 PL_uid = PerlProc_getuid();
1095 PL_euid = PerlProc_geteuid();
1097 if (PL_delaymagic & DM_GID) {
1098 #ifdef HAS_SETRESGID
1099 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1100 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1103 # ifdef HAS_SETREGID
1104 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1105 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1108 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1109 (void)setrgid(PL_gid);
1110 PL_delaymagic &= ~DM_RGID;
1112 # endif /* HAS_SETRGID */
1114 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1115 (void)setegid(PL_egid);
1116 PL_delaymagic &= ~DM_EGID;
1118 # endif /* HAS_SETEGID */
1119 if (PL_delaymagic & DM_GID) {
1120 if (PL_gid != PL_egid)
1121 DIE(aTHX_ "No setregid available");
1122 (void)PerlProc_setgid(PL_gid);
1124 # endif /* HAS_SETREGID */
1125 #endif /* HAS_SETRESGID */
1126 PL_gid = PerlProc_getgid();
1127 PL_egid = PerlProc_getegid();
1129 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1133 if (gimme == G_VOID)
1134 SP = firstrelem - 1;
1135 else if (gimme == G_SCALAR) {
1138 SETi(lastrelem - firstrelem + 1 - duplicates);
1145 /* Removes from the stack the entries which ended up as
1146 * duplicated keys in the hash (fix for [perl #24380]) */
1147 Move(firsthashrelem + duplicates,
1148 firsthashrelem, duplicates, SV**);
1149 lastrelem -= duplicates;
1154 SP = firstrelem + (lastlelem - firstlelem);
1155 lelem = firstlelem + (relem - firstrelem);
1157 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1165 register PMOP *pm = cPMOP;
1166 SV *rv = sv_newmortal();
1167 SV *sv = newSVrv(rv, "Regexp");
1168 if (pm->op_pmdynflags & PMdf_TAINTED)
1170 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1177 register PMOP *pm = cPMOP;
1179 const register char *t;
1180 const register char *s;
1183 I32 r_flags = REXEC_CHECKED;
1184 const char *truebase; /* Start of string */
1185 register REGEXP *rx = PM_GETRE(pm);
1187 const I32 gimme = GIMME;
1190 const I32 oldsave = PL_savestack_ix;
1191 I32 update_minmatch = 1;
1192 I32 had_zerolen = 0;
1194 if (PL_op->op_flags & OPf_STACKED)
1196 else if (PL_op->op_private & OPpTARGET_MY)
1203 PUTBACK; /* EVAL blocks need stack_sp. */
1204 s = SvPV_const(TARG, len);
1207 DIE(aTHX_ "panic: pp_match");
1208 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1209 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1212 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1214 /* PMdf_USED is set after a ?? matches once */
1215 if (pm->op_pmdynflags & PMdf_USED) {
1217 if (gimme == G_ARRAY)
1222 /* empty pattern special-cased to use last successful pattern if possible */
1223 if (!rx->prelen && PL_curpm) {
1228 if (rx->minlen > (I32)len)
1233 /* XXXX What part of this is needed with true \G-support? */
1234 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1236 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1237 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1238 if (mg && mg->mg_len >= 0) {
1239 if (!(rx->reganch & ROPT_GPOS_SEEN))
1240 rx->endp[0] = rx->startp[0] = mg->mg_len;
1241 else if (rx->reganch & ROPT_ANCH_GPOS) {
1242 r_flags |= REXEC_IGNOREPOS;
1243 rx->endp[0] = rx->startp[0] = mg->mg_len;
1245 minmatch = (mg->mg_flags & MGf_MINMATCH);
1246 update_minmatch = 0;
1250 if ((!global && rx->nparens)
1251 || SvTEMP(TARG) || PL_sawampersand)
1252 r_flags |= REXEC_COPY_STR;
1254 r_flags |= REXEC_SCREAM;
1257 if (global && rx->startp[0] != -1) {
1258 t = s = rx->endp[0] + truebase;
1259 if ((s + rx->minlen) > strend)
1261 if (update_minmatch++)
1262 minmatch = had_zerolen;
1264 if (rx->reganch & RE_USE_INTUIT &&
1265 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1266 /* FIXME - can PL_bostr be made const char *? */
1267 PL_bostr = (char *)truebase;
1268 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1272 if ( (rx->reganch & ROPT_CHECK_ALL)
1274 && ((rx->reganch & ROPT_NOSCAN)
1275 || !((rx->reganch & RE_INTUIT_TAIL)
1276 && (r_flags & REXEC_SCREAM)))
1277 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1280 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1283 if (dynpm->op_pmflags & PMf_ONCE)
1284 dynpm->op_pmdynflags |= PMdf_USED;
1293 RX_MATCH_TAINTED_on(rx);
1294 TAINT_IF(RX_MATCH_TAINTED(rx));
1295 if (gimme == G_ARRAY) {
1296 const I32 nparens = rx->nparens;
1297 I32 i = (global && !nparens) ? 1 : 0;
1299 SPAGAIN; /* EVAL blocks could move the stack. */
1300 EXTEND(SP, nparens + i);
1301 EXTEND_MORTAL(nparens + i);
1302 for (i = !i; i <= nparens; i++) {
1303 PUSHs(sv_newmortal());
1305 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1306 const I32 len = rx->endp[i] - rx->startp[i];
1307 s = rx->startp[i] + truebase;
1308 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1309 len < 0 || len > strend - s)
1310 DIE(aTHX_ "panic: pp_match start/end pointers");
1311 sv_setpvn(*SP, s, len);
1312 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1317 if (dynpm->op_pmflags & PMf_CONTINUE) {
1319 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1320 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1322 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1323 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1325 if (rx->startp[0] != -1) {
1326 mg->mg_len = rx->endp[0];
1327 if (rx->startp[0] == rx->endp[0])
1328 mg->mg_flags |= MGf_MINMATCH;
1330 mg->mg_flags &= ~MGf_MINMATCH;
1333 had_zerolen = (rx->startp[0] != -1
1334 && rx->startp[0] == rx->endp[0]);
1335 PUTBACK; /* EVAL blocks may use stack */
1336 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1341 LEAVE_SCOPE(oldsave);
1347 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1348 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1350 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1351 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1353 if (rx->startp[0] != -1) {
1354 mg->mg_len = rx->endp[0];
1355 if (rx->startp[0] == rx->endp[0])
1356 mg->mg_flags |= MGf_MINMATCH;
1358 mg->mg_flags &= ~MGf_MINMATCH;
1361 LEAVE_SCOPE(oldsave);
1365 yup: /* Confirmed by INTUIT */
1367 RX_MATCH_TAINTED_on(rx);
1368 TAINT_IF(RX_MATCH_TAINTED(rx));
1370 if (dynpm->op_pmflags & PMf_ONCE)
1371 dynpm->op_pmdynflags |= PMdf_USED;
1372 if (RX_MATCH_COPIED(rx))
1373 Safefree(rx->subbeg);
1374 RX_MATCH_COPIED_off(rx);
1375 rx->subbeg = Nullch;
1377 /* FIXME - should rx->subbeg be const char *? */
1378 rx->subbeg = (char *) truebase;
1379 rx->startp[0] = s - truebase;
1380 if (RX_MATCH_UTF8(rx)) {
1381 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1382 rx->endp[0] = t - truebase;
1385 rx->endp[0] = s - truebase + rx->minlen;
1387 rx->sublen = strend - truebase;
1390 if (PL_sawampersand) {
1392 #ifdef PERL_COPY_ON_WRITE
1393 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1395 PerlIO_printf(Perl_debug_log,
1396 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1397 (int) SvTYPE(TARG), truebase, t,
1400 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1401 rx->subbeg = SvPVX_const(rx->saved_copy) + (t - truebase);
1402 assert (SvPOKp(rx->saved_copy));
1407 rx->subbeg = savepvn(t, strend - t);
1408 #ifdef PERL_COPY_ON_WRITE
1409 rx->saved_copy = Nullsv;
1412 rx->sublen = strend - t;
1413 RX_MATCH_COPIED_on(rx);
1414 off = rx->startp[0] = s - t;
1415 rx->endp[0] = off + rx->minlen;
1417 else { /* startp/endp are used by @- @+. */
1418 rx->startp[0] = s - truebase;
1419 rx->endp[0] = s - truebase + rx->minlen;
1421 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1422 LEAVE_SCOPE(oldsave);
1427 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1428 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1429 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1434 LEAVE_SCOPE(oldsave);
1435 if (gimme == G_ARRAY)
1441 Perl_do_readline(pTHX)
1443 dVAR; dSP; dTARGETSTACKED;
1448 register IO * const io = GvIO(PL_last_in_gv);
1449 register const I32 type = PL_op->op_type;
1450 const I32 gimme = GIMME_V;
1453 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1455 XPUSHs(SvTIED_obj((SV*)io, mg));
1458 call_method("READLINE", gimme);
1461 if (gimme == G_SCALAR) {
1463 SvSetSV_nosteal(TARG, result);
1472 if (IoFLAGS(io) & IOf_ARGV) {
1473 if (IoFLAGS(io) & IOf_START) {
1475 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1476 IoFLAGS(io) &= ~IOf_START;
1477 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1478 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1479 SvSETMAGIC(GvSV(PL_last_in_gv));
1484 fp = nextargv(PL_last_in_gv);
1485 if (!fp) { /* Note: fp != IoIFP(io) */
1486 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1489 else if (type == OP_GLOB)
1490 fp = Perl_start_glob(aTHX_ POPs, io);
1492 else if (type == OP_GLOB)
1494 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1495 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1499 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1500 && (!io || !(IoFLAGS(io) & IOf_START))) {
1501 if (type == OP_GLOB)
1502 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1503 "glob failed (can't start child: %s)",
1506 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1508 if (gimme == G_SCALAR) {
1509 /* undef TARG, and push that undefined value */
1510 if (type != OP_RCATLINE) {
1511 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1519 if (gimme == G_SCALAR) {
1523 SvUPGRADE(sv, SVt_PV);
1524 tmplen = SvLEN(sv); /* remember if already alloced */
1525 if (!tmplen && !SvREADONLY(sv))
1526 Sv_Grow(sv, 80); /* try short-buffering it */
1528 if (type == OP_RCATLINE && SvOK(sv)) {
1531 (void)SvPV_force(sv, n_a);
1537 sv = sv_2mortal(NEWSV(57, 80));
1541 /* This should not be marked tainted if the fp is marked clean */
1542 #define MAYBE_TAINT_LINE(io, sv) \
1543 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1548 /* delay EOF state for a snarfed empty file */
1549 #define SNARF_EOF(gimme,rs,io,sv) \
1550 (gimme != G_SCALAR || SvCUR(sv) \
1551 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1555 if (!sv_gets(sv, fp, offset)
1557 || SNARF_EOF(gimme, PL_rs, io, sv)
1558 || PerlIO_error(fp)))
1560 PerlIO_clearerr(fp);
1561 if (IoFLAGS(io) & IOf_ARGV) {
1562 fp = nextargv(PL_last_in_gv);
1565 (void)do_close(PL_last_in_gv, FALSE);
1567 else if (type == OP_GLOB) {
1568 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1569 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1570 "glob failed (child exited with status %d%s)",
1571 (int)(STATUS_CURRENT >> 8),
1572 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1575 if (gimme == G_SCALAR) {
1576 if (type != OP_RCATLINE) {
1577 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1583 MAYBE_TAINT_LINE(io, sv);
1586 MAYBE_TAINT_LINE(io, sv);
1588 IoFLAGS(io) |= IOf_NOLINE;
1592 if (type == OP_GLOB) {
1595 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1596 tmps = SvEND(sv) - 1;
1597 if (*tmps == *SvPVX_const(PL_rs)) {
1599 SvCUR_set(sv, SvCUR(sv) - 1);
1602 for (tmps = SvPVX(sv); *tmps; tmps++)
1603 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1604 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1606 if (*tmps && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1607 (void)POPs; /* Unmatched wildcard? Chuck it... */
1610 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1611 const U8 *s = (U8*)SvPVX(sv) + offset;
1612 const STRLEN len = SvCUR(sv) - offset;
1615 if (ckWARN(WARN_UTF8) &&
1616 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1617 /* Emulate :encoding(utf8) warning in the same case. */
1618 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1619 "utf8 \"\\x%02X\" does not map to Unicode",
1620 f < (U8*)SvEND(sv) ? *f : 0);
1622 if (gimme == G_ARRAY) {
1623 if (SvLEN(sv) - SvCUR(sv) > 20) {
1624 SvPV_shrink_to_cur(sv);
1626 sv = sv_2mortal(NEWSV(58, 80));
1629 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1630 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1631 const STRLEN new_len
1632 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1633 SvPV_renew(sv, new_len);
1642 register PERL_CONTEXT *cx;
1643 I32 gimme = OP_GIMME(PL_op, -1);
1646 if (cxstack_ix >= 0)
1647 gimme = cxstack[cxstack_ix].blk_gimme;
1655 PUSHBLOCK(cx, CXt_BLOCK, SP);
1667 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1668 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1670 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1673 if (SvTYPE(hv) == SVt_PVHV) {
1674 if (PL_op->op_private & OPpLVAL_INTRO) {
1677 /* does the element we're localizing already exist? */
1679 /* can we determine whether it exists? */
1681 || mg_find((SV*)hv, PERL_MAGIC_env)
1682 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1683 /* Try to preserve the existenceness of a tied hash
1684 * element by using EXISTS and DELETE if possible.
1685 * Fallback to FETCH and STORE otherwise */
1686 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1687 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1688 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1690 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1693 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1694 svp = he ? &HeVAL(he) : 0;
1700 if (!svp || *svp == &PL_sv_undef) {
1704 DIE(aTHX_ PL_no_helem_sv, keysv);
1706 lv = sv_newmortal();
1707 sv_upgrade(lv, SVt_PVLV);
1709 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1710 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1711 LvTARG(lv) = SvREFCNT_inc(hv);
1716 if (PL_op->op_private & OPpLVAL_INTRO) {
1717 if (HvNAME_get(hv) && isGV(*svp))
1718 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1722 const char * const key = SvPV(keysv, keylen);
1723 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1725 save_helem(hv, keysv, svp);
1728 else if (PL_op->op_private & OPpDEREF)
1729 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1731 sv = (svp ? *svp : &PL_sv_undef);
1732 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1733 * Pushing the magical RHS on to the stack is useless, since
1734 * that magic is soon destined to be misled by the local(),
1735 * and thus the later pp_sassign() will fail to mg_get() the
1736 * old value. This should also cure problems with delayed
1737 * mg_get()s. GSAR 98-07-03 */
1738 if (!lval && SvGMAGICAL(sv))
1739 sv = sv_mortalcopy(sv);
1747 register PERL_CONTEXT *cx;
1752 if (PL_op->op_flags & OPf_SPECIAL) {
1753 cx = &cxstack[cxstack_ix];
1754 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1759 gimme = OP_GIMME(PL_op, -1);
1761 if (cxstack_ix >= 0)
1762 gimme = cxstack[cxstack_ix].blk_gimme;
1768 if (gimme == G_VOID)
1770 else if (gimme == G_SCALAR) {
1774 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1777 *MARK = sv_mortalcopy(TOPs);
1780 *MARK = &PL_sv_undef;
1784 else if (gimme == G_ARRAY) {
1785 /* in case LEAVE wipes old return values */
1787 for (mark = newsp + 1; mark <= SP; mark++) {
1788 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1789 *mark = sv_mortalcopy(*mark);
1790 TAINT_NOT; /* Each item is independent */
1794 PL_curpm = newpm; /* Don't pop $1 et al till now */
1804 register PERL_CONTEXT *cx;
1810 cx = &cxstack[cxstack_ix];
1811 if (CxTYPE(cx) != CXt_LOOP)
1812 DIE(aTHX_ "panic: pp_iter");
1814 itersvp = CxITERVAR(cx);
1815 av = cx->blk_loop.iterary;
1816 if (SvTYPE(av) != SVt_PVAV) {
1817 /* iterate ($min .. $max) */
1818 if (cx->blk_loop.iterlval) {
1819 /* string increment */
1820 register SV* cur = cx->blk_loop.iterlval;
1822 const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1823 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1824 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1825 /* safe to reuse old SV */
1826 sv_setsv(*itersvp, cur);
1830 /* we need a fresh SV every time so that loop body sees a
1831 * completely new SV for closures/references to work as
1834 *itersvp = newSVsv(cur);
1835 SvREFCNT_dec(oldsv);
1837 if (strEQ(SvPVX_const(cur), max))
1838 sv_setiv(cur, 0); /* terminate next time */
1845 /* integer increment */
1846 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1849 /* don't risk potential race */
1850 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1851 /* safe to reuse old SV */
1852 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1856 /* we need a fresh SV every time so that loop body sees a
1857 * completely new SV for closures/references to work as they
1860 *itersvp = newSViv(cx->blk_loop.iterix++);
1861 SvREFCNT_dec(oldsv);
1867 if (PL_op->op_private & OPpITER_REVERSED) {
1868 /* In reverse, use itermax as the min :-) */
1869 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1872 if (SvMAGICAL(av) || AvREIFY(av)) {
1873 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1880 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1884 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1888 if (SvMAGICAL(av) || AvREIFY(av)) {
1889 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1896 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1900 if (sv && SvREFCNT(sv) == 0) {
1902 Perl_croak(aTHX_ "Use of freed value in iteration");
1909 if (av != PL_curstack && sv == &PL_sv_undef) {
1910 SV *lv = cx->blk_loop.iterlval;
1911 if (lv && SvREFCNT(lv) > 1) {
1916 SvREFCNT_dec(LvTARG(lv));
1918 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1919 sv_upgrade(lv, SVt_PVLV);
1921 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1923 LvTARG(lv) = SvREFCNT_inc(av);
1924 LvTARGOFF(lv) = cx->blk_loop.iterix;
1925 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1930 *itersvp = SvREFCNT_inc(sv);
1931 SvREFCNT_dec(oldsv);
1939 register PMOP *pm = cPMOP;
1955 register REGEXP *rx = PM_GETRE(pm);
1957 int force_on_match = 0;
1958 I32 oldsave = PL_savestack_ix;
1960 bool doutf8 = FALSE;
1961 #ifdef PERL_COPY_ON_WRITE
1966 /* known replacement string? */
1967 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1968 if (PL_op->op_flags & OPf_STACKED)
1970 else if (PL_op->op_private & OPpTARGET_MY)
1977 #ifdef PERL_COPY_ON_WRITE
1978 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1979 because they make integers such as 256 "false". */
1980 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1983 sv_force_normal_flags(TARG,0);
1986 #ifdef PERL_COPY_ON_WRITE
1990 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1991 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1992 DIE(aTHX_ PL_no_modify);
1995 s = SvPV(TARG, len);
1996 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1998 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1999 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2004 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2008 DIE(aTHX_ "panic: pp_subst");
2011 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2012 maxiters = 2 * slen + 10; /* We can match twice at each
2013 position, once with zero-length,
2014 second time with non-zero. */
2016 if (!rx->prelen && PL_curpm) {
2020 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2021 ? REXEC_COPY_STR : 0;
2023 r_flags |= REXEC_SCREAM;
2026 if (rx->reganch & RE_USE_INTUIT) {
2028 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2032 /* How to do it in subst? */
2033 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2035 && ((rx->reganch & ROPT_NOSCAN)
2036 || !((rx->reganch & RE_INTUIT_TAIL)
2037 && (r_flags & REXEC_SCREAM))))
2042 /* only replace once? */
2043 once = !(rpm->op_pmflags & PMf_GLOBAL);
2045 /* known replacement string? */
2047 /* replacement needing upgrading? */
2048 if (DO_UTF8(TARG) && !doutf8) {
2049 nsv = sv_newmortal();
2052 sv_recode_to_utf8(nsv, PL_encoding);
2054 sv_utf8_upgrade(nsv);
2055 c = SvPV_const(nsv, clen);
2059 c = SvPV_const(dstr, clen);
2060 doutf8 = DO_UTF8(dstr);
2068 /* can do inplace substitution? */
2070 #ifdef PERL_COPY_ON_WRITE
2073 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2074 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2075 && (!doutf8 || SvUTF8(TARG))) {
2076 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2077 r_flags | REXEC_CHECKED))
2081 LEAVE_SCOPE(oldsave);
2084 #ifdef PERL_COPY_ON_WRITE
2085 if (SvIsCOW(TARG)) {
2086 assert (!force_on_match);
2090 if (force_on_match) {
2092 s = SvPV_force(TARG, len);
2097 SvSCREAM_off(TARG); /* disable possible screamer */
2099 rxtainted |= RX_MATCH_TAINTED(rx);
2100 m = orig + rx->startp[0];
2101 d = orig + rx->endp[0];
2103 if (m - s > strend - d) { /* faster to shorten from end */
2105 Copy(c, m, clen, char);
2110 Move(d, m, i, char);
2114 SvCUR_set(TARG, m - s);
2117 else if ((i = m - s)) { /* faster from front */
2125 Copy(c, m, clen, char);
2130 Copy(c, d, clen, char);
2135 TAINT_IF(rxtainted & 1);
2141 if (iters++ > maxiters)
2142 DIE(aTHX_ "Substitution loop");
2143 rxtainted |= RX_MATCH_TAINTED(rx);
2144 m = rx->startp[0] + orig;
2148 Move(s, d, i, char);
2152 Copy(c, d, clen, char);
2155 s = rx->endp[0] + orig;
2156 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2158 /* don't match same null twice */
2159 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2162 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2163 Move(s, d, i+1, char); /* include the NUL */
2165 TAINT_IF(rxtainted & 1);
2167 PUSHs(sv_2mortal(newSViv((I32)iters)));
2169 (void)SvPOK_only_UTF8(TARG);
2170 TAINT_IF(rxtainted);
2171 if (SvSMAGICAL(TARG)) {
2179 LEAVE_SCOPE(oldsave);
2183 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2184 r_flags | REXEC_CHECKED))
2186 if (force_on_match) {
2188 s = SvPV_force(TARG, len);
2191 #ifdef PERL_COPY_ON_WRITE
2194 rxtainted |= RX_MATCH_TAINTED(rx);
2195 dstr = newSVpvn(m, s-m);
2200 register PERL_CONTEXT *cx;
2204 RETURNOP(cPMOP->op_pmreplroot);
2206 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2208 if (iters++ > maxiters)
2209 DIE(aTHX_ "Substitution loop");
2210 rxtainted |= RX_MATCH_TAINTED(rx);
2211 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2216 strend = s + (strend - m);
2218 m = rx->startp[0] + orig;
2219 if (doutf8 && !SvUTF8(dstr))
2220 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2222 sv_catpvn(dstr, s, m-s);
2223 s = rx->endp[0] + orig;
2225 sv_catpvn(dstr, c, clen);
2228 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2229 TARG, NULL, r_flags));
2230 if (doutf8 && !DO_UTF8(TARG))
2231 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2233 sv_catpvn(dstr, s, strend - s);
2235 #ifdef PERL_COPY_ON_WRITE
2236 /* The match may make the string COW. If so, brilliant, because that's
2237 just saved us one malloc, copy and free - the regexp has donated
2238 the old buffer, and we malloc an entirely new one, rather than the
2239 regexp malloc()ing a buffer and copying our original, only for
2240 us to throw it away here during the substitution. */
2241 if (SvIsCOW(TARG)) {
2242 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2248 SvPV_set(TARG, SvPVX(dstr));
2249 SvCUR_set(TARG, SvCUR(dstr));
2250 SvLEN_set(TARG, SvLEN(dstr));
2251 doutf8 |= DO_UTF8(dstr);
2252 SvPV_set(dstr, (char*)0);
2255 TAINT_IF(rxtainted & 1);
2257 PUSHs(sv_2mortal(newSViv((I32)iters)));
2259 (void)SvPOK_only(TARG);
2262 TAINT_IF(rxtainted);
2265 LEAVE_SCOPE(oldsave);
2274 LEAVE_SCOPE(oldsave);
2283 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2284 ++*PL_markstack_ptr;
2285 LEAVE; /* exit inner scope */
2288 if (PL_stack_base + *PL_markstack_ptr > SP) {
2290 I32 gimme = GIMME_V;
2292 LEAVE; /* exit outer scope */
2293 (void)POPMARK; /* pop src */
2294 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2295 (void)POPMARK; /* pop dst */
2296 SP = PL_stack_base + POPMARK; /* pop original mark */
2297 if (gimme == G_SCALAR) {
2298 if (PL_op->op_private & OPpGREP_LEX) {
2299 SV* sv = sv_newmortal();
2300 sv_setiv(sv, items);
2308 else if (gimme == G_ARRAY)
2315 ENTER; /* enter inner scope */
2318 src = PL_stack_base[*PL_markstack_ptr];
2320 if (PL_op->op_private & OPpGREP_LEX)
2321 PAD_SVl(PL_op->op_targ) = src;
2325 RETURNOP(cLOGOP->op_other);
2336 register PERL_CONTEXT *cx;
2340 cxstack_ix++; /* temporarily protect top context */
2343 if (gimme == G_SCALAR) {
2346 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2348 *MARK = SvREFCNT_inc(TOPs);
2353 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2355 *MARK = sv_mortalcopy(sv);
2360 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2364 *MARK = &PL_sv_undef;
2368 else if (gimme == G_ARRAY) {
2369 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2370 if (!SvTEMP(*MARK)) {
2371 *MARK = sv_mortalcopy(*MARK);
2372 TAINT_NOT; /* Each item is independent */
2380 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2381 PL_curpm = newpm; /* ... and pop $1 et al */
2384 return cx->blk_sub.retop;
2387 /* This duplicates the above code because the above code must not
2388 * get any slower by more conditions */
2396 register PERL_CONTEXT *cx;
2400 cxstack_ix++; /* temporarily protect top context */
2404 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2405 /* We are an argument to a function or grep().
2406 * This kind of lvalueness was legal before lvalue
2407 * subroutines too, so be backward compatible:
2408 * cannot report errors. */
2410 /* Scalar context *is* possible, on the LHS of -> only,
2411 * as in f()->meth(). But this is not an lvalue. */
2412 if (gimme == G_SCALAR)
2414 if (gimme == G_ARRAY) {
2415 if (!CvLVALUE(cx->blk_sub.cv))
2416 goto temporise_array;
2417 EXTEND_MORTAL(SP - newsp);
2418 for (mark = newsp + 1; mark <= SP; mark++) {
2421 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2422 *mark = sv_mortalcopy(*mark);
2424 /* Can be a localized value subject to deletion. */
2425 PL_tmps_stack[++PL_tmps_ix] = *mark;
2426 (void)SvREFCNT_inc(*mark);
2431 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2432 /* Here we go for robustness, not for speed, so we change all
2433 * the refcounts so the caller gets a live guy. Cannot set
2434 * TEMP, so sv_2mortal is out of question. */
2435 if (!CvLVALUE(cx->blk_sub.cv)) {
2441 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2443 if (gimme == G_SCALAR) {
2447 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2453 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2454 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2455 : "a readonly value" : "a temporary");
2457 else { /* Can be a localized value
2458 * subject to deletion. */
2459 PL_tmps_stack[++PL_tmps_ix] = *mark;
2460 (void)SvREFCNT_inc(*mark);
2463 else { /* Should not happen? */
2469 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2470 (MARK > SP ? "Empty array" : "Array"));
2474 else if (gimme == G_ARRAY) {
2475 EXTEND_MORTAL(SP - newsp);
2476 for (mark = newsp + 1; mark <= SP; mark++) {
2477 if (*mark != &PL_sv_undef
2478 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2479 /* Might be flattened array after $#array = */
2486 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2487 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2490 /* Can be a localized value subject to deletion. */
2491 PL_tmps_stack[++PL_tmps_ix] = *mark;
2492 (void)SvREFCNT_inc(*mark);
2498 if (gimme == G_SCALAR) {
2502 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2504 *MARK = SvREFCNT_inc(TOPs);
2509 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2511 *MARK = sv_mortalcopy(sv);
2516 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2520 *MARK = &PL_sv_undef;
2524 else if (gimme == G_ARRAY) {
2526 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2527 if (!SvTEMP(*MARK)) {
2528 *MARK = sv_mortalcopy(*MARK);
2529 TAINT_NOT; /* Each item is independent */
2538 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2539 PL_curpm = newpm; /* ... and pop $1 et al */
2542 return cx->blk_sub.retop;
2547 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2549 SV *dbsv = GvSV(PL_DBsub);
2552 if (!PERLDB_SUB_NN) {
2555 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2556 || strEQ(GvNAME(gv), "END")
2557 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2558 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2559 && (gv = (GV*)*svp) ))) {
2560 /* Use GV from the stack as a fallback. */
2561 /* GV is potentially non-unique, or contain different CV. */
2562 SV *tmp = newRV((SV*)cv);
2563 sv_setsv(dbsv, tmp);
2567 gv_efullname3(dbsv, gv, Nullch);
2571 const int type = SvTYPE(dbsv);
2572 if (type < SVt_PVIV && type != SVt_IV)
2573 sv_upgrade(dbsv, SVt_PVIV);
2574 (void)SvIOK_on(dbsv);
2575 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2579 PL_curcopdb = PL_curcop;
2580 cv = GvCV(PL_DBsub);
2590 register PERL_CONTEXT *cx;
2592 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2595 DIE(aTHX_ "Not a CODE reference");
2596 switch (SvTYPE(sv)) {
2597 /* This is overwhelming the most common case: */
2599 if (!(cv = GvCVu((GV*)sv)))
2600 cv = sv_2cv(sv, &stash, &gv, FALSE);
2610 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2612 SP = PL_stack_base + POPMARK;
2615 if (SvGMAGICAL(sv)) {
2619 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2623 sym = SvPV(sv, n_a);
2626 DIE(aTHX_ PL_no_usym, "a subroutine");
2627 if (PL_op->op_private & HINT_STRICT_REFS)
2628 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2629 cv = get_cv(sym, TRUE);
2634 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2635 tryAMAGICunDEREF(to_cv);
2638 if (SvTYPE(cv) == SVt_PVCV)
2643 DIE(aTHX_ "Not a CODE reference");
2644 /* This is the second most common case: */
2654 if (!CvROOT(cv) && !CvXSUB(cv)) {
2659 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2660 if (CvASSERTION(cv) && PL_DBassertion)
2661 sv_setiv(PL_DBassertion, 1);
2663 cv = get_db_sub(&sv, cv);
2664 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2665 DIE(aTHX_ "No DB::sub routine defined");
2668 if (!(CvXSUB(cv))) {
2669 /* This path taken at least 75% of the time */
2671 register I32 items = SP - MARK;
2672 AV* padlist = CvPADLIST(cv);
2673 PUSHBLOCK(cx, CXt_SUB, MARK);
2675 cx->blk_sub.retop = PL_op->op_next;
2677 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2678 * that eval'' ops within this sub know the correct lexical space.
2679 * Owing the speed considerations, we choose instead to search for
2680 * the cv using find_runcv() when calling doeval().
2682 if (CvDEPTH(cv) >= 2) {
2683 PERL_STACK_OVERFLOW_CHECK();
2684 pad_push(padlist, CvDEPTH(cv));
2686 PAD_SET_CUR(padlist, CvDEPTH(cv));
2691 DEBUG_S(PerlIO_printf(Perl_debug_log,
2692 "%p entersub preparing @_\n", thr));
2694 av = (AV*)PAD_SVl(0);
2696 /* @_ is normally not REAL--this should only ever
2697 * happen when DB::sub() calls things that modify @_ */
2702 cx->blk_sub.savearray = GvAV(PL_defgv);
2703 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2704 CX_CURPAD_SAVE(cx->blk_sub);
2705 cx->blk_sub.argarray = av;
2708 if (items > AvMAX(av) + 1) {
2709 SV **ary = AvALLOC(av);
2710 if (AvARRAY(av) != ary) {
2711 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2712 SvPV_set(av, (char*)ary);
2714 if (items > AvMAX(av) + 1) {
2715 AvMAX(av) = items - 1;
2716 Renew(ary,items,SV*);
2718 SvPV_set(av, (char*)ary);
2721 Copy(MARK,AvARRAY(av),items,SV*);
2722 AvFILLp(av) = items - 1;
2730 /* warning must come *after* we fully set up the context
2731 * stuff so that __WARN__ handlers can safely dounwind()
2734 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2735 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2736 sub_crush_depth(cv);
2738 DEBUG_S(PerlIO_printf(Perl_debug_log,
2739 "%p entersub returning %p\n", thr, CvSTART(cv)));
2741 RETURNOP(CvSTART(cv));
2744 #ifdef PERL_XSUB_OLDSTYLE
2745 if (CvOLDSTYLE(cv)) {
2746 I32 (*fp3)(int,int,int);
2748 register I32 items = SP - MARK;
2749 /* We dont worry to copy from @_. */
2754 PL_stack_sp = mark + 1;
2755 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2756 items = (*fp3)(CvXSUBANY(cv).any_i32,
2757 MARK - PL_stack_base + 1,
2759 PL_stack_sp = PL_stack_base + items;
2762 #endif /* PERL_XSUB_OLDSTYLE */
2764 I32 markix = TOPMARK;
2769 /* Need to copy @_ to stack. Alternative may be to
2770 * switch stack to @_, and copy return values
2771 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2772 AV * const av = GvAV(PL_defgv);
2773 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2776 /* Mark is at the end of the stack. */
2778 Copy(AvARRAY(av), SP + 1, items, SV*);
2783 /* We assume first XSUB in &DB::sub is the called one. */
2785 SAVEVPTR(PL_curcop);
2786 PL_curcop = PL_curcopdb;
2789 /* Do we need to open block here? XXXX */
2790 (void)(*CvXSUB(cv))(aTHX_ cv);
2792 /* Enforce some sanity in scalar context. */
2793 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2794 if (markix > PL_stack_sp - PL_stack_base)
2795 *(PL_stack_base + markix) = &PL_sv_undef;
2797 *(PL_stack_base + markix) = *PL_stack_sp;
2798 PL_stack_sp = PL_stack_base + markix;
2805 assert (0); /* Cannot get here. */
2806 /* This is deliberately moved here as spaghetti code to keep it out of the
2813 /* anonymous or undef'd function leaves us no recourse */
2814 if (CvANON(cv) || !(gv = CvGV(cv)))
2815 DIE(aTHX_ "Undefined subroutine called");
2817 /* autoloaded stub? */
2818 if (cv != GvCV(gv)) {
2821 /* should call AUTOLOAD now? */
2824 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2831 sub_name = sv_newmortal();
2832 gv_efullname3(sub_name, gv, Nullch);
2833 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2837 DIE(aTHX_ "Not a CODE reference");
2843 Perl_sub_crush_depth(pTHX_ CV *cv)
2846 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2848 SV* tmpstr = sv_newmortal();
2849 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2850 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2859 SV* const elemsv = POPs;
2860 IV elem = SvIV(elemsv);
2862 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2863 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2866 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2867 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2869 elem -= PL_curcop->cop_arybase;
2870 if (SvTYPE(av) != SVt_PVAV)
2872 svp = av_fetch(av, elem, lval && !defer);
2874 #ifdef PERL_MALLOC_WRAP
2875 if (SvUOK(elemsv)) {
2876 const UV uv = SvUV(elemsv);
2877 elem = uv > IV_MAX ? IV_MAX : uv;
2879 else if (SvNOK(elemsv))
2880 elem = (IV)SvNV(elemsv);
2882 static const char oom_array_extend[] =
2883 "Out of memory during array extend"; /* Duplicated in av.c */
2884 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2887 if (!svp || *svp == &PL_sv_undef) {
2890 DIE(aTHX_ PL_no_aelem, elem);
2891 lv = sv_newmortal();
2892 sv_upgrade(lv, SVt_PVLV);
2894 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2895 LvTARG(lv) = SvREFCNT_inc(av);
2896 LvTARGOFF(lv) = elem;
2901 if (PL_op->op_private & OPpLVAL_INTRO)
2902 save_aelem(av, elem, svp);
2903 else if (PL_op->op_private & OPpDEREF)
2904 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2906 sv = (svp ? *svp : &PL_sv_undef);
2907 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2908 sv = sv_mortalcopy(sv);
2914 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2920 Perl_croak(aTHX_ PL_no_modify);
2921 if (SvTYPE(sv) < SVt_RV)
2922 sv_upgrade(sv, SVt_RV);
2923 else if (SvTYPE(sv) >= SVt_PV) {
2930 SvRV_set(sv, NEWSV(355,0));
2933 SvRV_set(sv, (SV*)newAV());
2936 SvRV_set(sv, (SV*)newHV());
2951 if (SvTYPE(rsv) == SVt_PVCV) {
2957 SETs(method_common(sv, Null(U32*)));
2965 U32 hash = SvSHARED_HASH(sv);
2967 XPUSHs(method_common(sv, &hash));
2972 S_method_common(pTHX_ SV* meth, U32* hashp)
2979 const char* packname = 0;
2980 SV *packsv = Nullsv;
2982 const char *name = SvPV_const(meth, namelen);
2984 sv = *(PL_stack_base + TOPMARK + 1);
2987 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2996 /* this isn't a reference */
2999 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3000 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3002 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3009 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3010 !(ob=(SV*)GvIO(iogv)))
3012 /* this isn't the name of a filehandle either */
3014 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3015 ? !isIDFIRST_utf8((U8*)packname)
3016 : !isIDFIRST(*packname)
3019 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3020 SvOK(sv) ? "without a package or object reference"
3021 : "on an undefined value");
3023 /* assume it's a package name */
3024 stash = gv_stashpvn(packname, packlen, FALSE);
3028 SV* ref = newSViv(PTR2IV(stash));
3029 hv_store(PL_stashcache, packname, packlen, ref, 0);
3033 /* it _is_ a filehandle name -- replace with a reference */
3034 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3037 /* if we got here, ob should be a reference or a glob */
3038 if (!ob || !(SvOBJECT(ob)
3039 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3042 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3046 stash = SvSTASH(ob);
3049 /* NOTE: stash may be null, hope hv_fetch_ent and
3050 gv_fetchmethod can cope (it seems they can) */
3052 /* shortcut for simple names */
3054 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3056 gv = (GV*)HeVAL(he);
3057 if (isGV(gv) && GvCV(gv) &&
3058 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3059 return (SV*)GvCV(gv);
3063 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3066 /* This code tries to figure out just what went wrong with
3067 gv_fetchmethod. It therefore needs to duplicate a lot of
3068 the internals of that function. We can't move it inside
3069 Perl_gv_fetchmethod_autoload(), however, since that would
3070 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3073 const char* leaf = name;
3074 const char* sep = Nullch;
3077 for (p = name; *p; p++) {
3079 sep = p, leaf = p + 1;
3080 else if (*p == ':' && *(p + 1) == ':')
3081 sep = p, leaf = p + 2;
3083 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3084 /* the method name is unqualified or starts with SUPER:: */
3085 bool need_strlen = 1;
3087 packname = CopSTASHPV(PL_curcop);
3090 HEK *packhek = HvNAME_HEK(stash);
3092 packname = HEK_KEY(packhek);
3093 packlen = HEK_LEN(packhek);
3103 "Can't use anonymous symbol table for method lookup");
3105 else if (need_strlen)
3106 packlen = strlen(packname);
3110 /* the method name is qualified */
3112 packlen = sep - name;
3115 /* we're relying on gv_fetchmethod not autovivifying the stash */
3116 if (gv_stashpvn(packname, packlen, FALSE)) {
3118 "Can't locate object method \"%s\" via package \"%.*s\"",
3119 leaf, (int)packlen, packname);
3123 "Can't locate object method \"%s\" via package \"%.*s\""
3124 " (perhaps you forgot to load \"%.*s\"?)",
3125 leaf, (int)packlen, packname, (int)packlen, packname);
3128 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3133 * c-indentation-style: bsd
3135 * indent-tabs-mode: t
3138 * ex: set ts=8 sts=4 sw=4 noet: