3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
19 /* This file contains 'hot' pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * By 'hot', we mean common ops whose execution speed is critical.
26 * By gathering them together into a single file, we encourage
27 * CPU cache hits on hot code. Also it could be taken as a warning not to
28 * change any code in this file unless you're sure it won't affect
33 #define PERL_IN_PP_HOT_C
47 PL_curcop = (COP*)PL_op;
48 TAINT_NOT; /* Each statement is presumed innocent */
49 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
58 if (PL_op->op_private & OPpLVAL_INTRO)
59 PUSHs(save_scalar(cGVOP_gv));
61 PUSHs(GvSVn(cGVOP_gv));
72 PL_curcop = (COP*)PL_op;
78 PUSHMARK(PL_stack_sp);
93 XPUSHs((SV*)cGVOP_gv);
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_const(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_const(right, rlen);
192 sv_catpvn_nomg(TARG, rpv, rlen);
203 if (PL_op->op_flags & OPf_MOD) {
204 if (PL_op->op_private & OPpLVAL_INTRO)
205 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
206 if (PL_op->op_private & OPpDEREF) {
208 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
217 tryAMAGICunTARGET(iter, 0);
218 PL_last_in_gv = (GV*)(*PL_stack_sp--);
219 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
220 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
221 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
224 XPUSHs((SV*)PL_last_in_gv);
227 PL_last_in_gv = (GV*)(*PL_stack_sp--);
230 return do_readline();
235 dSP; tryAMAGICbinSET(eq,0);
236 #ifndef NV_PRESERVES_UV
237 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
239 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
243 #ifdef PERL_PRESERVE_IVUV
246 /* Unless the left argument is integer in range we are going
247 to have to use NV maths. Hence only attempt to coerce the
248 right argument if we know the left is integer. */
251 bool auvok = SvUOK(TOPm1s);
252 bool buvok = SvUOK(TOPs);
254 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
255 /* Casting IV to UV before comparison isn't going to matter
256 on 2s complement. On 1s complement or sign&magnitude
257 (if we have any of them) it could to make negative zero
258 differ from normal zero. As I understand it. (Need to
259 check - is negative zero implementation defined behaviour
261 UV buv = SvUVX(POPs);
262 UV auv = SvUVX(TOPs);
264 SETs(boolSV(auv == buv));
267 { /* ## Mixed IV,UV ## */
271 /* == is commutative so doesn't matter which is left or right */
273 /* top of stack (b) is the iv */
282 /* As uv is a UV, it's >0, so it cannot be == */
286 /* we know iv is >= 0 */
287 SETs(boolSV((UV)iv == SvUVX(uvp)));
295 SETs(boolSV(TOPn == value));
303 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
304 DIE(aTHX_ PL_no_modify);
305 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
306 && SvIVX(TOPs) != IV_MAX)
308 SvIV_set(TOPs, SvIVX(TOPs) + 1);
309 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
311 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
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++) {
975 TAINT_NOT; /* Each item is independent */
976 *relem = sv_mortalcopy(sv);
986 while (lelem <= lastlelem) {
987 TAINT_NOT; /* Each item stands on its own, taintwise. */
989 switch (SvTYPE(sv)) {
992 magic = SvMAGICAL(ary) != 0;
994 av_extend(ary, lastrelem - relem);
996 while (relem <= lastrelem) { /* gobble up all the rest */
999 sv = newSVsv(*relem);
1001 didstore = av_store(ary,i++,sv);
1011 case SVt_PVHV: { /* normal hash */
1015 magic = SvMAGICAL(hash) != 0;
1017 firsthashrelem = relem;
1019 while (relem < lastrelem) { /* gobble up all the rest */
1024 sv = &PL_sv_no, relem++;
1025 tmpstr = NEWSV(29,0);
1027 sv_setsv(tmpstr,*relem); /* value */
1028 *(relem++) = tmpstr;
1029 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1030 /* key overwrites an existing entry */
1032 didstore = hv_store_ent(hash,sv,tmpstr,0);
1034 if (SvSMAGICAL(tmpstr))
1041 if (relem == lastrelem) {
1042 do_oddball(hash, relem, firstrelem);
1048 if (SvIMMORTAL(sv)) {
1049 if (relem <= lastrelem)
1053 if (relem <= lastrelem) {
1054 sv_setsv(sv, *relem);
1058 sv_setsv(sv, &PL_sv_undef);
1063 if (PL_delaymagic & ~DM_DELAY) {
1064 if (PL_delaymagic & DM_UID) {
1065 #ifdef HAS_SETRESUID
1066 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1067 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1070 # ifdef HAS_SETREUID
1071 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1072 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1075 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1076 (void)setruid(PL_uid);
1077 PL_delaymagic &= ~DM_RUID;
1079 # endif /* HAS_SETRUID */
1081 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1082 (void)seteuid(PL_euid);
1083 PL_delaymagic &= ~DM_EUID;
1085 # endif /* HAS_SETEUID */
1086 if (PL_delaymagic & DM_UID) {
1087 if (PL_uid != PL_euid)
1088 DIE(aTHX_ "No setreuid available");
1089 (void)PerlProc_setuid(PL_uid);
1091 # endif /* HAS_SETREUID */
1092 #endif /* HAS_SETRESUID */
1093 PL_uid = PerlProc_getuid();
1094 PL_euid = PerlProc_geteuid();
1096 if (PL_delaymagic & DM_GID) {
1097 #ifdef HAS_SETRESGID
1098 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1099 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1102 # ifdef HAS_SETREGID
1103 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1104 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1107 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1108 (void)setrgid(PL_gid);
1109 PL_delaymagic &= ~DM_RGID;
1111 # endif /* HAS_SETRGID */
1113 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1114 (void)setegid(PL_egid);
1115 PL_delaymagic &= ~DM_EGID;
1117 # endif /* HAS_SETEGID */
1118 if (PL_delaymagic & DM_GID) {
1119 if (PL_gid != PL_egid)
1120 DIE(aTHX_ "No setregid available");
1121 (void)PerlProc_setgid(PL_gid);
1123 # endif /* HAS_SETREGID */
1124 #endif /* HAS_SETRESGID */
1125 PL_gid = PerlProc_getgid();
1126 PL_egid = PerlProc_getegid();
1128 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1132 if (gimme == G_VOID)
1133 SP = firstrelem - 1;
1134 else if (gimme == G_SCALAR) {
1137 SETi(lastrelem - firstrelem + 1 - duplicates);
1144 /* Removes from the stack the entries which ended up as
1145 * duplicated keys in the hash (fix for [perl #24380]) */
1146 Move(firsthashrelem + duplicates,
1147 firsthashrelem, duplicates, SV**);
1148 lastrelem -= duplicates;
1153 SP = firstrelem + (lastlelem - firstlelem);
1154 lelem = firstlelem + (relem - firstrelem);
1156 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1164 register PMOP *pm = cPMOP;
1165 SV *rv = sv_newmortal();
1166 SV *sv = newSVrv(rv, "Regexp");
1167 if (pm->op_pmdynflags & PMdf_TAINTED)
1169 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1176 register PMOP *pm = cPMOP;
1178 const register char *t;
1179 const register char *s;
1182 I32 r_flags = REXEC_CHECKED;
1183 const char *truebase; /* Start of string */
1184 register REGEXP *rx = PM_GETRE(pm);
1186 const I32 gimme = GIMME;
1189 const I32 oldsave = PL_savestack_ix;
1190 I32 update_minmatch = 1;
1191 I32 had_zerolen = 0;
1193 if (PL_op->op_flags & OPf_STACKED)
1195 else if (PL_op->op_private & OPpTARGET_MY)
1202 PUTBACK; /* EVAL blocks need stack_sp. */
1203 s = SvPV_const(TARG, len);
1206 DIE(aTHX_ "panic: pp_match");
1207 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1208 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1211 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1213 /* PMdf_USED is set after a ?? matches once */
1214 if (pm->op_pmdynflags & PMdf_USED) {
1216 if (gimme == G_ARRAY)
1221 /* empty pattern special-cased to use last successful pattern if possible */
1222 if (!rx->prelen && PL_curpm) {
1227 if (rx->minlen > (I32)len)
1232 /* XXXX What part of this is needed with true \G-support? */
1233 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1235 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1236 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1237 if (mg && mg->mg_len >= 0) {
1238 if (!(rx->reganch & ROPT_GPOS_SEEN))
1239 rx->endp[0] = rx->startp[0] = mg->mg_len;
1240 else if (rx->reganch & ROPT_ANCH_GPOS) {
1241 r_flags |= REXEC_IGNOREPOS;
1242 rx->endp[0] = rx->startp[0] = mg->mg_len;
1244 minmatch = (mg->mg_flags & MGf_MINMATCH);
1245 update_minmatch = 0;
1249 if ((!global && rx->nparens)
1250 || SvTEMP(TARG) || PL_sawampersand)
1251 r_flags |= REXEC_COPY_STR;
1253 r_flags |= REXEC_SCREAM;
1256 if (global && rx->startp[0] != -1) {
1257 t = s = rx->endp[0] + truebase;
1258 if ((s + rx->minlen) > strend)
1260 if (update_minmatch++)
1261 minmatch = had_zerolen;
1263 if (rx->reganch & RE_USE_INTUIT &&
1264 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1265 /* FIXME - can PL_bostr be made const char *? */
1266 PL_bostr = (char *)truebase;
1267 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)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, (char*)s, (char *)strend, (char*)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());
1303 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1304 const I32 len = rx->endp[i] - rx->startp[i];
1305 s = rx->startp[i] + truebase;
1306 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1307 len < 0 || len > strend - s)
1308 DIE(aTHX_ "panic: pp_match start/end pointers");
1309 sv_setpvn(*SP, s, len);
1310 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1315 if (dynpm->op_pmflags & PMf_CONTINUE) {
1317 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1318 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1320 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1321 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1323 if (rx->startp[0] != -1) {
1324 mg->mg_len = rx->endp[0];
1325 if (rx->startp[0] == rx->endp[0])
1326 mg->mg_flags |= MGf_MINMATCH;
1328 mg->mg_flags &= ~MGf_MINMATCH;
1331 had_zerolen = (rx->startp[0] != -1
1332 && rx->startp[0] == rx->endp[0]);
1333 PUTBACK; /* EVAL blocks may use stack */
1334 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1339 LEAVE_SCOPE(oldsave);
1345 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1346 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1348 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1349 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1351 if (rx->startp[0] != -1) {
1352 mg->mg_len = rx->endp[0];
1353 if (rx->startp[0] == rx->endp[0])
1354 mg->mg_flags |= MGf_MINMATCH;
1356 mg->mg_flags &= ~MGf_MINMATCH;
1359 LEAVE_SCOPE(oldsave);
1363 yup: /* Confirmed by INTUIT */
1365 RX_MATCH_TAINTED_on(rx);
1366 TAINT_IF(RX_MATCH_TAINTED(rx));
1368 if (dynpm->op_pmflags & PMf_ONCE)
1369 dynpm->op_pmdynflags |= PMdf_USED;
1370 if (RX_MATCH_COPIED(rx))
1371 Safefree(rx->subbeg);
1372 RX_MATCH_COPIED_off(rx);
1373 rx->subbeg = Nullch;
1375 /* FIXME - should rx->subbeg be const char *? */
1376 rx->subbeg = (char *) 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_OLD_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 = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1400 assert (SvPOKp(rx->saved_copy));
1405 rx->subbeg = savepvn(t, strend - t);
1406 #ifdef PERL_OLD_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(GvSVn(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 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)) {
1528 SvPV_force_nolen(sv);
1534 sv = sv_2mortal(NEWSV(57, 80));
1538 /* This should not be marked tainted if the fp is marked clean */
1539 #define MAYBE_TAINT_LINE(io, sv) \
1540 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1545 /* delay EOF state for a snarfed empty file */
1546 #define SNARF_EOF(gimme,rs,io,sv) \
1547 (gimme != G_SCALAR || SvCUR(sv) \
1548 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1552 if (!sv_gets(sv, fp, offset)
1554 || SNARF_EOF(gimme, PL_rs, io, sv)
1555 || PerlIO_error(fp)))
1557 PerlIO_clearerr(fp);
1558 if (IoFLAGS(io) & IOf_ARGV) {
1559 fp = nextargv(PL_last_in_gv);
1562 (void)do_close(PL_last_in_gv, FALSE);
1564 else if (type == OP_GLOB) {
1565 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1566 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1567 "glob failed (child exited with status %d%s)",
1568 (int)(STATUS_CURRENT >> 8),
1569 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1572 if (gimme == G_SCALAR) {
1573 if (type != OP_RCATLINE) {
1574 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1580 MAYBE_TAINT_LINE(io, sv);
1583 MAYBE_TAINT_LINE(io, sv);
1585 IoFLAGS(io) |= IOf_NOLINE;
1589 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 (t1 = SvPVX_const(sv); *t1; t1++)
1601 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1602 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1604 if (*t1 && 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 = (const U8*)SvPVX_const(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 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1671 if (SvTYPE(hv) == SVt_PVHV) {
1672 if (PL_op->op_private & OPpLVAL_INTRO) {
1675 /* does the element we're localizing already exist? */
1677 /* can we determine whether it exists? */
1679 || mg_find((SV*)hv, PERL_MAGIC_env)
1680 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1681 /* Try to preserve the existenceness of a tied hash
1682 * element by using EXISTS and DELETE if possible.
1683 * Fallback to FETCH and STORE otherwise */
1684 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1685 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1686 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1688 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1691 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1692 svp = he ? &HeVAL(he) : 0;
1698 if (!svp || *svp == &PL_sv_undef) {
1702 DIE(aTHX_ PL_no_helem_sv, keysv);
1704 lv = sv_newmortal();
1705 sv_upgrade(lv, SVt_PVLV);
1707 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1708 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1709 LvTARG(lv) = SvREFCNT_inc(hv);
1714 if (PL_op->op_private & OPpLVAL_INTRO) {
1715 if (HvNAME_get(hv) && isGV(*svp))
1716 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1720 const char * const key = SvPV_const(keysv, keylen);
1721 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1723 save_helem(hv, keysv, svp);
1726 else if (PL_op->op_private & OPpDEREF)
1727 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1729 sv = (svp ? *svp : &PL_sv_undef);
1730 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1731 * Pushing the magical RHS on to the stack is useless, since
1732 * that magic is soon destined to be misled by the local(),
1733 * and thus the later pp_sassign() will fail to mg_get() the
1734 * old value. This should also cure problems with delayed
1735 * mg_get()s. GSAR 98-07-03 */
1736 if (!lval && SvGMAGICAL(sv))
1737 sv = sv_mortalcopy(sv);
1745 register PERL_CONTEXT *cx;
1750 if (PL_op->op_flags & OPf_SPECIAL) {
1751 cx = &cxstack[cxstack_ix];
1752 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1757 gimme = OP_GIMME(PL_op, -1);
1759 if (cxstack_ix >= 0)
1760 gimme = cxstack[cxstack_ix].blk_gimme;
1766 if (gimme == G_VOID)
1768 else if (gimme == G_SCALAR) {
1772 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1775 *MARK = sv_mortalcopy(TOPs);
1778 *MARK = &PL_sv_undef;
1782 else if (gimme == G_ARRAY) {
1783 /* in case LEAVE wipes old return values */
1785 for (mark = newsp + 1; mark <= SP; mark++) {
1786 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1787 *mark = sv_mortalcopy(*mark);
1788 TAINT_NOT; /* Each item is independent */
1792 PL_curpm = newpm; /* Don't pop $1 et al till now */
1802 register PERL_CONTEXT *cx;
1808 cx = &cxstack[cxstack_ix];
1809 if (CxTYPE(cx) != CXt_LOOP)
1810 DIE(aTHX_ "panic: pp_iter");
1812 itersvp = CxITERVAR(cx);
1813 av = cx->blk_loop.iterary;
1814 if (SvTYPE(av) != SVt_PVAV) {
1815 /* iterate ($min .. $max) */
1816 if (cx->blk_loop.iterlval) {
1817 /* string increment */
1818 register SV* cur = cx->blk_loop.iterlval;
1820 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1821 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1822 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1823 /* safe to reuse old SV */
1824 sv_setsv(*itersvp, cur);
1828 /* we need a fresh SV every time so that loop body sees a
1829 * completely new SV for closures/references to work as
1832 *itersvp = newSVsv(cur);
1833 SvREFCNT_dec(oldsv);
1835 if (strEQ(SvPVX_const(cur), max))
1836 sv_setiv(cur, 0); /* terminate next time */
1843 /* integer increment */
1844 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1847 /* don't risk potential race */
1848 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1849 /* safe to reuse old SV */
1850 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1854 /* we need a fresh SV every time so that loop body sees a
1855 * completely new SV for closures/references to work as they
1858 *itersvp = newSViv(cx->blk_loop.iterix++);
1859 SvREFCNT_dec(oldsv);
1865 if (PL_op->op_private & OPpITER_REVERSED) {
1866 /* In reverse, use itermax as the min :-) */
1867 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1870 if (SvMAGICAL(av) || AvREIFY(av)) {
1871 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1878 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1882 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1886 if (SvMAGICAL(av) || AvREIFY(av)) {
1887 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1894 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1898 if (sv && SvREFCNT(sv) == 0) {
1900 Perl_croak(aTHX_ "Use of freed value in iteration");
1907 if (av != PL_curstack && sv == &PL_sv_undef) {
1908 SV *lv = cx->blk_loop.iterlval;
1909 if (lv && SvREFCNT(lv) > 1) {
1914 SvREFCNT_dec(LvTARG(lv));
1916 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1917 sv_upgrade(lv, SVt_PVLV);
1919 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1921 LvTARG(lv) = SvREFCNT_inc(av);
1922 LvTARGOFF(lv) = cx->blk_loop.iterix;
1923 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1928 *itersvp = SvREFCNT_inc(sv);
1929 SvREFCNT_dec(oldsv);
1937 register PMOP *pm = cPMOP;
1953 register REGEXP *rx = PM_GETRE(pm);
1955 int force_on_match = 0;
1956 I32 oldsave = PL_savestack_ix;
1958 bool doutf8 = FALSE;
1959 #ifdef PERL_OLD_COPY_ON_WRITE
1964 /* known replacement string? */
1965 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1966 if (PL_op->op_flags & OPf_STACKED)
1968 else if (PL_op->op_private & OPpTARGET_MY)
1975 #ifdef PERL_OLD_COPY_ON_WRITE
1976 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1977 because they make integers such as 256 "false". */
1978 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1981 sv_force_normal_flags(TARG,0);
1984 #ifdef PERL_OLD_COPY_ON_WRITE
1988 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1989 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1990 DIE(aTHX_ PL_no_modify);
1993 s = SvPV_mutable(TARG, len);
1994 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1996 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1997 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2002 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2006 DIE(aTHX_ "panic: pp_subst");
2009 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2010 maxiters = 2 * slen + 10; /* We can match twice at each
2011 position, once with zero-length,
2012 second time with non-zero. */
2014 if (!rx->prelen && PL_curpm) {
2018 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2019 ? REXEC_COPY_STR : 0;
2021 r_flags |= REXEC_SCREAM;
2024 if (rx->reganch & RE_USE_INTUIT) {
2026 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2030 /* How to do it in subst? */
2031 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2033 && ((rx->reganch & ROPT_NOSCAN)
2034 || !((rx->reganch & RE_INTUIT_TAIL)
2035 && (r_flags & REXEC_SCREAM))))
2040 /* only replace once? */
2041 once = !(rpm->op_pmflags & PMf_GLOBAL);
2043 /* known replacement string? */
2045 /* replacement needing upgrading? */
2046 if (DO_UTF8(TARG) && !doutf8) {
2047 nsv = sv_newmortal();
2050 sv_recode_to_utf8(nsv, PL_encoding);
2052 sv_utf8_upgrade(nsv);
2053 c = SvPV_const(nsv, clen);
2057 c = SvPV_const(dstr, clen);
2058 doutf8 = DO_UTF8(dstr);
2066 /* can do inplace substitution? */
2068 #ifdef PERL_OLD_COPY_ON_WRITE
2071 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2072 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2073 && (!doutf8 || SvUTF8(TARG))) {
2074 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2075 r_flags | REXEC_CHECKED))
2079 LEAVE_SCOPE(oldsave);
2082 #ifdef PERL_OLD_COPY_ON_WRITE
2083 if (SvIsCOW(TARG)) {
2084 assert (!force_on_match);
2088 if (force_on_match) {
2090 s = SvPV_force(TARG, len);
2095 SvSCREAM_off(TARG); /* disable possible screamer */
2097 rxtainted |= RX_MATCH_TAINTED(rx);
2098 m = orig + rx->startp[0];
2099 d = orig + rx->endp[0];
2101 if (m - s > strend - d) { /* faster to shorten from end */
2103 Copy(c, m, clen, char);
2108 Move(d, m, i, char);
2112 SvCUR_set(TARG, m - s);
2114 else if ((i = m - s)) { /* faster from front */
2122 Copy(c, m, clen, char);
2127 Copy(c, d, clen, char);
2132 TAINT_IF(rxtainted & 1);
2138 if (iters++ > maxiters)
2139 DIE(aTHX_ "Substitution loop");
2140 rxtainted |= RX_MATCH_TAINTED(rx);
2141 m = rx->startp[0] + orig;
2144 Move(s, d, i, char);
2148 Copy(c, d, clen, char);
2151 s = rx->endp[0] + orig;
2152 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2154 /* don't match same null twice */
2155 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2158 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2159 Move(s, d, i+1, char); /* include the NUL */
2161 TAINT_IF(rxtainted & 1);
2163 PUSHs(sv_2mortal(newSViv((I32)iters)));
2165 (void)SvPOK_only_UTF8(TARG);
2166 TAINT_IF(rxtainted);
2167 if (SvSMAGICAL(TARG)) {
2175 LEAVE_SCOPE(oldsave);
2179 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2180 r_flags | REXEC_CHECKED))
2182 if (force_on_match) {
2184 s = SvPV_force(TARG, len);
2187 #ifdef PERL_OLD_COPY_ON_WRITE
2190 rxtainted |= RX_MATCH_TAINTED(rx);
2191 dstr = newSVpvn(m, s-m);
2196 register PERL_CONTEXT *cx;
2198 (void)ReREFCNT_inc(rx);
2200 RETURNOP(cPMOP->op_pmreplroot);
2202 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2204 if (iters++ > maxiters)
2205 DIE(aTHX_ "Substitution loop");
2206 rxtainted |= RX_MATCH_TAINTED(rx);
2207 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2212 strend = s + (strend - m);
2214 m = rx->startp[0] + orig;
2215 if (doutf8 && !SvUTF8(dstr))
2216 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2218 sv_catpvn(dstr, s, m-s);
2219 s = rx->endp[0] + orig;
2221 sv_catpvn(dstr, c, clen);
2224 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2225 TARG, NULL, r_flags));
2226 if (doutf8 && !DO_UTF8(TARG))
2227 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2229 sv_catpvn(dstr, s, strend - s);
2231 #ifdef PERL_OLD_COPY_ON_WRITE
2232 /* The match may make the string COW. If so, brilliant, because that's
2233 just saved us one malloc, copy and free - the regexp has donated
2234 the old buffer, and we malloc an entirely new one, rather than the
2235 regexp malloc()ing a buffer and copying our original, only for
2236 us to throw it away here during the substitution. */
2237 if (SvIsCOW(TARG)) {
2238 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2244 SvPV_set(TARG, SvPVX(dstr));
2245 SvCUR_set(TARG, SvCUR(dstr));
2246 SvLEN_set(TARG, SvLEN(dstr));
2247 doutf8 |= DO_UTF8(dstr);
2248 SvPV_set(dstr, (char*)0);
2251 TAINT_IF(rxtainted & 1);
2253 PUSHs(sv_2mortal(newSViv((I32)iters)));
2255 (void)SvPOK_only(TARG);
2258 TAINT_IF(rxtainted);
2261 LEAVE_SCOPE(oldsave);
2270 LEAVE_SCOPE(oldsave);
2279 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2280 ++*PL_markstack_ptr;
2281 LEAVE; /* exit inner scope */
2284 if (PL_stack_base + *PL_markstack_ptr > SP) {
2286 I32 gimme = GIMME_V;
2288 LEAVE; /* exit outer scope */
2289 (void)POPMARK; /* pop src */
2290 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2291 (void)POPMARK; /* pop dst */
2292 SP = PL_stack_base + POPMARK; /* pop original mark */
2293 if (gimme == G_SCALAR) {
2294 if (PL_op->op_private & OPpGREP_LEX) {
2295 SV* sv = sv_newmortal();
2296 sv_setiv(sv, items);
2304 else if (gimme == G_ARRAY)
2311 ENTER; /* enter inner scope */
2314 src = PL_stack_base[*PL_markstack_ptr];
2316 if (PL_op->op_private & OPpGREP_LEX)
2317 PAD_SVl(PL_op->op_targ) = src;
2321 RETURNOP(cLOGOP->op_other);
2332 register PERL_CONTEXT *cx;
2336 cxstack_ix++; /* temporarily protect top context */
2339 if (gimme == G_SCALAR) {
2342 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2344 *MARK = SvREFCNT_inc(TOPs);
2349 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2351 *MARK = sv_mortalcopy(sv);
2356 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2360 *MARK = &PL_sv_undef;
2364 else if (gimme == G_ARRAY) {
2365 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2366 if (!SvTEMP(*MARK)) {
2367 *MARK = sv_mortalcopy(*MARK);
2368 TAINT_NOT; /* Each item is independent */
2376 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2377 PL_curpm = newpm; /* ... and pop $1 et al */
2380 return cx->blk_sub.retop;
2383 /* This duplicates the above code because the above code must not
2384 * get any slower by more conditions */
2392 register PERL_CONTEXT *cx;
2396 cxstack_ix++; /* temporarily protect top context */
2400 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2401 /* We are an argument to a function or grep().
2402 * This kind of lvalueness was legal before lvalue
2403 * subroutines too, so be backward compatible:
2404 * cannot report errors. */
2406 /* Scalar context *is* possible, on the LHS of -> only,
2407 * as in f()->meth(). But this is not an lvalue. */
2408 if (gimme == G_SCALAR)
2410 if (gimme == G_ARRAY) {
2411 if (!CvLVALUE(cx->blk_sub.cv))
2412 goto temporise_array;
2413 EXTEND_MORTAL(SP - newsp);
2414 for (mark = newsp + 1; mark <= SP; mark++) {
2417 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2418 *mark = sv_mortalcopy(*mark);
2420 /* Can be a localized value subject to deletion. */
2421 PL_tmps_stack[++PL_tmps_ix] = *mark;
2422 (void)SvREFCNT_inc(*mark);
2427 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2428 /* Here we go for robustness, not for speed, so we change all
2429 * the refcounts so the caller gets a live guy. Cannot set
2430 * TEMP, so sv_2mortal is out of question. */
2431 if (!CvLVALUE(cx->blk_sub.cv)) {
2437 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2439 if (gimme == G_SCALAR) {
2443 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2449 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2450 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2451 : "a readonly value" : "a temporary");
2453 else { /* Can be a localized value
2454 * subject to deletion. */
2455 PL_tmps_stack[++PL_tmps_ix] = *mark;
2456 (void)SvREFCNT_inc(*mark);
2459 else { /* Should not happen? */
2465 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2466 (MARK > SP ? "Empty array" : "Array"));
2470 else if (gimme == G_ARRAY) {
2471 EXTEND_MORTAL(SP - newsp);
2472 for (mark = newsp + 1; mark <= SP; mark++) {
2473 if (*mark != &PL_sv_undef
2474 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2475 /* Might be flattened array after $#array = */
2482 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2483 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2486 /* Can be a localized value subject to deletion. */
2487 PL_tmps_stack[++PL_tmps_ix] = *mark;
2488 (void)SvREFCNT_inc(*mark);
2494 if (gimme == G_SCALAR) {
2498 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2500 *MARK = SvREFCNT_inc(TOPs);
2505 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2507 *MARK = sv_mortalcopy(sv);
2512 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2516 *MARK = &PL_sv_undef;
2520 else if (gimme == G_ARRAY) {
2522 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2523 if (!SvTEMP(*MARK)) {
2524 *MARK = sv_mortalcopy(*MARK);
2525 TAINT_NOT; /* Each item is independent */
2534 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2535 PL_curpm = newpm; /* ... and pop $1 et al */
2538 return cx->blk_sub.retop;
2543 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2545 SV *dbsv = GvSVn(PL_DBsub);
2548 if (!PERLDB_SUB_NN) {
2551 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2552 || strEQ(GvNAME(gv), "END")
2553 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2554 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2555 && (gv = (GV*)*svp) ))) {
2556 /* Use GV from the stack as a fallback. */
2557 /* GV is potentially non-unique, or contain different CV. */
2558 SV *tmp = newRV((SV*)cv);
2559 sv_setsv(dbsv, tmp);
2563 gv_efullname3(dbsv, gv, Nullch);
2567 const int type = SvTYPE(dbsv);
2568 if (type < SVt_PVIV && type != SVt_IV)
2569 sv_upgrade(dbsv, SVt_PVIV);
2570 (void)SvIOK_on(dbsv);
2571 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2575 PL_curcopdb = PL_curcop;
2576 cv = GvCV(PL_DBsub);
2586 register PERL_CONTEXT *cx;
2588 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2591 DIE(aTHX_ "Not a CODE reference");
2592 switch (SvTYPE(sv)) {
2593 /* This is overwhelming the most common case: */
2595 if (!(cv = GvCVu((GV*)sv)))
2596 cv = sv_2cv(sv, &stash, &gv, FALSE);
2606 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2608 SP = PL_stack_base + POPMARK;
2611 if (SvGMAGICAL(sv)) {
2615 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2618 sym = SvPV_nolen_const(sv);
2621 DIE(aTHX_ PL_no_usym, "a subroutine");
2622 if (PL_op->op_private & HINT_STRICT_REFS)
2623 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2624 cv = get_cv(sym, TRUE);
2629 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2630 tryAMAGICunDEREF(to_cv);
2633 if (SvTYPE(cv) == SVt_PVCV)
2638 DIE(aTHX_ "Not a CODE reference");
2639 /* This is the second most common case: */
2649 if (!CvROOT(cv) && !CvXSUB(cv)) {
2654 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2655 if (CvASSERTION(cv) && PL_DBassertion)
2656 sv_setiv(PL_DBassertion, 1);
2658 cv = get_db_sub(&sv, cv);
2659 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2660 DIE(aTHX_ "No DB::sub routine defined");
2663 if (!(CvXSUB(cv))) {
2664 /* This path taken at least 75% of the time */
2666 register I32 items = SP - MARK;
2667 AV* padlist = CvPADLIST(cv);
2668 PUSHBLOCK(cx, CXt_SUB, MARK);
2670 cx->blk_sub.retop = PL_op->op_next;
2672 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2673 * that eval'' ops within this sub know the correct lexical space.
2674 * Owing the speed considerations, we choose instead to search for
2675 * the cv using find_runcv() when calling doeval().
2677 if (CvDEPTH(cv) >= 2) {
2678 PERL_STACK_OVERFLOW_CHECK();
2679 pad_push(padlist, CvDEPTH(cv));
2682 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2687 DEBUG_S(PerlIO_printf(Perl_debug_log,
2688 "%p entersub preparing @_\n", thr));
2690 av = (AV*)PAD_SVl(0);
2692 /* @_ is normally not REAL--this should only ever
2693 * happen when DB::sub() calls things that modify @_ */
2698 cx->blk_sub.savearray = GvAV(PL_defgv);
2699 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2700 CX_CURPAD_SAVE(cx->blk_sub);
2701 cx->blk_sub.argarray = av;
2704 if (items > AvMAX(av) + 1) {
2705 SV **ary = AvALLOC(av);
2706 if (AvARRAY(av) != ary) {
2707 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2708 SvPV_set(av, (char*)ary);
2710 if (items > AvMAX(av) + 1) {
2711 AvMAX(av) = items - 1;
2712 Renew(ary,items,SV*);
2714 SvPV_set(av, (char*)ary);
2717 Copy(MARK,AvARRAY(av),items,SV*);
2718 AvFILLp(av) = items - 1;
2726 /* warning must come *after* we fully set up the context
2727 * stuff so that __WARN__ handlers can safely dounwind()
2730 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2731 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2732 sub_crush_depth(cv);
2734 DEBUG_S(PerlIO_printf(Perl_debug_log,
2735 "%p entersub returning %p\n", thr, CvSTART(cv)));
2737 RETURNOP(CvSTART(cv));
2740 #ifdef PERL_XSUB_OLDSTYLE
2741 if (CvOLDSTYLE(cv)) {
2742 I32 (*fp3)(int,int,int);
2744 register I32 items = SP - MARK;
2745 /* We dont worry to copy from @_. */
2750 PL_stack_sp = mark + 1;
2751 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2752 items = (*fp3)(CvXSUBANY(cv).any_i32,
2753 MARK - PL_stack_base + 1,
2755 PL_stack_sp = PL_stack_base + items;
2758 #endif /* PERL_XSUB_OLDSTYLE */
2760 I32 markix = TOPMARK;
2765 /* Need to copy @_ to stack. Alternative may be to
2766 * switch stack to @_, and copy return values
2767 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2768 AV * const av = GvAV(PL_defgv);
2769 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2772 /* Mark is at the end of the stack. */
2774 Copy(AvARRAY(av), SP + 1, items, SV*);
2779 /* We assume first XSUB in &DB::sub is the called one. */
2781 SAVEVPTR(PL_curcop);
2782 PL_curcop = PL_curcopdb;
2785 /* Do we need to open block here? XXXX */
2786 (void)(*CvXSUB(cv))(aTHX_ cv);
2788 /* Enforce some sanity in scalar context. */
2789 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2790 if (markix > PL_stack_sp - PL_stack_base)
2791 *(PL_stack_base + markix) = &PL_sv_undef;
2793 *(PL_stack_base + markix) = *PL_stack_sp;
2794 PL_stack_sp = PL_stack_base + markix;
2802 assert (0); /* Cannot get here. */
2803 /* This is deliberately moved here as spaghetti code to keep it out of the
2810 /* anonymous or undef'd function leaves us no recourse */
2811 if (CvANON(cv) || !(gv = CvGV(cv)))
2812 DIE(aTHX_ "Undefined subroutine called");
2814 /* autoloaded stub? */
2815 if (cv != GvCV(gv)) {
2818 /* should call AUTOLOAD now? */
2821 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2828 sub_name = sv_newmortal();
2829 gv_efullname3(sub_name, gv, Nullch);
2830 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2834 DIE(aTHX_ "Not a CODE reference");
2840 Perl_sub_crush_depth(pTHX_ CV *cv)
2843 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2845 SV* tmpstr = sv_newmortal();
2846 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2847 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2856 SV* const elemsv = POPs;
2857 IV elem = SvIV(elemsv);
2859 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2860 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2863 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2864 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2866 elem -= PL_curcop->cop_arybase;
2867 if (SvTYPE(av) != SVt_PVAV)
2869 svp = av_fetch(av, elem, lval && !defer);
2871 #ifdef PERL_MALLOC_WRAP
2872 if (SvUOK(elemsv)) {
2873 const UV uv = SvUV(elemsv);
2874 elem = uv > IV_MAX ? IV_MAX : uv;
2876 else if (SvNOK(elemsv))
2877 elem = (IV)SvNV(elemsv);
2879 static const char oom_array_extend[] =
2880 "Out of memory during array extend"; /* Duplicated in av.c */
2881 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2884 if (!svp || *svp == &PL_sv_undef) {
2887 DIE(aTHX_ PL_no_aelem, elem);
2888 lv = sv_newmortal();
2889 sv_upgrade(lv, SVt_PVLV);
2891 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2892 LvTARG(lv) = SvREFCNT_inc(av);
2893 LvTARGOFF(lv) = elem;
2898 if (PL_op->op_private & OPpLVAL_INTRO)
2899 save_aelem(av, elem, svp);
2900 else if (PL_op->op_private & OPpDEREF)
2901 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2903 sv = (svp ? *svp : &PL_sv_undef);
2904 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2905 sv = sv_mortalcopy(sv);
2911 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2917 Perl_croak(aTHX_ PL_no_modify);
2918 if (SvTYPE(sv) < SVt_RV)
2919 sv_upgrade(sv, SVt_RV);
2920 else if (SvTYPE(sv) >= SVt_PV) {
2927 SvRV_set(sv, NEWSV(355,0));
2930 SvRV_set(sv, (SV*)newAV());
2933 SvRV_set(sv, (SV*)newHV());
2948 if (SvTYPE(rsv) == SVt_PVCV) {
2954 SETs(method_common(sv, Null(U32*)));
2962 U32 hash = SvSHARED_HASH(sv);
2964 XPUSHs(method_common(sv, &hash));
2969 S_method_common(pTHX_ SV* meth, U32* hashp)
2976 const char* packname = 0;
2977 SV *packsv = Nullsv;
2979 const char *name = SvPV_const(meth, namelen);
2981 sv = *(PL_stack_base + TOPMARK + 1);
2984 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2993 /* this isn't a reference */
2996 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2997 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2999 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3006 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3007 !(ob=(SV*)GvIO(iogv)))
3009 /* this isn't the name of a filehandle either */
3011 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3012 ? !isIDFIRST_utf8((U8*)packname)
3013 : !isIDFIRST(*packname)
3016 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3017 SvOK(sv) ? "without a package or object reference"
3018 : "on an undefined value");
3020 /* assume it's a package name */
3021 stash = gv_stashpvn(packname, packlen, FALSE);
3025 SV* ref = newSViv(PTR2IV(stash));
3026 hv_store(PL_stashcache, packname, packlen, ref, 0);
3030 /* it _is_ a filehandle name -- replace with a reference */
3031 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3034 /* if we got here, ob should be a reference or a glob */
3035 if (!ob || !(SvOBJECT(ob)
3036 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3039 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3043 stash = SvSTASH(ob);
3046 /* NOTE: stash may be null, hope hv_fetch_ent and
3047 gv_fetchmethod can cope (it seems they can) */
3049 /* shortcut for simple names */
3051 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3053 gv = (GV*)HeVAL(he);
3054 if (isGV(gv) && GvCV(gv) &&
3055 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3056 return (SV*)GvCV(gv);
3060 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3063 /* This code tries to figure out just what went wrong with
3064 gv_fetchmethod. It therefore needs to duplicate a lot of
3065 the internals of that function. We can't move it inside
3066 Perl_gv_fetchmethod_autoload(), however, since that would
3067 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3070 const char* leaf = name;
3071 const char* sep = Nullch;
3074 for (p = name; *p; p++) {
3076 sep = p, leaf = p + 1;
3077 else if (*p == ':' && *(p + 1) == ':')
3078 sep = p, leaf = p + 2;
3080 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3081 /* the method name is unqualified or starts with SUPER:: */
3082 bool need_strlen = 1;
3084 packname = CopSTASHPV(PL_curcop);
3087 HEK *packhek = HvNAME_HEK(stash);
3089 packname = HEK_KEY(packhek);
3090 packlen = HEK_LEN(packhek);
3100 "Can't use anonymous symbol table for method lookup");
3102 else if (need_strlen)
3103 packlen = strlen(packname);
3107 /* the method name is qualified */
3109 packlen = sep - name;
3112 /* we're relying on gv_fetchmethod not autovivifying the stash */
3113 if (gv_stashpvn(packname, packlen, FALSE)) {
3115 "Can't locate object method \"%s\" via package \"%.*s\"",
3116 leaf, (int)packlen, packname);
3120 "Can't locate object method \"%s\" via package \"%.*s\""
3121 " (perhaps you forgot to load \"%.*s\"?)",
3122 leaf, (int)packlen, packname, (int)packlen, packname);
3125 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3130 * c-indentation-style: bsd
3132 * indent-tabs-mode: t
3135 * ex: set ts=8 sts=4 sw=4 noet: