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_const(left, llen); /* Needed to set UTF8 flag */
177 lbyte = !DO_UTF8(left);
182 if (lbyte != rbyte) {
184 sv_utf8_upgrade_nomg(TARG);
187 right = sv_2mortal(newSVpvn(rpv, rlen));
188 sv_utf8_upgrade_nomg(right);
189 rpv = SvPV(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_OLD_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 = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1402 assert (SvPOKp(rx->saved_copy));
1407 rx->subbeg = savepvn(t, strend - t);
1408 #ifdef PERL_OLD_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)) {
1530 SvPV_force_nolen(sv);
1536 sv = sv_2mortal(NEWSV(57, 80));
1540 /* This should not be marked tainted if the fp is marked clean */
1541 #define MAYBE_TAINT_LINE(io, sv) \
1542 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1547 /* delay EOF state for a snarfed empty file */
1548 #define SNARF_EOF(gimme,rs,io,sv) \
1549 (gimme != G_SCALAR || SvCUR(sv) \
1550 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1554 if (!sv_gets(sv, fp, offset)
1556 || SNARF_EOF(gimme, PL_rs, io, sv)
1557 || PerlIO_error(fp)))
1559 PerlIO_clearerr(fp);
1560 if (IoFLAGS(io) & IOf_ARGV) {
1561 fp = nextargv(PL_last_in_gv);
1564 (void)do_close(PL_last_in_gv, FALSE);
1566 else if (type == OP_GLOB) {
1567 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1568 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1569 "glob failed (child exited with status %d%s)",
1570 (int)(STATUS_CURRENT >> 8),
1571 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1574 if (gimme == G_SCALAR) {
1575 if (type != OP_RCATLINE) {
1576 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1582 MAYBE_TAINT_LINE(io, sv);
1585 MAYBE_TAINT_LINE(io, sv);
1587 IoFLAGS(io) |= IOf_NOLINE;
1591 if (type == OP_GLOB) {
1594 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1595 tmps = SvEND(sv) - 1;
1596 if (*tmps == *SvPVX_const(PL_rs)) {
1598 SvCUR_set(sv, SvCUR(sv) - 1);
1601 for (tmps = SvPVX(sv); *tmps; tmps++)
1602 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1603 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1605 if (*tmps && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1606 (void)POPs; /* Unmatched wildcard? Chuck it... */
1609 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1610 const U8 *s = (U8*)SvPVX(sv) + offset;
1611 const STRLEN len = SvCUR(sv) - offset;
1614 if (ckWARN(WARN_UTF8) &&
1615 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1616 /* Emulate :encoding(utf8) warning in the same case. */
1617 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1618 "utf8 \"\\x%02X\" does not map to Unicode",
1619 f < (U8*)SvEND(sv) ? *f : 0);
1621 if (gimme == G_ARRAY) {
1622 if (SvLEN(sv) - SvCUR(sv) > 20) {
1623 SvPV_shrink_to_cur(sv);
1625 sv = sv_2mortal(NEWSV(58, 80));
1628 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1629 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1630 const STRLEN new_len
1631 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1632 SvPV_renew(sv, new_len);
1641 register PERL_CONTEXT *cx;
1642 I32 gimme = OP_GIMME(PL_op, -1);
1645 if (cxstack_ix >= 0)
1646 gimme = cxstack[cxstack_ix].blk_gimme;
1654 PUSHBLOCK(cx, CXt_BLOCK, SP);
1666 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1667 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1669 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1672 if (SvTYPE(hv) == SVt_PVHV) {
1673 if (PL_op->op_private & OPpLVAL_INTRO) {
1676 /* does the element we're localizing already exist? */
1678 /* can we determine whether it exists? */
1680 || mg_find((SV*)hv, PERL_MAGIC_env)
1681 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1682 /* Try to preserve the existenceness of a tied hash
1683 * element by using EXISTS and DELETE if possible.
1684 * Fallback to FETCH and STORE otherwise */
1685 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1686 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1687 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1689 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1692 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1693 svp = he ? &HeVAL(he) : 0;
1699 if (!svp || *svp == &PL_sv_undef) {
1703 DIE(aTHX_ PL_no_helem_sv, keysv);
1705 lv = sv_newmortal();
1706 sv_upgrade(lv, SVt_PVLV);
1708 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1709 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1710 LvTARG(lv) = SvREFCNT_inc(hv);
1715 if (PL_op->op_private & OPpLVAL_INTRO) {
1716 if (HvNAME_get(hv) && isGV(*svp))
1717 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1721 const char * const key = SvPV_const(keysv, keylen);
1722 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1724 save_helem(hv, keysv, svp);
1727 else if (PL_op->op_private & OPpDEREF)
1728 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1730 sv = (svp ? *svp : &PL_sv_undef);
1731 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1732 * Pushing the magical RHS on to the stack is useless, since
1733 * that magic is soon destined to be misled by the local(),
1734 * and thus the later pp_sassign() will fail to mg_get() the
1735 * old value. This should also cure problems with delayed
1736 * mg_get()s. GSAR 98-07-03 */
1737 if (!lval && SvGMAGICAL(sv))
1738 sv = sv_mortalcopy(sv);
1746 register PERL_CONTEXT *cx;
1751 if (PL_op->op_flags & OPf_SPECIAL) {
1752 cx = &cxstack[cxstack_ix];
1753 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1758 gimme = OP_GIMME(PL_op, -1);
1760 if (cxstack_ix >= 0)
1761 gimme = cxstack[cxstack_ix].blk_gimme;
1767 if (gimme == G_VOID)
1769 else if (gimme == G_SCALAR) {
1773 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1776 *MARK = sv_mortalcopy(TOPs);
1779 *MARK = &PL_sv_undef;
1783 else if (gimme == G_ARRAY) {
1784 /* in case LEAVE wipes old return values */
1786 for (mark = newsp + 1; mark <= SP; mark++) {
1787 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1788 *mark = sv_mortalcopy(*mark);
1789 TAINT_NOT; /* Each item is independent */
1793 PL_curpm = newpm; /* Don't pop $1 et al till now */
1803 register PERL_CONTEXT *cx;
1809 cx = &cxstack[cxstack_ix];
1810 if (CxTYPE(cx) != CXt_LOOP)
1811 DIE(aTHX_ "panic: pp_iter");
1813 itersvp = CxITERVAR(cx);
1814 av = cx->blk_loop.iterary;
1815 if (SvTYPE(av) != SVt_PVAV) {
1816 /* iterate ($min .. $max) */
1817 if (cx->blk_loop.iterlval) {
1818 /* string increment */
1819 register SV* cur = cx->blk_loop.iterlval;
1821 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1822 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1823 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1824 /* safe to reuse old SV */
1825 sv_setsv(*itersvp, cur);
1829 /* we need a fresh SV every time so that loop body sees a
1830 * completely new SV for closures/references to work as
1833 *itersvp = newSVsv(cur);
1834 SvREFCNT_dec(oldsv);
1836 if (strEQ(SvPVX_const(cur), max))
1837 sv_setiv(cur, 0); /* terminate next time */
1844 /* integer increment */
1845 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1848 /* don't risk potential race */
1849 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1850 /* safe to reuse old SV */
1851 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1855 /* we need a fresh SV every time so that loop body sees a
1856 * completely new SV for closures/references to work as they
1859 *itersvp = newSViv(cx->blk_loop.iterix++);
1860 SvREFCNT_dec(oldsv);
1866 if (PL_op->op_private & OPpITER_REVERSED) {
1867 /* In reverse, use itermax as the min :-) */
1868 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1871 if (SvMAGICAL(av) || AvREIFY(av)) {
1872 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1879 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1883 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1887 if (SvMAGICAL(av) || AvREIFY(av)) {
1888 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1895 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1899 if (sv && SvREFCNT(sv) == 0) {
1901 Perl_croak(aTHX_ "Use of freed value in iteration");
1908 if (av != PL_curstack && sv == &PL_sv_undef) {
1909 SV *lv = cx->blk_loop.iterlval;
1910 if (lv && SvREFCNT(lv) > 1) {
1915 SvREFCNT_dec(LvTARG(lv));
1917 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1918 sv_upgrade(lv, SVt_PVLV);
1920 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1922 LvTARG(lv) = SvREFCNT_inc(av);
1923 LvTARGOFF(lv) = cx->blk_loop.iterix;
1924 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1929 *itersvp = SvREFCNT_inc(sv);
1930 SvREFCNT_dec(oldsv);
1938 register PMOP *pm = cPMOP;
1954 register REGEXP *rx = PM_GETRE(pm);
1956 int force_on_match = 0;
1957 I32 oldsave = PL_savestack_ix;
1959 bool doutf8 = FALSE;
1960 #ifdef PERL_OLD_COPY_ON_WRITE
1965 /* known replacement string? */
1966 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1967 if (PL_op->op_flags & OPf_STACKED)
1969 else if (PL_op->op_private & OPpTARGET_MY)
1976 #ifdef PERL_OLD_COPY_ON_WRITE
1977 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1978 because they make integers such as 256 "false". */
1979 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1982 sv_force_normal_flags(TARG,0);
1985 #ifdef PERL_OLD_COPY_ON_WRITE
1989 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1990 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1991 DIE(aTHX_ PL_no_modify);
1994 s = SvPV_mutable(TARG, len);
1995 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1997 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1998 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2003 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2007 DIE(aTHX_ "panic: pp_subst");
2010 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2011 maxiters = 2 * slen + 10; /* We can match twice at each
2012 position, once with zero-length,
2013 second time with non-zero. */
2015 if (!rx->prelen && PL_curpm) {
2019 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2020 ? REXEC_COPY_STR : 0;
2022 r_flags |= REXEC_SCREAM;
2025 if (rx->reganch & RE_USE_INTUIT) {
2027 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2031 /* How to do it in subst? */
2032 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2034 && ((rx->reganch & ROPT_NOSCAN)
2035 || !((rx->reganch & RE_INTUIT_TAIL)
2036 && (r_flags & REXEC_SCREAM))))
2041 /* only replace once? */
2042 once = !(rpm->op_pmflags & PMf_GLOBAL);
2044 /* known replacement string? */
2046 /* replacement needing upgrading? */
2047 if (DO_UTF8(TARG) && !doutf8) {
2048 nsv = sv_newmortal();
2051 sv_recode_to_utf8(nsv, PL_encoding);
2053 sv_utf8_upgrade(nsv);
2054 c = SvPV_const(nsv, clen);
2058 c = SvPV_const(dstr, clen);
2059 doutf8 = DO_UTF8(dstr);
2067 /* can do inplace substitution? */
2069 #ifdef PERL_OLD_COPY_ON_WRITE
2072 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2073 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2074 && (!doutf8 || SvUTF8(TARG))) {
2075 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2076 r_flags | REXEC_CHECKED))
2080 LEAVE_SCOPE(oldsave);
2083 #ifdef PERL_OLD_COPY_ON_WRITE
2084 if (SvIsCOW(TARG)) {
2085 assert (!force_on_match);
2089 if (force_on_match) {
2091 s = SvPV_force(TARG, len);
2096 SvSCREAM_off(TARG); /* disable possible screamer */
2098 rxtainted |= RX_MATCH_TAINTED(rx);
2099 m = orig + rx->startp[0];
2100 d = orig + rx->endp[0];
2102 if (m - s > strend - d) { /* faster to shorten from end */
2104 Copy(c, m, clen, char);
2109 Move(d, m, i, char);
2113 SvCUR_set(TARG, m - s);
2116 else if ((i = m - s)) { /* faster from front */
2124 Copy(c, m, clen, char);
2129 Copy(c, d, clen, char);
2134 TAINT_IF(rxtainted & 1);
2140 if (iters++ > maxiters)
2141 DIE(aTHX_ "Substitution loop");
2142 rxtainted |= RX_MATCH_TAINTED(rx);
2143 m = rx->startp[0] + orig;
2147 Move(s, d, i, char);
2151 Copy(c, d, clen, char);
2154 s = rx->endp[0] + orig;
2155 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2157 /* don't match same null twice */
2158 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2161 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2162 Move(s, d, i+1, char); /* include the NUL */
2164 TAINT_IF(rxtainted & 1);
2166 PUSHs(sv_2mortal(newSViv((I32)iters)));
2168 (void)SvPOK_only_UTF8(TARG);
2169 TAINT_IF(rxtainted);
2170 if (SvSMAGICAL(TARG)) {
2178 LEAVE_SCOPE(oldsave);
2182 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2183 r_flags | REXEC_CHECKED))
2185 if (force_on_match) {
2187 s = SvPV_force(TARG, len);
2190 #ifdef PERL_OLD_COPY_ON_WRITE
2193 rxtainted |= RX_MATCH_TAINTED(rx);
2194 dstr = newSVpvn(m, s-m);
2199 register PERL_CONTEXT *cx;
2203 RETURNOP(cPMOP->op_pmreplroot);
2205 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2207 if (iters++ > maxiters)
2208 DIE(aTHX_ "Substitution loop");
2209 rxtainted |= RX_MATCH_TAINTED(rx);
2210 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2215 strend = s + (strend - m);
2217 m = rx->startp[0] + orig;
2218 if (doutf8 && !SvUTF8(dstr))
2219 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2221 sv_catpvn(dstr, s, m-s);
2222 s = rx->endp[0] + orig;
2224 sv_catpvn(dstr, c, clen);
2227 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2228 TARG, NULL, r_flags));
2229 if (doutf8 && !DO_UTF8(TARG))
2230 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2232 sv_catpvn(dstr, s, strend - s);
2234 #ifdef PERL_OLD_COPY_ON_WRITE
2235 /* The match may make the string COW. If so, brilliant, because that's
2236 just saved us one malloc, copy and free - the regexp has donated
2237 the old buffer, and we malloc an entirely new one, rather than the
2238 regexp malloc()ing a buffer and copying our original, only for
2239 us to throw it away here during the substitution. */
2240 if (SvIsCOW(TARG)) {
2241 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2247 SvPV_set(TARG, SvPVX(dstr));
2248 SvCUR_set(TARG, SvCUR(dstr));
2249 SvLEN_set(TARG, SvLEN(dstr));
2250 doutf8 |= DO_UTF8(dstr);
2251 SvPV_set(dstr, (char*)0);
2254 TAINT_IF(rxtainted & 1);
2256 PUSHs(sv_2mortal(newSViv((I32)iters)));
2258 (void)SvPOK_only(TARG);
2261 TAINT_IF(rxtainted);
2264 LEAVE_SCOPE(oldsave);
2273 LEAVE_SCOPE(oldsave);
2282 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2283 ++*PL_markstack_ptr;
2284 LEAVE; /* exit inner scope */
2287 if (PL_stack_base + *PL_markstack_ptr > SP) {
2289 I32 gimme = GIMME_V;
2291 LEAVE; /* exit outer scope */
2292 (void)POPMARK; /* pop src */
2293 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2294 (void)POPMARK; /* pop dst */
2295 SP = PL_stack_base + POPMARK; /* pop original mark */
2296 if (gimme == G_SCALAR) {
2297 if (PL_op->op_private & OPpGREP_LEX) {
2298 SV* sv = sv_newmortal();
2299 sv_setiv(sv, items);
2307 else if (gimme == G_ARRAY)
2314 ENTER; /* enter inner scope */
2317 src = PL_stack_base[*PL_markstack_ptr];
2319 if (PL_op->op_private & OPpGREP_LEX)
2320 PAD_SVl(PL_op->op_targ) = src;
2324 RETURNOP(cLOGOP->op_other);
2335 register PERL_CONTEXT *cx;
2339 cxstack_ix++; /* temporarily protect top context */
2342 if (gimme == G_SCALAR) {
2345 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2347 *MARK = SvREFCNT_inc(TOPs);
2352 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2354 *MARK = sv_mortalcopy(sv);
2359 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2363 *MARK = &PL_sv_undef;
2367 else if (gimme == G_ARRAY) {
2368 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2369 if (!SvTEMP(*MARK)) {
2370 *MARK = sv_mortalcopy(*MARK);
2371 TAINT_NOT; /* Each item is independent */
2379 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2380 PL_curpm = newpm; /* ... and pop $1 et al */
2383 return cx->blk_sub.retop;
2386 /* This duplicates the above code because the above code must not
2387 * get any slower by more conditions */
2395 register PERL_CONTEXT *cx;
2399 cxstack_ix++; /* temporarily protect top context */
2403 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2404 /* We are an argument to a function or grep().
2405 * This kind of lvalueness was legal before lvalue
2406 * subroutines too, so be backward compatible:
2407 * cannot report errors. */
2409 /* Scalar context *is* possible, on the LHS of -> only,
2410 * as in f()->meth(). But this is not an lvalue. */
2411 if (gimme == G_SCALAR)
2413 if (gimme == G_ARRAY) {
2414 if (!CvLVALUE(cx->blk_sub.cv))
2415 goto temporise_array;
2416 EXTEND_MORTAL(SP - newsp);
2417 for (mark = newsp + 1; mark <= SP; mark++) {
2420 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2421 *mark = sv_mortalcopy(*mark);
2423 /* Can be a localized value subject to deletion. */
2424 PL_tmps_stack[++PL_tmps_ix] = *mark;
2425 (void)SvREFCNT_inc(*mark);
2430 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2431 /* Here we go for robustness, not for speed, so we change all
2432 * the refcounts so the caller gets a live guy. Cannot set
2433 * TEMP, so sv_2mortal is out of question. */
2434 if (!CvLVALUE(cx->blk_sub.cv)) {
2440 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2442 if (gimme == G_SCALAR) {
2446 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2452 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2453 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2454 : "a readonly value" : "a temporary");
2456 else { /* Can be a localized value
2457 * subject to deletion. */
2458 PL_tmps_stack[++PL_tmps_ix] = *mark;
2459 (void)SvREFCNT_inc(*mark);
2462 else { /* Should not happen? */
2468 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2469 (MARK > SP ? "Empty array" : "Array"));
2473 else if (gimme == G_ARRAY) {
2474 EXTEND_MORTAL(SP - newsp);
2475 for (mark = newsp + 1; mark <= SP; mark++) {
2476 if (*mark != &PL_sv_undef
2477 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2478 /* Might be flattened array after $#array = */
2485 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2486 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2489 /* Can be a localized value subject to deletion. */
2490 PL_tmps_stack[++PL_tmps_ix] = *mark;
2491 (void)SvREFCNT_inc(*mark);
2497 if (gimme == G_SCALAR) {
2501 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2503 *MARK = SvREFCNT_inc(TOPs);
2508 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2510 *MARK = sv_mortalcopy(sv);
2515 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2519 *MARK = &PL_sv_undef;
2523 else if (gimme == G_ARRAY) {
2525 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2526 if (!SvTEMP(*MARK)) {
2527 *MARK = sv_mortalcopy(*MARK);
2528 TAINT_NOT; /* Each item is independent */
2537 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2538 PL_curpm = newpm; /* ... and pop $1 et al */
2541 return cx->blk_sub.retop;
2546 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2548 SV *dbsv = GvSV(PL_DBsub);
2551 if (!PERLDB_SUB_NN) {
2554 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2555 || strEQ(GvNAME(gv), "END")
2556 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2557 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2558 && (gv = (GV*)*svp) ))) {
2559 /* Use GV from the stack as a fallback. */
2560 /* GV is potentially non-unique, or contain different CV. */
2561 SV *tmp = newRV((SV*)cv);
2562 sv_setsv(dbsv, tmp);
2566 gv_efullname3(dbsv, gv, Nullch);
2570 const int type = SvTYPE(dbsv);
2571 if (type < SVt_PVIV && type != SVt_IV)
2572 sv_upgrade(dbsv, SVt_PVIV);
2573 (void)SvIOK_on(dbsv);
2574 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2578 PL_curcopdb = PL_curcop;
2579 cv = GvCV(PL_DBsub);
2589 register PERL_CONTEXT *cx;
2591 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2594 DIE(aTHX_ "Not a CODE reference");
2595 switch (SvTYPE(sv)) {
2596 /* This is overwhelming the most common case: */
2598 if (!(cv = GvCVu((GV*)sv)))
2599 cv = sv_2cv(sv, &stash, &gv, FALSE);
2609 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2611 SP = PL_stack_base + POPMARK;
2614 if (SvGMAGICAL(sv)) {
2618 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2621 sym = SvPV_nolen_const(sv);
2624 DIE(aTHX_ PL_no_usym, "a subroutine");
2625 if (PL_op->op_private & HINT_STRICT_REFS)
2626 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2627 cv = get_cv(sym, TRUE);
2632 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2633 tryAMAGICunDEREF(to_cv);
2636 if (SvTYPE(cv) == SVt_PVCV)
2641 DIE(aTHX_ "Not a CODE reference");
2642 /* This is the second most common case: */
2652 if (!CvROOT(cv) && !CvXSUB(cv)) {
2657 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2658 if (CvASSERTION(cv) && PL_DBassertion)
2659 sv_setiv(PL_DBassertion, 1);
2661 cv = get_db_sub(&sv, cv);
2662 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2663 DIE(aTHX_ "No DB::sub routine defined");
2666 if (!(CvXSUB(cv))) {
2667 /* This path taken at least 75% of the time */
2669 register I32 items = SP - MARK;
2670 AV* padlist = CvPADLIST(cv);
2671 PUSHBLOCK(cx, CXt_SUB, MARK);
2673 cx->blk_sub.retop = PL_op->op_next;
2675 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2676 * that eval'' ops within this sub know the correct lexical space.
2677 * Owing the speed considerations, we choose instead to search for
2678 * the cv using find_runcv() when calling doeval().
2680 if (CvDEPTH(cv) >= 2) {
2681 PERL_STACK_OVERFLOW_CHECK();
2682 pad_push(padlist, CvDEPTH(cv));
2684 PAD_SET_CUR(padlist, CvDEPTH(cv));
2689 DEBUG_S(PerlIO_printf(Perl_debug_log,
2690 "%p entersub preparing @_\n", thr));
2692 av = (AV*)PAD_SVl(0);
2694 /* @_ is normally not REAL--this should only ever
2695 * happen when DB::sub() calls things that modify @_ */
2700 cx->blk_sub.savearray = GvAV(PL_defgv);
2701 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2702 CX_CURPAD_SAVE(cx->blk_sub);
2703 cx->blk_sub.argarray = av;
2706 if (items > AvMAX(av) + 1) {
2707 SV **ary = AvALLOC(av);
2708 if (AvARRAY(av) != ary) {
2709 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2710 SvPV_set(av, (char*)ary);
2712 if (items > AvMAX(av) + 1) {
2713 AvMAX(av) = items - 1;
2714 Renew(ary,items,SV*);
2716 SvPV_set(av, (char*)ary);
2719 Copy(MARK,AvARRAY(av),items,SV*);
2720 AvFILLp(av) = items - 1;
2728 /* warning must come *after* we fully set up the context
2729 * stuff so that __WARN__ handlers can safely dounwind()
2732 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2733 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2734 sub_crush_depth(cv);
2736 DEBUG_S(PerlIO_printf(Perl_debug_log,
2737 "%p entersub returning %p\n", thr, CvSTART(cv)));
2739 RETURNOP(CvSTART(cv));
2742 #ifdef PERL_XSUB_OLDSTYLE
2743 if (CvOLDSTYLE(cv)) {
2744 I32 (*fp3)(int,int,int);
2746 register I32 items = SP - MARK;
2747 /* We dont worry to copy from @_. */
2752 PL_stack_sp = mark + 1;
2753 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2754 items = (*fp3)(CvXSUBANY(cv).any_i32,
2755 MARK - PL_stack_base + 1,
2757 PL_stack_sp = PL_stack_base + items;
2760 #endif /* PERL_XSUB_OLDSTYLE */
2762 I32 markix = TOPMARK;
2767 /* Need to copy @_ to stack. Alternative may be to
2768 * switch stack to @_, and copy return values
2769 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2770 AV * const av = GvAV(PL_defgv);
2771 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2774 /* Mark is at the end of the stack. */
2776 Copy(AvARRAY(av), SP + 1, items, SV*);
2781 /* We assume first XSUB in &DB::sub is the called one. */
2783 SAVEVPTR(PL_curcop);
2784 PL_curcop = PL_curcopdb;
2787 /* Do we need to open block here? XXXX */
2788 (void)(*CvXSUB(cv))(aTHX_ cv);
2790 /* Enforce some sanity in scalar context. */
2791 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2792 if (markix > PL_stack_sp - PL_stack_base)
2793 *(PL_stack_base + markix) = &PL_sv_undef;
2795 *(PL_stack_base + markix) = *PL_stack_sp;
2796 PL_stack_sp = PL_stack_base + markix;
2803 assert (0); /* Cannot get here. */
2804 /* This is deliberately moved here as spaghetti code to keep it out of the
2811 /* anonymous or undef'd function leaves us no recourse */
2812 if (CvANON(cv) || !(gv = CvGV(cv)))
2813 DIE(aTHX_ "Undefined subroutine called");
2815 /* autoloaded stub? */
2816 if (cv != GvCV(gv)) {
2819 /* should call AUTOLOAD now? */
2822 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2829 sub_name = sv_newmortal();
2830 gv_efullname3(sub_name, gv, Nullch);
2831 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2835 DIE(aTHX_ "Not a CODE reference");
2841 Perl_sub_crush_depth(pTHX_ CV *cv)
2844 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2846 SV* tmpstr = sv_newmortal();
2847 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2848 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2857 SV* const elemsv = POPs;
2858 IV elem = SvIV(elemsv);
2860 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2861 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2864 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2865 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2867 elem -= PL_curcop->cop_arybase;
2868 if (SvTYPE(av) != SVt_PVAV)
2870 svp = av_fetch(av, elem, lval && !defer);
2872 #ifdef PERL_MALLOC_WRAP
2873 if (SvUOK(elemsv)) {
2874 const UV uv = SvUV(elemsv);
2875 elem = uv > IV_MAX ? IV_MAX : uv;
2877 else if (SvNOK(elemsv))
2878 elem = (IV)SvNV(elemsv);
2880 static const char oom_array_extend[] =
2881 "Out of memory during array extend"; /* Duplicated in av.c */
2882 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2885 if (!svp || *svp == &PL_sv_undef) {
2888 DIE(aTHX_ PL_no_aelem, elem);
2889 lv = sv_newmortal();
2890 sv_upgrade(lv, SVt_PVLV);
2892 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2893 LvTARG(lv) = SvREFCNT_inc(av);
2894 LvTARGOFF(lv) = elem;
2899 if (PL_op->op_private & OPpLVAL_INTRO)
2900 save_aelem(av, elem, svp);
2901 else if (PL_op->op_private & OPpDEREF)
2902 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2904 sv = (svp ? *svp : &PL_sv_undef);
2905 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2906 sv = sv_mortalcopy(sv);
2912 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2918 Perl_croak(aTHX_ PL_no_modify);
2919 if (SvTYPE(sv) < SVt_RV)
2920 sv_upgrade(sv, SVt_RV);
2921 else if (SvTYPE(sv) >= SVt_PV) {
2928 SvRV_set(sv, NEWSV(355,0));
2931 SvRV_set(sv, (SV*)newAV());
2934 SvRV_set(sv, (SV*)newHV());
2949 if (SvTYPE(rsv) == SVt_PVCV) {
2955 SETs(method_common(sv, Null(U32*)));
2963 U32 hash = SvSHARED_HASH(sv);
2965 XPUSHs(method_common(sv, &hash));
2970 S_method_common(pTHX_ SV* meth, U32* hashp)
2977 const char* packname = 0;
2978 SV *packsv = Nullsv;
2980 const char *name = SvPV_const(meth, namelen);
2982 sv = *(PL_stack_base + TOPMARK + 1);
2985 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2994 /* this isn't a reference */
2997 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2998 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3000 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3007 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3008 !(ob=(SV*)GvIO(iogv)))
3010 /* this isn't the name of a filehandle either */
3012 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3013 ? !isIDFIRST_utf8((U8*)packname)
3014 : !isIDFIRST(*packname)
3017 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3018 SvOK(sv) ? "without a package or object reference"
3019 : "on an undefined value");
3021 /* assume it's a package name */
3022 stash = gv_stashpvn(packname, packlen, FALSE);
3026 SV* ref = newSViv(PTR2IV(stash));
3027 hv_store(PL_stashcache, packname, packlen, ref, 0);
3031 /* it _is_ a filehandle name -- replace with a reference */
3032 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3035 /* if we got here, ob should be a reference or a glob */
3036 if (!ob || !(SvOBJECT(ob)
3037 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3040 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3044 stash = SvSTASH(ob);
3047 /* NOTE: stash may be null, hope hv_fetch_ent and
3048 gv_fetchmethod can cope (it seems they can) */
3050 /* shortcut for simple names */
3052 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3054 gv = (GV*)HeVAL(he);
3055 if (isGV(gv) && GvCV(gv) &&
3056 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3057 return (SV*)GvCV(gv);
3061 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3064 /* This code tries to figure out just what went wrong with
3065 gv_fetchmethod. It therefore needs to duplicate a lot of
3066 the internals of that function. We can't move it inside
3067 Perl_gv_fetchmethod_autoload(), however, since that would
3068 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3071 const char* leaf = name;
3072 const char* sep = Nullch;
3075 for (p = name; *p; p++) {
3077 sep = p, leaf = p + 1;
3078 else if (*p == ':' && *(p + 1) == ':')
3079 sep = p, leaf = p + 2;
3081 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3082 /* the method name is unqualified or starts with SUPER:: */
3083 bool need_strlen = 1;
3085 packname = CopSTASHPV(PL_curcop);
3088 HEK *packhek = HvNAME_HEK(stash);
3090 packname = HEK_KEY(packhek);
3091 packlen = HEK_LEN(packhek);
3101 "Can't use anonymous symbol table for method lookup");
3103 else if (need_strlen)
3104 packlen = strlen(packname);
3108 /* the method name is qualified */
3110 packlen = sep - name;
3113 /* we're relying on gv_fetchmethod not autovivifying the stash */
3114 if (gv_stashpvn(packname, packlen, FALSE)) {
3116 "Can't locate object method \"%s\" via package \"%.*s\"",
3117 leaf, (int)packlen, packname);
3121 "Can't locate object method \"%s\" via package \"%.*s\""
3122 " (perhaps you forgot to load \"%.*s\"?)",
3123 leaf, (int)packlen, packname, (int)packlen, packname);
3126 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3131 * c-indentation-style: bsd
3133 * indent-tabs-mode: t
3136 * ex: set ts=8 sts=4 sw=4 noet: