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(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(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;
1183 I32 r_flags = REXEC_CHECKED;
1184 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(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 PL_bostr = truebase;
1267 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1271 if ( (rx->reganch & ROPT_CHECK_ALL)
1273 && ((rx->reganch & ROPT_NOSCAN)
1274 || !((rx->reganch & RE_INTUIT_TAIL)
1275 && (r_flags & REXEC_SCREAM)))
1276 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1279 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1282 if (dynpm->op_pmflags & PMf_ONCE)
1283 dynpm->op_pmdynflags |= PMdf_USED;
1292 RX_MATCH_TAINTED_on(rx);
1293 TAINT_IF(RX_MATCH_TAINTED(rx));
1294 if (gimme == G_ARRAY) {
1295 const I32 nparens = rx->nparens;
1296 I32 i = (global && !nparens) ? 1 : 0;
1298 SPAGAIN; /* EVAL blocks could move the stack. */
1299 EXTEND(SP, nparens + i);
1300 EXTEND_MORTAL(nparens + i);
1301 for (i = !i; i <= nparens; i++) {
1302 PUSHs(sv_newmortal());
1304 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1305 const I32 len = rx->endp[i] - rx->startp[i];
1306 s = rx->startp[i] + truebase;
1307 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1308 len < 0 || len > strend - s)
1309 DIE(aTHX_ "panic: pp_match start/end pointers");
1310 sv_setpvn(*SP, s, len);
1311 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1316 if (dynpm->op_pmflags & PMf_CONTINUE) {
1318 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1319 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1321 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1322 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1324 if (rx->startp[0] != -1) {
1325 mg->mg_len = rx->endp[0];
1326 if (rx->startp[0] == rx->endp[0])
1327 mg->mg_flags |= MGf_MINMATCH;
1329 mg->mg_flags &= ~MGf_MINMATCH;
1332 had_zerolen = (rx->startp[0] != -1
1333 && rx->startp[0] == rx->endp[0]);
1334 PUTBACK; /* EVAL blocks may use stack */
1335 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1340 LEAVE_SCOPE(oldsave);
1346 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1347 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1349 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1350 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1352 if (rx->startp[0] != -1) {
1353 mg->mg_len = rx->endp[0];
1354 if (rx->startp[0] == rx->endp[0])
1355 mg->mg_flags |= MGf_MINMATCH;
1357 mg->mg_flags &= ~MGf_MINMATCH;
1360 LEAVE_SCOPE(oldsave);
1364 yup: /* Confirmed by INTUIT */
1366 RX_MATCH_TAINTED_on(rx);
1367 TAINT_IF(RX_MATCH_TAINTED(rx));
1369 if (dynpm->op_pmflags & PMf_ONCE)
1370 dynpm->op_pmdynflags |= PMdf_USED;
1371 if (RX_MATCH_COPIED(rx))
1372 Safefree(rx->subbeg);
1373 RX_MATCH_COPIED_off(rx);
1374 rx->subbeg = Nullch;
1376 rx->subbeg = truebase;
1377 rx->startp[0] = s - truebase;
1378 if (RX_MATCH_UTF8(rx)) {
1379 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1380 rx->endp[0] = t - truebase;
1383 rx->endp[0] = s - truebase + rx->minlen;
1385 rx->sublen = strend - truebase;
1388 if (PL_sawampersand) {
1390 #ifdef PERL_COPY_ON_WRITE
1391 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1393 PerlIO_printf(Perl_debug_log,
1394 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1395 (int) SvTYPE(TARG), truebase, t,
1398 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1399 rx->subbeg = SvPVX_const(rx->saved_copy) + (t - truebase);
1400 assert (SvPOKp(rx->saved_copy));
1405 rx->subbeg = savepvn(t, strend - t);
1406 #ifdef PERL_COPY_ON_WRITE
1407 rx->saved_copy = Nullsv;
1410 rx->sublen = strend - t;
1411 RX_MATCH_COPIED_on(rx);
1412 off = rx->startp[0] = s - t;
1413 rx->endp[0] = off + rx->minlen;
1415 else { /* startp/endp are used by @- @+. */
1416 rx->startp[0] = s - truebase;
1417 rx->endp[0] = s - truebase + rx->minlen;
1419 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1420 LEAVE_SCOPE(oldsave);
1425 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1426 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1427 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1432 LEAVE_SCOPE(oldsave);
1433 if (gimme == G_ARRAY)
1439 Perl_do_readline(pTHX)
1441 dVAR; dSP; dTARGETSTACKED;
1446 register IO * const io = GvIO(PL_last_in_gv);
1447 register const I32 type = PL_op->op_type;
1448 const I32 gimme = GIMME_V;
1451 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1453 XPUSHs(SvTIED_obj((SV*)io, mg));
1456 call_method("READLINE", gimme);
1459 if (gimme == G_SCALAR) {
1461 SvSetSV_nosteal(TARG, result);
1470 if (IoFLAGS(io) & IOf_ARGV) {
1471 if (IoFLAGS(io) & IOf_START) {
1473 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1474 IoFLAGS(io) &= ~IOf_START;
1475 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1476 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1477 SvSETMAGIC(GvSV(PL_last_in_gv));
1482 fp = nextargv(PL_last_in_gv);
1483 if (!fp) { /* Note: fp != IoIFP(io) */
1484 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1487 else if (type == OP_GLOB)
1488 fp = Perl_start_glob(aTHX_ POPs, io);
1490 else if (type == OP_GLOB)
1492 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1493 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1497 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1498 && (!io || !(IoFLAGS(io) & IOf_START))) {
1499 if (type == OP_GLOB)
1500 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1501 "glob failed (can't start child: %s)",
1504 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1506 if (gimme == G_SCALAR) {
1507 /* undef TARG, and push that undefined value */
1508 if (type != OP_RCATLINE) {
1509 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1517 if (gimme == G_SCALAR) {
1521 (void)SvUPGRADE(sv, SVt_PV);
1522 tmplen = SvLEN(sv); /* remember if already alloced */
1523 if (!tmplen && !SvREADONLY(sv))
1524 Sv_Grow(sv, 80); /* try short-buffering it */
1526 if (type == OP_RCATLINE && SvOK(sv)) {
1529 (void)SvPV_force(sv, n_a);
1535 sv = sv_2mortal(NEWSV(57, 80));
1539 /* This should not be marked tainted if the fp is marked clean */
1540 #define MAYBE_TAINT_LINE(io, sv) \
1541 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1546 /* delay EOF state for a snarfed empty file */
1547 #define SNARF_EOF(gimme,rs,io,sv) \
1548 (gimme != G_SCALAR || SvCUR(sv) \
1549 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1553 if (!sv_gets(sv, fp, offset)
1555 || SNARF_EOF(gimme, PL_rs, io, sv)
1556 || PerlIO_error(fp)))
1558 PerlIO_clearerr(fp);
1559 if (IoFLAGS(io) & IOf_ARGV) {
1560 fp = nextargv(PL_last_in_gv);
1563 (void)do_close(PL_last_in_gv, FALSE);
1565 else if (type == OP_GLOB) {
1566 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1567 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1568 "glob failed (child exited with status %d%s)",
1569 (int)(STATUS_CURRENT >> 8),
1570 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1573 if (gimme == G_SCALAR) {
1574 if (type != OP_RCATLINE) {
1575 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1581 MAYBE_TAINT_LINE(io, sv);
1584 MAYBE_TAINT_LINE(io, sv);
1586 IoFLAGS(io) |= IOf_NOLINE;
1590 if (type == OP_GLOB) {
1593 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1594 tmps = SvEND(sv) - 1;
1595 if (*tmps == *SvPVX_const(PL_rs)) {
1597 SvCUR_set(sv, SvCUR(sv) - 1);
1600 for (tmps = SvPVX(sv); *tmps; tmps++)
1601 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1602 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1604 if (*tmps && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1605 (void)POPs; /* Unmatched wildcard? Chuck it... */
1608 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1609 const U8 *s = (U8*)SvPVX(sv) + offset;
1610 const STRLEN len = SvCUR(sv) - offset;
1613 if (ckWARN(WARN_UTF8) &&
1614 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1615 /* Emulate :encoding(utf8) warning in the same case. */
1616 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1617 "utf8 \"\\x%02X\" does not map to Unicode",
1618 f < (U8*)SvEND(sv) ? *f : 0);
1620 if (gimme == G_ARRAY) {
1621 if (SvLEN(sv) - SvCUR(sv) > 20) {
1622 SvPV_shrink_to_cur(sv);
1624 sv = sv_2mortal(NEWSV(58, 80));
1627 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1628 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1629 const STRLEN new_len
1630 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1631 SvPV_renew(sv, new_len);
1640 register PERL_CONTEXT *cx;
1641 I32 gimme = OP_GIMME(PL_op, -1);
1644 if (cxstack_ix >= 0)
1645 gimme = cxstack[cxstack_ix].blk_gimme;
1653 PUSHBLOCK(cx, CXt_BLOCK, SP);
1665 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1666 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1668 #ifdef PERL_COPY_ON_WRITE
1669 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1671 const U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1675 if (SvTYPE(hv) == SVt_PVHV) {
1676 if (PL_op->op_private & OPpLVAL_INTRO) {
1679 /* does the element we're localizing already exist? */
1681 /* can we determine whether it exists? */
1683 || mg_find((SV*)hv, PERL_MAGIC_env)
1684 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1685 /* Try to preserve the existenceness of a tied hash
1686 * element by using EXISTS and DELETE if possible.
1687 * Fallback to FETCH and STORE otherwise */
1688 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1689 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1690 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1692 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1695 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1696 svp = he ? &HeVAL(he) : 0;
1702 if (!svp || *svp == &PL_sv_undef) {
1706 DIE(aTHX_ PL_no_helem_sv, keysv);
1708 lv = sv_newmortal();
1709 sv_upgrade(lv, SVt_PVLV);
1711 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1712 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1713 LvTARG(lv) = SvREFCNT_inc(hv);
1718 if (PL_op->op_private & OPpLVAL_INTRO) {
1719 if (HvNAME_get(hv) && isGV(*svp))
1720 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1724 const char * const key = SvPV(keysv, keylen);
1725 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1727 save_helem(hv, keysv, svp);
1730 else if (PL_op->op_private & OPpDEREF)
1731 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1733 sv = (svp ? *svp : &PL_sv_undef);
1734 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1735 * Pushing the magical RHS on to the stack is useless, since
1736 * that magic is soon destined to be misled by the local(),
1737 * and thus the later pp_sassign() will fail to mg_get() the
1738 * old value. This should also cure problems with delayed
1739 * mg_get()s. GSAR 98-07-03 */
1740 if (!lval && SvGMAGICAL(sv))
1741 sv = sv_mortalcopy(sv);
1749 register PERL_CONTEXT *cx;
1754 if (PL_op->op_flags & OPf_SPECIAL) {
1755 cx = &cxstack[cxstack_ix];
1756 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1761 gimme = OP_GIMME(PL_op, -1);
1763 if (cxstack_ix >= 0)
1764 gimme = cxstack[cxstack_ix].blk_gimme;
1770 if (gimme == G_VOID)
1772 else if (gimme == G_SCALAR) {
1776 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1779 *MARK = sv_mortalcopy(TOPs);
1782 *MARK = &PL_sv_undef;
1786 else if (gimme == G_ARRAY) {
1787 /* in case LEAVE wipes old return values */
1789 for (mark = newsp + 1; mark <= SP; mark++) {
1790 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1791 *mark = sv_mortalcopy(*mark);
1792 TAINT_NOT; /* Each item is independent */
1796 PL_curpm = newpm; /* Don't pop $1 et al till now */
1806 register PERL_CONTEXT *cx;
1812 cx = &cxstack[cxstack_ix];
1813 if (CxTYPE(cx) != CXt_LOOP)
1814 DIE(aTHX_ "panic: pp_iter");
1816 itersvp = CxITERVAR(cx);
1817 av = cx->blk_loop.iterary;
1818 if (SvTYPE(av) != SVt_PVAV) {
1819 /* iterate ($min .. $max) */
1820 if (cx->blk_loop.iterlval) {
1821 /* string increment */
1822 register SV* cur = cx->blk_loop.iterlval;
1824 const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1825 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1826 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1827 /* safe to reuse old SV */
1828 sv_setsv(*itersvp, cur);
1832 /* we need a fresh SV every time so that loop body sees a
1833 * completely new SV for closures/references to work as
1836 *itersvp = newSVsv(cur);
1837 SvREFCNT_dec(oldsv);
1839 if (strEQ(SvPVX_const(cur), max))
1840 sv_setiv(cur, 0); /* terminate next time */
1847 /* integer increment */
1848 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1851 /* don't risk potential race */
1852 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1853 /* safe to reuse old SV */
1854 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1858 /* we need a fresh SV every time so that loop body sees a
1859 * completely new SV for closures/references to work as they
1862 *itersvp = newSViv(cx->blk_loop.iterix++);
1863 SvREFCNT_dec(oldsv);
1869 if (PL_op->op_private & OPpITER_REVERSED) {
1870 /* In reverse, use itermax as the min :-) */
1871 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1874 if (SvMAGICAL(av) || AvREIFY(av)) {
1875 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1882 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1886 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1890 if (SvMAGICAL(av) || AvREIFY(av)) {
1891 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1898 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1902 if (sv && SvREFCNT(sv) == 0) {
1904 Perl_croak(aTHX_ "Use of freed value in iteration");
1911 if (av != PL_curstack && sv == &PL_sv_undef) {
1912 SV *lv = cx->blk_loop.iterlval;
1913 if (lv && SvREFCNT(lv) > 1) {
1918 SvREFCNT_dec(LvTARG(lv));
1920 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1921 sv_upgrade(lv, SVt_PVLV);
1923 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1925 LvTARG(lv) = SvREFCNT_inc(av);
1926 LvTARGOFF(lv) = cx->blk_loop.iterix;
1927 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1932 *itersvp = SvREFCNT_inc(sv);
1933 SvREFCNT_dec(oldsv);
1941 register PMOP *pm = cPMOP;
1957 register REGEXP *rx = PM_GETRE(pm);
1959 int force_on_match = 0;
1960 I32 oldsave = PL_savestack_ix;
1962 bool doutf8 = FALSE;
1963 #ifdef PERL_COPY_ON_WRITE
1968 /* known replacement string? */
1969 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1970 if (PL_op->op_flags & OPf_STACKED)
1972 else if (PL_op->op_private & OPpTARGET_MY)
1979 #ifdef PERL_COPY_ON_WRITE
1980 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1981 because they make integers such as 256 "false". */
1982 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1985 sv_force_normal_flags(TARG,0);
1988 #ifdef PERL_COPY_ON_WRITE
1992 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1993 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1994 DIE(aTHX_ PL_no_modify);
1997 s = SvPV(TARG, len);
1998 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2000 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2001 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2006 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2010 DIE(aTHX_ "panic: pp_subst");
2013 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2014 maxiters = 2 * slen + 10; /* We can match twice at each
2015 position, once with zero-length,
2016 second time with non-zero. */
2018 if (!rx->prelen && PL_curpm) {
2022 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2023 ? REXEC_COPY_STR : 0;
2025 r_flags |= REXEC_SCREAM;
2028 if (rx->reganch & RE_USE_INTUIT) {
2030 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2034 /* How to do it in subst? */
2035 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2037 && ((rx->reganch & ROPT_NOSCAN)
2038 || !((rx->reganch & RE_INTUIT_TAIL)
2039 && (r_flags & REXEC_SCREAM))))
2044 /* only replace once? */
2045 once = !(rpm->op_pmflags & PMf_GLOBAL);
2047 /* known replacement string? */
2049 /* replacement needing upgrading? */
2050 if (DO_UTF8(TARG) && !doutf8) {
2051 nsv = sv_newmortal();
2054 sv_recode_to_utf8(nsv, PL_encoding);
2056 sv_utf8_upgrade(nsv);
2057 c = SvPV(nsv, clen);
2061 c = SvPV(dstr, clen);
2062 doutf8 = DO_UTF8(dstr);
2070 /* can do inplace substitution? */
2072 #ifdef PERL_COPY_ON_WRITE
2075 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2076 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2077 && (!doutf8 || SvUTF8(TARG))) {
2078 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2079 r_flags | REXEC_CHECKED))
2083 LEAVE_SCOPE(oldsave);
2086 #ifdef PERL_COPY_ON_WRITE
2087 if (SvIsCOW(TARG)) {
2088 assert (!force_on_match);
2092 if (force_on_match) {
2094 s = SvPV_force(TARG, len);
2099 SvSCREAM_off(TARG); /* disable possible screamer */
2101 rxtainted |= RX_MATCH_TAINTED(rx);
2102 m = orig + rx->startp[0];
2103 d = orig + rx->endp[0];
2105 if (m - s > strend - d) { /* faster to shorten from end */
2107 Copy(c, m, clen, char);
2112 Move(d, m, i, char);
2116 SvCUR_set(TARG, m - s);
2119 else if ((i = m - s)) { /* faster from front */
2127 Copy(c, m, clen, char);
2132 Copy(c, d, clen, char);
2137 TAINT_IF(rxtainted & 1);
2143 if (iters++ > maxiters)
2144 DIE(aTHX_ "Substitution loop");
2145 rxtainted |= RX_MATCH_TAINTED(rx);
2146 m = rx->startp[0] + orig;
2150 Move(s, d, i, char);
2154 Copy(c, d, clen, char);
2157 s = rx->endp[0] + orig;
2158 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2160 /* don't match same null twice */
2161 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2164 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2165 Move(s, d, i+1, char); /* include the NUL */
2167 TAINT_IF(rxtainted & 1);
2169 PUSHs(sv_2mortal(newSViv((I32)iters)));
2171 (void)SvPOK_only_UTF8(TARG);
2172 TAINT_IF(rxtainted);
2173 if (SvSMAGICAL(TARG)) {
2181 LEAVE_SCOPE(oldsave);
2185 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2186 r_flags | REXEC_CHECKED))
2188 if (force_on_match) {
2190 s = SvPV_force(TARG, len);
2193 #ifdef PERL_COPY_ON_WRITE
2196 rxtainted |= RX_MATCH_TAINTED(rx);
2197 dstr = newSVpvn(m, s-m);
2202 register PERL_CONTEXT *cx;
2206 RETURNOP(cPMOP->op_pmreplroot);
2208 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2210 if (iters++ > maxiters)
2211 DIE(aTHX_ "Substitution loop");
2212 rxtainted |= RX_MATCH_TAINTED(rx);
2213 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2218 strend = s + (strend - m);
2220 m = rx->startp[0] + orig;
2221 if (doutf8 && !SvUTF8(dstr))
2222 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2224 sv_catpvn(dstr, s, m-s);
2225 s = rx->endp[0] + orig;
2227 sv_catpvn(dstr, c, clen);
2230 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2231 TARG, NULL, r_flags));
2232 if (doutf8 && !DO_UTF8(TARG))
2233 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2235 sv_catpvn(dstr, s, strend - s);
2237 #ifdef PERL_COPY_ON_WRITE
2238 /* The match may make the string COW. If so, brilliant, because that's
2239 just saved us one malloc, copy and free - the regexp has donated
2240 the old buffer, and we malloc an entirely new one, rather than the
2241 regexp malloc()ing a buffer and copying our original, only for
2242 us to throw it away here during the substitution. */
2243 if (SvIsCOW(TARG)) {
2244 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2250 SvPV_set(TARG, SvPVX(dstr));
2251 SvCUR_set(TARG, SvCUR(dstr));
2252 SvLEN_set(TARG, SvLEN(dstr));
2253 doutf8 |= DO_UTF8(dstr);
2254 SvPV_set(dstr, (char*)0);
2257 TAINT_IF(rxtainted & 1);
2259 PUSHs(sv_2mortal(newSViv((I32)iters)));
2261 (void)SvPOK_only(TARG);
2264 TAINT_IF(rxtainted);
2267 LEAVE_SCOPE(oldsave);
2276 LEAVE_SCOPE(oldsave);
2285 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2286 ++*PL_markstack_ptr;
2287 LEAVE; /* exit inner scope */
2290 if (PL_stack_base + *PL_markstack_ptr > SP) {
2292 I32 gimme = GIMME_V;
2294 LEAVE; /* exit outer scope */
2295 (void)POPMARK; /* pop src */
2296 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2297 (void)POPMARK; /* pop dst */
2298 SP = PL_stack_base + POPMARK; /* pop original mark */
2299 if (gimme == G_SCALAR) {
2300 if (PL_op->op_private & OPpGREP_LEX) {
2301 SV* sv = sv_newmortal();
2302 sv_setiv(sv, items);
2310 else if (gimme == G_ARRAY)
2317 ENTER; /* enter inner scope */
2320 src = PL_stack_base[*PL_markstack_ptr];
2322 if (PL_op->op_private & OPpGREP_LEX)
2323 PAD_SVl(PL_op->op_targ) = src;
2327 RETURNOP(cLOGOP->op_other);
2338 register PERL_CONTEXT *cx;
2342 cxstack_ix++; /* temporarily protect top context */
2345 if (gimme == G_SCALAR) {
2348 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2350 *MARK = SvREFCNT_inc(TOPs);
2355 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2357 *MARK = sv_mortalcopy(sv);
2362 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2366 *MARK = &PL_sv_undef;
2370 else if (gimme == G_ARRAY) {
2371 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2372 if (!SvTEMP(*MARK)) {
2373 *MARK = sv_mortalcopy(*MARK);
2374 TAINT_NOT; /* Each item is independent */
2382 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2383 PL_curpm = newpm; /* ... and pop $1 et al */
2386 return cx->blk_sub.retop;
2389 /* This duplicates the above code because the above code must not
2390 * get any slower by more conditions */
2398 register PERL_CONTEXT *cx;
2402 cxstack_ix++; /* temporarily protect top context */
2406 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2407 /* We are an argument to a function or grep().
2408 * This kind of lvalueness was legal before lvalue
2409 * subroutines too, so be backward compatible:
2410 * cannot report errors. */
2412 /* Scalar context *is* possible, on the LHS of -> only,
2413 * as in f()->meth(). But this is not an lvalue. */
2414 if (gimme == G_SCALAR)
2416 if (gimme == G_ARRAY) {
2417 if (!CvLVALUE(cx->blk_sub.cv))
2418 goto temporise_array;
2419 EXTEND_MORTAL(SP - newsp);
2420 for (mark = newsp + 1; mark <= SP; mark++) {
2423 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2424 *mark = sv_mortalcopy(*mark);
2426 /* Can be a localized value subject to deletion. */
2427 PL_tmps_stack[++PL_tmps_ix] = *mark;
2428 (void)SvREFCNT_inc(*mark);
2433 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2434 /* Here we go for robustness, not for speed, so we change all
2435 * the refcounts so the caller gets a live guy. Cannot set
2436 * TEMP, so sv_2mortal is out of question. */
2437 if (!CvLVALUE(cx->blk_sub.cv)) {
2443 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2445 if (gimme == G_SCALAR) {
2449 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2455 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2456 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2457 : "a readonly value" : "a temporary");
2459 else { /* Can be a localized value
2460 * subject to deletion. */
2461 PL_tmps_stack[++PL_tmps_ix] = *mark;
2462 (void)SvREFCNT_inc(*mark);
2465 else { /* Should not happen? */
2471 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2472 (MARK > SP ? "Empty array" : "Array"));
2476 else if (gimme == G_ARRAY) {
2477 EXTEND_MORTAL(SP - newsp);
2478 for (mark = newsp + 1; mark <= SP; mark++) {
2479 if (*mark != &PL_sv_undef
2480 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2481 /* Might be flattened array after $#array = */
2488 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2489 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2492 /* Can be a localized value subject to deletion. */
2493 PL_tmps_stack[++PL_tmps_ix] = *mark;
2494 (void)SvREFCNT_inc(*mark);
2500 if (gimme == G_SCALAR) {
2504 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2506 *MARK = SvREFCNT_inc(TOPs);
2511 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2513 *MARK = sv_mortalcopy(sv);
2518 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2522 *MARK = &PL_sv_undef;
2526 else if (gimme == G_ARRAY) {
2528 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2529 if (!SvTEMP(*MARK)) {
2530 *MARK = sv_mortalcopy(*MARK);
2531 TAINT_NOT; /* Each item is independent */
2540 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2541 PL_curpm = newpm; /* ... and pop $1 et al */
2544 return cx->blk_sub.retop;
2549 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2551 SV *dbsv = GvSV(PL_DBsub);
2554 if (!PERLDB_SUB_NN) {
2557 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2558 || strEQ(GvNAME(gv), "END")
2559 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2560 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2561 && (gv = (GV*)*svp) ))) {
2562 /* Use GV from the stack as a fallback. */
2563 /* GV is potentially non-unique, or contain different CV. */
2564 SV *tmp = newRV((SV*)cv);
2565 sv_setsv(dbsv, tmp);
2569 gv_efullname3(dbsv, gv, Nullch);
2573 const int type = SvTYPE(dbsv);
2574 if (type < SVt_PVIV && type != SVt_IV)
2575 sv_upgrade(dbsv, SVt_PVIV);
2576 (void)SvIOK_on(dbsv);
2577 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2581 PL_curcopdb = PL_curcop;
2582 cv = GvCV(PL_DBsub);
2592 register PERL_CONTEXT *cx;
2594 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2597 DIE(aTHX_ "Not a CODE reference");
2598 switch (SvTYPE(sv)) {
2599 /* This is overwhelming the most common case: */
2601 if (!(cv = GvCVu((GV*)sv)))
2602 cv = sv_2cv(sv, &stash, &gv, FALSE);
2612 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2614 SP = PL_stack_base + POPMARK;
2617 if (SvGMAGICAL(sv)) {
2621 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2625 sym = SvPV(sv, n_a);
2628 DIE(aTHX_ PL_no_usym, "a subroutine");
2629 if (PL_op->op_private & HINT_STRICT_REFS)
2630 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2631 cv = get_cv(sym, TRUE);
2636 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2637 tryAMAGICunDEREF(to_cv);
2640 if (SvTYPE(cv) == SVt_PVCV)
2645 DIE(aTHX_ "Not a CODE reference");
2646 /* This is the second most common case: */
2656 if (!CvROOT(cv) && !CvXSUB(cv)) {
2661 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2662 if (CvASSERTION(cv) && PL_DBassertion)
2663 sv_setiv(PL_DBassertion, 1);
2665 cv = get_db_sub(&sv, cv);
2666 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2667 DIE(aTHX_ "No DB::sub routine defined");
2670 if (!(CvXSUB(cv))) {
2671 /* This path taken at least 75% of the time */
2673 register I32 items = SP - MARK;
2674 AV* padlist = CvPADLIST(cv);
2675 PUSHBLOCK(cx, CXt_SUB, MARK);
2677 cx->blk_sub.retop = PL_op->op_next;
2679 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2680 * that eval'' ops within this sub know the correct lexical space.
2681 * Owing the speed considerations, we choose instead to search for
2682 * the cv using find_runcv() when calling doeval().
2684 if (CvDEPTH(cv) >= 2) {
2685 PERL_STACK_OVERFLOW_CHECK();
2686 pad_push(padlist, CvDEPTH(cv));
2688 PAD_SET_CUR(padlist, CvDEPTH(cv));
2693 DEBUG_S(PerlIO_printf(Perl_debug_log,
2694 "%p entersub preparing @_\n", thr));
2696 av = (AV*)PAD_SVl(0);
2698 /* @_ is normally not REAL--this should only ever
2699 * happen when DB::sub() calls things that modify @_ */
2704 cx->blk_sub.savearray = GvAV(PL_defgv);
2705 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2706 CX_CURPAD_SAVE(cx->blk_sub);
2707 cx->blk_sub.argarray = av;
2710 if (items > AvMAX(av) + 1) {
2711 SV **ary = AvALLOC(av);
2712 if (AvARRAY(av) != ary) {
2713 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2714 SvPV_set(av, (char*)ary);
2716 if (items > AvMAX(av) + 1) {
2717 AvMAX(av) = items - 1;
2718 Renew(ary,items,SV*);
2720 SvPV_set(av, (char*)ary);
2723 Copy(MARK,AvARRAY(av),items,SV*);
2724 AvFILLp(av) = items - 1;
2732 /* warning must come *after* we fully set up the context
2733 * stuff so that __WARN__ handlers can safely dounwind()
2736 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2737 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2738 sub_crush_depth(cv);
2740 DEBUG_S(PerlIO_printf(Perl_debug_log,
2741 "%p entersub returning %p\n", thr, CvSTART(cv)));
2743 RETURNOP(CvSTART(cv));
2746 #ifdef PERL_XSUB_OLDSTYLE
2747 if (CvOLDSTYLE(cv)) {
2748 I32 (*fp3)(int,int,int);
2750 register I32 items = SP - MARK;
2751 /* We dont worry to copy from @_. */
2756 PL_stack_sp = mark + 1;
2757 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2758 items = (*fp3)(CvXSUBANY(cv).any_i32,
2759 MARK - PL_stack_base + 1,
2761 PL_stack_sp = PL_stack_base + items;
2764 #endif /* PERL_XSUB_OLDSTYLE */
2766 I32 markix = TOPMARK;
2771 /* Need to copy @_ to stack. Alternative may be to
2772 * switch stack to @_, and copy return values
2773 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2774 AV * const av = GvAV(PL_defgv);
2775 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2778 /* Mark is at the end of the stack. */
2780 Copy(AvARRAY(av), SP + 1, items, SV*);
2785 /* We assume first XSUB in &DB::sub is the called one. */
2787 SAVEVPTR(PL_curcop);
2788 PL_curcop = PL_curcopdb;
2791 /* Do we need to open block here? XXXX */
2792 (void)(*CvXSUB(cv))(aTHX_ cv);
2794 /* Enforce some sanity in scalar context. */
2795 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2796 if (markix > PL_stack_sp - PL_stack_base)
2797 *(PL_stack_base + markix) = &PL_sv_undef;
2799 *(PL_stack_base + markix) = *PL_stack_sp;
2800 PL_stack_sp = PL_stack_base + markix;
2807 assert (0); /* Cannot get here. */
2808 /* This is deliberately moved here as spaghetti code to keep it out of the
2815 /* anonymous or undef'd function leaves us no recourse */
2816 if (CvANON(cv) || !(gv = CvGV(cv)))
2817 DIE(aTHX_ "Undefined subroutine called");
2819 /* autoloaded stub? */
2820 if (cv != GvCV(gv)) {
2823 /* should call AUTOLOAD now? */
2826 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2833 sub_name = sv_newmortal();
2834 gv_efullname3(sub_name, gv, Nullch);
2835 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2839 DIE(aTHX_ "Not a CODE reference");
2845 Perl_sub_crush_depth(pTHX_ CV *cv)
2848 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2850 SV* tmpstr = sv_newmortal();
2851 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2852 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2861 SV* const elemsv = POPs;
2862 IV elem = SvIV(elemsv);
2864 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2865 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2868 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2869 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2871 elem -= PL_curcop->cop_arybase;
2872 if (SvTYPE(av) != SVt_PVAV)
2874 svp = av_fetch(av, elem, lval && !defer);
2876 #ifdef PERL_MALLOC_WRAP
2877 if (SvUOK(elemsv)) {
2878 const UV uv = SvUV(elemsv);
2879 elem = uv > IV_MAX ? IV_MAX : uv;
2881 else if (SvNOK(elemsv))
2882 elem = (IV)SvNV(elemsv);
2884 static const char oom_array_extend[] =
2885 "Out of memory during array extend"; /* Duplicated in av.c */
2886 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2889 if (!svp || *svp == &PL_sv_undef) {
2892 DIE(aTHX_ PL_no_aelem, elem);
2893 lv = sv_newmortal();
2894 sv_upgrade(lv, SVt_PVLV);
2896 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2897 LvTARG(lv) = SvREFCNT_inc(av);
2898 LvTARGOFF(lv) = elem;
2903 if (PL_op->op_private & OPpLVAL_INTRO)
2904 save_aelem(av, elem, svp);
2905 else if (PL_op->op_private & OPpDEREF)
2906 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2908 sv = (svp ? *svp : &PL_sv_undef);
2909 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2910 sv = sv_mortalcopy(sv);
2916 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2922 Perl_croak(aTHX_ PL_no_modify);
2923 if (SvTYPE(sv) < SVt_RV)
2924 sv_upgrade(sv, SVt_RV);
2925 else if (SvTYPE(sv) >= SVt_PV) {
2932 SvRV_set(sv, NEWSV(355,0));
2935 SvRV_set(sv, (SV*)newAV());
2938 SvRV_set(sv, (SV*)newHV());
2953 if (SvTYPE(rsv) == SVt_PVCV) {
2959 SETs(method_common(sv, Null(U32*)));
2967 U32 hash = SvUVX(sv);
2969 XPUSHs(method_common(sv, &hash));
2974 S_method_common(pTHX_ SV* meth, U32* hashp)
2981 const char* packname = 0;
2982 SV *packsv = Nullsv;
2984 const char *name = SvPV(meth, namelen);
2986 sv = *(PL_stack_base + TOPMARK + 1);
2989 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2998 /* this isn't a reference */
3001 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3002 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3004 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3011 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3012 !(ob=(SV*)GvIO(iogv)))
3014 /* this isn't the name of a filehandle either */
3016 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3017 ? !isIDFIRST_utf8((U8*)packname)
3018 : !isIDFIRST(*packname)
3021 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3022 SvOK(sv) ? "without a package or object reference"
3023 : "on an undefined value");
3025 /* assume it's a package name */
3026 stash = gv_stashpvn(packname, packlen, FALSE);
3030 SV* ref = newSViv(PTR2IV(stash));
3031 hv_store(PL_stashcache, packname, packlen, ref, 0);
3035 /* it _is_ a filehandle name -- replace with a reference */
3036 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3039 /* if we got here, ob should be a reference or a glob */
3040 if (!ob || !(SvOBJECT(ob)
3041 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3044 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3048 stash = SvSTASH(ob);
3051 /* NOTE: stash may be null, hope hv_fetch_ent and
3052 gv_fetchmethod can cope (it seems they can) */
3054 /* shortcut for simple names */
3056 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3058 gv = (GV*)HeVAL(he);
3059 if (isGV(gv) && GvCV(gv) &&
3060 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3061 return (SV*)GvCV(gv);
3065 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3068 /* This code tries to figure out just what went wrong with
3069 gv_fetchmethod. It therefore needs to duplicate a lot of
3070 the internals of that function. We can't move it inside
3071 Perl_gv_fetchmethod_autoload(), however, since that would
3072 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3075 const char* leaf = name;
3076 const char* sep = Nullch;
3079 for (p = name; *p; p++) {
3081 sep = p, leaf = p + 1;
3082 else if (*p == ':' && *(p + 1) == ':')
3083 sep = p, leaf = p + 2;
3085 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3086 /* the method name is unqualified or starts with SUPER:: */
3087 bool need_strlen = 1;
3089 packname = CopSTASHPV(PL_curcop);
3092 HEK *packhek = HvNAME_HEK(stash);
3094 packname = HEK_KEY(packhek);
3095 packlen = HEK_LEN(packhek);
3105 "Can't use anonymous symbol table for method lookup");
3107 else if (need_strlen)
3108 packlen = strlen(packname);
3112 /* the method name is qualified */
3114 packlen = sep - name;
3117 /* we're relying on gv_fetchmethod not autovivifying the stash */
3118 if (gv_stashpvn(packname, packlen, FALSE)) {
3120 "Can't locate object method \"%s\" via package \"%.*s\"",
3121 leaf, (int)packlen, packname);
3125 "Can't locate object method \"%s\" via package \"%.*s\""
3126 " (perhaps you forgot to load \"%.*s\"?)",
3127 leaf, (int)packlen, packname, (int)packlen, packname);
3130 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3135 * c-indentation-style: bsd
3137 * indent-tabs-mode: t
3140 * ex: set ts=8 sts=4 sw=4 noet: