3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
19 /* This file contains 'hot' pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * By 'hot', we mean common ops whose execution speed is critical.
26 * By gathering them together into a single file, we encourage
27 * CPU cache hits on hot code. Also it could be taken as a warning not to
28 * change any code in this file unless you're sure it won't affect
33 #define PERL_IN_PP_HOT_C
47 PL_curcop = (COP*)PL_op;
48 TAINT_NOT; /* Each statement is presumed innocent */
49 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
58 if (PL_op->op_private & OPpLVAL_INTRO)
59 PUSHs(save_scalar(cGVOP_gv));
61 PUSHs(GvSV(cGVOP_gv));
72 PL_curcop = (COP*)PL_op;
78 PUSHMARK(PL_stack_sp);
93 XPUSHs((SV*)cGVOP_gv);
104 RETURNOP(cLOGOP->op_other);
112 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
114 temp = left; left = right; right = temp;
116 if (PL_tainting && PL_tainted && !SvTAINTED(left))
118 SvSetMagicSV(right, left);
127 RETURNOP(cLOGOP->op_other);
129 RETURNOP(cLOGOP->op_next);
135 TAINT_NOT; /* Each statement is presumed innocent */
136 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
138 oldsave = PL_scopestack[PL_scopestack_ix - 1];
139 LEAVE_SCOPE(oldsave);
145 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
150 const char *rpv = SvPV(right, rlen); /* mg_get(right) happens here */
151 const bool rbyte = !DO_UTF8(right);
152 bool rcopied = FALSE;
154 if (TARG == right && right != left) {
155 right = sv_2mortal(newSVpvn(rpv, rlen));
156 rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
162 const char* const lpv = SvPV(left, llen); /* mg_get(left) may happen here */
163 lbyte = !DO_UTF8(left);
164 sv_setpvn(TARG, lpv, llen);
170 else { /* TARG == left */
172 if (SvGMAGICAL(left))
173 mg_get(left); /* or mg_get(left) may happen here */
175 sv_setpvn(left, "", 0);
176 (void)SvPV_nomg(left, llen); /* Needed to set UTF8 flag */
177 lbyte = !DO_UTF8(left);
182 if (lbyte != rbyte) {
184 sv_utf8_upgrade_nomg(TARG);
187 right = sv_2mortal(newSVpvn(rpv, rlen));
188 sv_utf8_upgrade_nomg(right);
189 rpv = SvPV(right, rlen);
192 sv_catpvn_nomg(TARG, rpv, rlen);
203 if (PL_op->op_flags & OPf_MOD) {
204 if (PL_op->op_private & OPpLVAL_INTRO)
205 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
206 if (PL_op->op_private & OPpDEREF) {
208 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
217 tryAMAGICunTARGET(iter, 0);
218 PL_last_in_gv = (GV*)(*PL_stack_sp--);
219 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
220 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
221 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
224 XPUSHs((SV*)PL_last_in_gv);
227 PL_last_in_gv = (GV*)(*PL_stack_sp--);
230 return do_readline();
235 dSP; tryAMAGICbinSET(eq,0);
236 #ifndef NV_PRESERVES_UV
237 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
239 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
243 #ifdef PERL_PRESERVE_IVUV
246 /* Unless the left argument is integer in range we are going
247 to have to use NV maths. Hence only attempt to coerce the
248 right argument if we know the left is integer. */
251 bool auvok = SvUOK(TOPm1s);
252 bool buvok = SvUOK(TOPs);
254 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
255 /* Casting IV to UV before comparison isn't going to matter
256 on 2s complement. On 1s complement or sign&magnitude
257 (if we have any of them) it could to make negative zero
258 differ from normal zero. As I understand it. (Need to
259 check - is negative zero implementation defined behaviour
261 UV buv = SvUVX(POPs);
262 UV auv = SvUVX(TOPs);
264 SETs(boolSV(auv == buv));
267 { /* ## Mixed IV,UV ## */
271 /* == is commutative so doesn't matter which is left or right */
273 /* top of stack (b) is the iv */
282 /* As uv is a UV, it's >0, so it cannot be == */
286 /* we know iv is >= 0 */
287 SETs(boolSV((UV)iv == SvUVX(uvp)));
295 SETs(boolSV(TOPn == value));
303 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
304 DIE(aTHX_ PL_no_modify);
305 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
306 && SvIVX(TOPs) != IV_MAX)
308 SvIV_set(TOPs, SvIVX(TOPs) + 1);
309 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
311 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
324 RETURNOP(cLOGOP->op_other);
330 /* Most of this is lifted straight from pp_defined */
332 register SV* const sv = TOPs;
334 if (!sv || !SvANY(sv)) {
336 RETURNOP(cLOGOP->op_other);
339 switch (SvTYPE(sv)) {
341 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
345 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
349 if (CvROOT(sv) || CvXSUB(sv))
360 RETURNOP(cLOGOP->op_other);
365 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
366 useleft = USE_LEFT(TOPm1s);
367 #ifdef PERL_PRESERVE_IVUV
368 /* We must see if we can perform the addition with integers if possible,
369 as the integer code detects overflow while the NV code doesn't.
370 If either argument hasn't had a numeric conversion yet attempt to get
371 the IV. It's important to do this now, rather than just assuming that
372 it's not IOK as a PV of "9223372036854775806" may not take well to NV
373 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
374 integer in case the second argument is IV=9223372036854775806
375 We can (now) rely on sv_2iv to do the right thing, only setting the
376 public IOK flag if the value in the NV (or PV) slot is truly integer.
378 A side effect is that this also aggressively prefers integer maths over
379 fp maths for integer values.
381 How to detect overflow?
383 C 99 section 6.2.6.1 says
385 The range of nonnegative values of a signed integer type is a subrange
386 of the corresponding unsigned integer type, and the representation of
387 the same value in each type is the same. A computation involving
388 unsigned operands can never overflow, because a result that cannot be
389 represented by the resulting unsigned integer type is reduced modulo
390 the number that is one greater than the largest value that can be
391 represented by the resulting type.
395 which I read as "unsigned ints wrap."
397 signed integer overflow seems to be classed as "exception condition"
399 If an exceptional condition occurs during the evaluation of an
400 expression (that is, if the result is not mathematically defined or not
401 in the range of representable values for its type), the behavior is
404 (6.5, the 5th paragraph)
406 I had assumed that on 2s complement machines signed arithmetic would
407 wrap, hence coded pp_add and pp_subtract on the assumption that
408 everything perl builds on would be happy. After much wailing and
409 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
410 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
411 unsigned code below is actually shorter than the old code. :-)
416 /* Unless the left argument is integer in range we are going to have to
417 use NV maths. Hence only attempt to coerce the right argument if
418 we know the left is integer. */
426 /* left operand is undef, treat as zero. + 0 is identity,
427 Could SETi or SETu right now, but space optimise by not adding
428 lots of code to speed up what is probably a rarish case. */
430 /* Left operand is defined, so is it IV? */
433 if ((auvok = SvUOK(TOPm1s)))
436 register const IV aiv = SvIVX(TOPm1s);
439 auvok = 1; /* Now acting as a sign flag. */
440 } else { /* 2s complement assumption for IV_MIN */
448 bool result_good = 0;
451 bool buvok = SvUOK(TOPs);
456 register const IV biv = SvIVX(TOPs);
463 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
464 else "IV" now, independent of how it came in.
465 if a, b represents positive, A, B negative, a maps to -A etc
470 all UV maths. negate result if A negative.
471 add if signs same, subtract if signs differ. */
477 /* Must get smaller */
483 /* result really should be -(auv-buv). as its negation
484 of true value, need to swap our result flag */
501 if (result <= (UV)IV_MIN)
504 /* result valid, but out of range for IV. */
509 } /* Overflow, drop through to NVs. */
516 /* left operand is undef, treat as zero. + 0.0 is identity. */
520 SETn( value + TOPn );
528 AV *av = PL_op->op_flags & OPf_SPECIAL ?
529 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
530 const U32 lval = PL_op->op_flags & OPf_MOD;
531 SV** svp = av_fetch(av, PL_op->op_private, lval);
532 SV *sv = (svp ? *svp : &PL_sv_undef);
534 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
535 sv = sv_mortalcopy(sv);
544 do_join(TARG, *MARK, MARK, SP);
555 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
556 * will be enough to hold an OP*.
558 SV* sv = sv_newmortal();
559 sv_upgrade(sv, SVt_PVLV);
561 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
569 /* Oversized hot code. */
573 dVAR; dSP; dMARK; dORIGMARK;
579 if (PL_op->op_flags & OPf_STACKED)
584 if (gv && (io = GvIO(gv))
585 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
588 if (MARK == ORIGMARK) {
589 /* If using default handle then we need to make space to
590 * pass object as 1st arg, so move other args up ...
594 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
598 *MARK = SvTIED_obj((SV*)io, mg);
601 call_method("PRINT", G_SCALAR);
609 if (!(io = GvIO(gv))) {
610 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
611 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
613 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
614 report_evil_fh(gv, io, PL_op->op_type);
615 SETERRNO(EBADF,RMS_IFI);
618 else if (!(fp = IoOFP(io))) {
619 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
621 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
622 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
623 report_evil_fh(gv, io, PL_op->op_type);
625 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
630 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
632 if (!do_print(*MARK, fp))
636 if (!do_print(PL_ofs_sv, fp)) { /* $, */
645 if (!do_print(*MARK, fp))
653 if (PL_ors_sv && SvOK(PL_ors_sv))
654 if (!do_print(PL_ors_sv, fp)) /* $\ */
657 if (IoFLAGS(io) & IOf_FLUSH)
658 if (PerlIO_flush(fp) == EOF)
679 tryAMAGICunDEREF(to_av);
682 if (SvTYPE(av) != SVt_PVAV)
683 DIE(aTHX_ "Not an ARRAY reference");
684 if (PL_op->op_flags & OPf_REF) {
689 if (GIMME == G_SCALAR)
690 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
694 else if (PL_op->op_flags & OPf_MOD
695 && PL_op->op_private & OPpLVAL_INTRO)
696 Perl_croak(aTHX_ PL_no_localize_ref);
699 if (SvTYPE(sv) == SVt_PVAV) {
701 if (PL_op->op_flags & OPf_REF) {
706 if (GIMME == G_SCALAR)
707 Perl_croak(aTHX_ "Can't return array to lvalue"
716 if (SvTYPE(sv) != SVt_PVGV) {
717 if (SvGMAGICAL(sv)) {
723 if (PL_op->op_flags & OPf_REF ||
724 PL_op->op_private & HINT_STRICT_REFS)
725 DIE(aTHX_ PL_no_usym, "an ARRAY");
726 if (ckWARN(WARN_UNINITIALIZED))
728 if (GIMME == G_ARRAY) {
734 if ((PL_op->op_flags & OPf_SPECIAL) &&
735 !(PL_op->op_flags & OPf_MOD))
737 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
739 && (!is_gv_magical_sv(sv,0)
740 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
746 if (PL_op->op_private & HINT_STRICT_REFS)
747 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
748 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
755 if (PL_op->op_private & OPpLVAL_INTRO)
757 if (PL_op->op_flags & OPf_REF) {
762 if (GIMME == G_SCALAR)
763 Perl_croak(aTHX_ "Can't return array to lvalue"
771 if (GIMME == G_ARRAY) {
772 const I32 maxarg = AvFILL(av) + 1;
773 (void)POPs; /* XXXX May be optimized away? */
775 if (SvRMAGICAL(av)) {
777 for (i=0; i < (U32)maxarg; i++) {
778 SV **svp = av_fetch(av, i, FALSE);
779 /* See note in pp_helem, and bug id #27839 */
781 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
786 Copy(AvARRAY(av), SP+1, maxarg, SV*);
790 else if (GIMME_V == G_SCALAR) {
792 const I32 maxarg = AvFILL(av) + 1;
802 const I32 gimme = GIMME_V;
803 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
807 tryAMAGICunDEREF(to_hv);
810 if (SvTYPE(hv) != SVt_PVHV)
811 DIE(aTHX_ "Not a HASH reference");
812 if (PL_op->op_flags & OPf_REF) {
817 if (gimme != G_ARRAY)
818 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
822 else if (PL_op->op_flags & OPf_MOD
823 && PL_op->op_private & OPpLVAL_INTRO)
824 Perl_croak(aTHX_ PL_no_localize_ref);
827 if (SvTYPE(sv) == SVt_PVHV) {
829 if (PL_op->op_flags & OPf_REF) {
834 if (gimme != G_ARRAY)
835 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
843 if (SvTYPE(sv) != SVt_PVGV) {
844 if (SvGMAGICAL(sv)) {
850 if (PL_op->op_flags & OPf_REF ||
851 PL_op->op_private & HINT_STRICT_REFS)
852 DIE(aTHX_ PL_no_usym, "a HASH");
853 if (ckWARN(WARN_UNINITIALIZED))
855 if (gimme == G_ARRAY) {
861 if ((PL_op->op_flags & OPf_SPECIAL) &&
862 !(PL_op->op_flags & OPf_MOD))
864 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
866 && (!is_gv_magical_sv(sv,0)
867 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
873 if (PL_op->op_private & HINT_STRICT_REFS)
874 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
875 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
882 if (PL_op->op_private & OPpLVAL_INTRO)
884 if (PL_op->op_flags & OPf_REF) {
889 if (gimme != G_ARRAY)
890 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
897 if (gimme == G_ARRAY) { /* array wanted */
898 *PL_stack_sp = (SV*)hv;
901 else if (gimme == G_SCALAR) {
903 TARG = Perl_hv_scalar(aTHX_ hv);
910 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
916 if (ckWARN(WARN_MISC)) {
918 if (relem == firstrelem &&
920 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
921 SvTYPE(SvRV(*relem)) == SVt_PVHV))
923 err = "Reference found where even-sized list expected";
926 err = "Odd number of elements in hash assignment";
927 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
930 tmpstr = NEWSV(29,0);
931 didstore = hv_store_ent(hash,*relem,tmpstr,0);
932 if (SvMAGICAL(hash)) {
933 if (SvSMAGICAL(tmpstr))
945 SV **lastlelem = PL_stack_sp;
946 SV **lastrelem = PL_stack_base + POPMARK;
947 SV **firstrelem = PL_stack_base + POPMARK + 1;
948 SV **firstlelem = lastrelem + 1;
961 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
964 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
967 /* If there's a common identifier on both sides we have to take
968 * special care that assigning the identifier on the left doesn't
969 * clobber a value on the right that's used later in the list.
971 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
972 EXTEND_MORTAL(lastrelem - firstrelem + 1);
973 for (relem = firstrelem; relem <= lastrelem; relem++) {
976 TAINT_NOT; /* Each item is independent */
977 *relem = sv_mortalcopy(sv);
987 while (lelem <= lastlelem) {
988 TAINT_NOT; /* Each item stands on its own, taintwise. */
990 switch (SvTYPE(sv)) {
993 magic = SvMAGICAL(ary) != 0;
995 av_extend(ary, lastrelem - relem);
997 while (relem <= lastrelem) { /* gobble up all the rest */
1000 sv = newSVsv(*relem);
1002 didstore = av_store(ary,i++,sv);
1012 case SVt_PVHV: { /* normal hash */
1016 magic = SvMAGICAL(hash) != 0;
1018 firsthashrelem = relem;
1020 while (relem < lastrelem) { /* gobble up all the rest */
1025 sv = &PL_sv_no, relem++;
1026 tmpstr = NEWSV(29,0);
1028 sv_setsv(tmpstr,*relem); /* value */
1029 *(relem++) = tmpstr;
1030 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1031 /* key overwrites an existing entry */
1033 didstore = hv_store_ent(hash,sv,tmpstr,0);
1035 if (SvSMAGICAL(tmpstr))
1042 if (relem == lastrelem) {
1043 do_oddball(hash, relem, firstrelem);
1049 if (SvIMMORTAL(sv)) {
1050 if (relem <= lastrelem)
1054 if (relem <= lastrelem) {
1055 sv_setsv(sv, *relem);
1059 sv_setsv(sv, &PL_sv_undef);
1064 if (PL_delaymagic & ~DM_DELAY) {
1065 if (PL_delaymagic & DM_UID) {
1066 #ifdef HAS_SETRESUID
1067 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1068 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1071 # ifdef HAS_SETREUID
1072 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1073 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1076 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1077 (void)setruid(PL_uid);
1078 PL_delaymagic &= ~DM_RUID;
1080 # endif /* HAS_SETRUID */
1082 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1083 (void)seteuid(PL_euid);
1084 PL_delaymagic &= ~DM_EUID;
1086 # endif /* HAS_SETEUID */
1087 if (PL_delaymagic & DM_UID) {
1088 if (PL_uid != PL_euid)
1089 DIE(aTHX_ "No setreuid available");
1090 (void)PerlProc_setuid(PL_uid);
1092 # endif /* HAS_SETREUID */
1093 #endif /* HAS_SETRESUID */
1094 PL_uid = PerlProc_getuid();
1095 PL_euid = PerlProc_geteuid();
1097 if (PL_delaymagic & DM_GID) {
1098 #ifdef HAS_SETRESGID
1099 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1100 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1103 # ifdef HAS_SETREGID
1104 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1105 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1108 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1109 (void)setrgid(PL_gid);
1110 PL_delaymagic &= ~DM_RGID;
1112 # endif /* HAS_SETRGID */
1114 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1115 (void)setegid(PL_egid);
1116 PL_delaymagic &= ~DM_EGID;
1118 # endif /* HAS_SETEGID */
1119 if (PL_delaymagic & DM_GID) {
1120 if (PL_gid != PL_egid)
1121 DIE(aTHX_ "No setregid available");
1122 (void)PerlProc_setgid(PL_gid);
1124 # endif /* HAS_SETREGID */
1125 #endif /* HAS_SETRESGID */
1126 PL_gid = PerlProc_getgid();
1127 PL_egid = PerlProc_getegid();
1129 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1133 if (gimme == G_VOID)
1134 SP = firstrelem - 1;
1135 else if (gimme == G_SCALAR) {
1138 SETi(lastrelem - firstrelem + 1 - duplicates);
1145 /* Removes from the stack the entries which ended up as
1146 * duplicated keys in the hash (fix for [perl #24380]) */
1147 Move(firsthashrelem + duplicates,
1148 firsthashrelem, duplicates, SV**);
1149 lastrelem -= duplicates;
1154 SP = firstrelem + (lastlelem - firstlelem);
1155 lelem = firstlelem + (relem - firstrelem);
1157 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1165 register PMOP *pm = cPMOP;
1166 SV *rv = sv_newmortal();
1167 SV *sv = newSVrv(rv, "Regexp");
1168 if (pm->op_pmdynflags & PMdf_TAINTED)
1170 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1177 register PMOP *pm = cPMOP;
1183 I32 r_flags = REXEC_CHECKED;
1184 char *truebase; /* Start of string */
1185 register REGEXP *rx = PM_GETRE(pm);
1187 const I32 gimme = GIMME;
1190 const I32 oldsave = PL_savestack_ix;
1191 I32 update_minmatch = 1;
1192 I32 had_zerolen = 0;
1194 if (PL_op->op_flags & OPf_STACKED)
1196 else if (PL_op->op_private & OPpTARGET_MY)
1203 PUTBACK; /* EVAL blocks need stack_sp. */
1204 s = SvPV(TARG, len);
1207 DIE(aTHX_ "panic: pp_match");
1208 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1209 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1212 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1214 /* PMdf_USED is set after a ?? matches once */
1215 if (pm->op_pmdynflags & PMdf_USED) {
1217 if (gimme == G_ARRAY)
1222 /* empty pattern special-cased to use last successful pattern if possible */
1223 if (!rx->prelen && PL_curpm) {
1228 if (rx->minlen > (I32)len)
1233 /* XXXX What part of this is needed with true \G-support? */
1234 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1236 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1237 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1238 if (mg && mg->mg_len >= 0) {
1239 if (!(rx->reganch & ROPT_GPOS_SEEN))
1240 rx->endp[0] = rx->startp[0] = mg->mg_len;
1241 else if (rx->reganch & ROPT_ANCH_GPOS) {
1242 r_flags |= REXEC_IGNOREPOS;
1243 rx->endp[0] = rx->startp[0] = mg->mg_len;
1245 minmatch = (mg->mg_flags & MGf_MINMATCH);
1246 update_minmatch = 0;
1250 if ((!global && rx->nparens)
1251 || SvTEMP(TARG) || PL_sawampersand)
1252 r_flags |= REXEC_COPY_STR;
1254 r_flags |= REXEC_SCREAM;
1257 if (global && rx->startp[0] != -1) {
1258 t = s = rx->endp[0] + truebase;
1259 if ((s + rx->minlen) > strend)
1261 if (update_minmatch++)
1262 minmatch = had_zerolen;
1264 if (rx->reganch & RE_USE_INTUIT &&
1265 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1266 PL_bostr = truebase;
1267 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1271 if ( (rx->reganch & ROPT_CHECK_ALL)
1273 && ((rx->reganch & ROPT_NOSCAN)
1274 || !((rx->reganch & RE_INTUIT_TAIL)
1275 && (r_flags & REXEC_SCREAM)))
1276 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1279 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1282 if (dynpm->op_pmflags & PMf_ONCE)
1283 dynpm->op_pmdynflags |= PMdf_USED;
1292 RX_MATCH_TAINTED_on(rx);
1293 TAINT_IF(RX_MATCH_TAINTED(rx));
1294 if (gimme == G_ARRAY) {
1295 const I32 nparens = rx->nparens;
1296 I32 i = (global && !nparens) ? 1 : 0;
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 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 rx->subbeg = truebase;
1378 rx->startp[0] = s - truebase;
1379 if (RX_MATCH_UTF8(rx)) {
1380 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1381 rx->endp[0] = t - truebase;
1384 rx->endp[0] = s - truebase + rx->minlen;
1386 rx->sublen = strend - truebase;
1389 if (PL_sawampersand) {
1391 #ifdef PERL_COPY_ON_WRITE
1392 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1394 PerlIO_printf(Perl_debug_log,
1395 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1396 (int) SvTYPE(TARG), truebase, t,
1399 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1400 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1401 assert (SvPOKp(rx->saved_copy));
1406 rx->subbeg = savepvn(t, strend - t);
1407 #ifdef PERL_COPY_ON_WRITE
1408 rx->saved_copy = Nullsv;
1411 rx->sublen = strend - t;
1412 RX_MATCH_COPIED_on(rx);
1413 off = rx->startp[0] = s - t;
1414 rx->endp[0] = off + rx->minlen;
1416 else { /* startp/endp are used by @- @+. */
1417 rx->startp[0] = s - truebase;
1418 rx->endp[0] = s - truebase + rx->minlen;
1420 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1421 LEAVE_SCOPE(oldsave);
1426 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1427 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1428 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1433 LEAVE_SCOPE(oldsave);
1434 if (gimme == G_ARRAY)
1440 Perl_do_readline(pTHX)
1442 dVAR; dSP; dTARGETSTACKED;
1447 register IO * const io = GvIO(PL_last_in_gv);
1448 register const I32 type = PL_op->op_type;
1449 const I32 gimme = GIMME_V;
1452 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1454 XPUSHs(SvTIED_obj((SV*)io, mg));
1457 call_method("READLINE", gimme);
1460 if (gimme == G_SCALAR) {
1462 SvSetSV_nosteal(TARG, result);
1471 if (IoFLAGS(io) & IOf_ARGV) {
1472 if (IoFLAGS(io) & IOf_START) {
1474 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1475 IoFLAGS(io) &= ~IOf_START;
1476 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1477 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1478 SvSETMAGIC(GvSV(PL_last_in_gv));
1483 fp = nextargv(PL_last_in_gv);
1484 if (!fp) { /* Note: fp != IoIFP(io) */
1485 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1488 else if (type == OP_GLOB)
1489 fp = Perl_start_glob(aTHX_ POPs, io);
1491 else if (type == OP_GLOB)
1493 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1494 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1498 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1499 && (!io || !(IoFLAGS(io) & IOf_START))) {
1500 if (type == OP_GLOB)
1501 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1502 "glob failed (can't start child: %s)",
1505 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1507 if (gimme == G_SCALAR) {
1508 /* undef TARG, and push that undefined value */
1509 if (type != OP_RCATLINE) {
1510 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1518 if (gimme == G_SCALAR) {
1522 (void)SvUPGRADE(sv, SVt_PV);
1523 tmplen = SvLEN(sv); /* remember if already alloced */
1524 if (!tmplen && !SvREADONLY(sv))
1525 Sv_Grow(sv, 80); /* try short-buffering it */
1527 if (type == OP_RCATLINE && SvOK(sv)) {
1530 (void)SvPV_force(sv, n_a);
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(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(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 #ifdef PERL_COPY_ON_WRITE
1670 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1672 const U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1676 if (SvTYPE(hv) == SVt_PVHV) {
1677 if (PL_op->op_private & OPpLVAL_INTRO) {
1680 /* does the element we're localizing already exist? */
1682 /* can we determine whether it exists? */
1684 || mg_find((SV*)hv, PERL_MAGIC_env)
1685 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1686 /* Try to preserve the existenceness of a tied hash
1687 * element by using EXISTS and DELETE if possible.
1688 * Fallback to FETCH and STORE otherwise */
1689 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1690 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1691 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1693 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1696 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1697 svp = he ? &HeVAL(he) : 0;
1703 if (!svp || *svp == &PL_sv_undef) {
1707 DIE(aTHX_ PL_no_helem_sv, keysv);
1709 lv = sv_newmortal();
1710 sv_upgrade(lv, SVt_PVLV);
1712 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1713 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1714 LvTARG(lv) = SvREFCNT_inc(hv);
1719 if (PL_op->op_private & OPpLVAL_INTRO) {
1720 if (HvNAME_get(hv) && isGV(*svp))
1721 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1725 const char * const key = SvPV(keysv, keylen);
1726 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1728 save_helem(hv, keysv, svp);
1731 else if (PL_op->op_private & OPpDEREF)
1732 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1734 sv = (svp ? *svp : &PL_sv_undef);
1735 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1736 * Pushing the magical RHS on to the stack is useless, since
1737 * that magic is soon destined to be misled by the local(),
1738 * and thus the later pp_sassign() will fail to mg_get() the
1739 * old value. This should also cure problems with delayed
1740 * mg_get()s. GSAR 98-07-03 */
1741 if (!lval && SvGMAGICAL(sv))
1742 sv = sv_mortalcopy(sv);
1750 register PERL_CONTEXT *cx;
1755 if (PL_op->op_flags & OPf_SPECIAL) {
1756 cx = &cxstack[cxstack_ix];
1757 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1762 gimme = OP_GIMME(PL_op, -1);
1764 if (cxstack_ix >= 0)
1765 gimme = cxstack[cxstack_ix].blk_gimme;
1771 if (gimme == G_VOID)
1773 else if (gimme == G_SCALAR) {
1777 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1780 *MARK = sv_mortalcopy(TOPs);
1783 *MARK = &PL_sv_undef;
1787 else if (gimme == G_ARRAY) {
1788 /* in case LEAVE wipes old return values */
1790 for (mark = newsp + 1; mark <= SP; mark++) {
1791 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1792 *mark = sv_mortalcopy(*mark);
1793 TAINT_NOT; /* Each item is independent */
1797 PL_curpm = newpm; /* Don't pop $1 et al till now */
1807 register PERL_CONTEXT *cx;
1813 cx = &cxstack[cxstack_ix];
1814 if (CxTYPE(cx) != CXt_LOOP)
1815 DIE(aTHX_ "panic: pp_iter");
1817 itersvp = CxITERVAR(cx);
1818 av = cx->blk_loop.iterary;
1819 if (SvTYPE(av) != SVt_PVAV) {
1820 /* iterate ($min .. $max) */
1821 if (cx->blk_loop.iterlval) {
1822 /* string increment */
1823 register SV* cur = cx->blk_loop.iterlval;
1825 const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1826 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1827 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1828 /* safe to reuse old SV */
1829 sv_setsv(*itersvp, cur);
1833 /* we need a fresh SV every time so that loop body sees a
1834 * completely new SV for closures/references to work as
1837 *itersvp = newSVsv(cur);
1838 SvREFCNT_dec(oldsv);
1840 if (strEQ(SvPVX(cur), max))
1841 sv_setiv(cur, 0); /* terminate next time */
1848 /* integer increment */
1849 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1852 /* don't risk potential race */
1853 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1854 /* safe to reuse old SV */
1855 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1859 /* we need a fresh SV every time so that loop body sees a
1860 * completely new SV for closures/references to work as they
1863 *itersvp = newSViv(cx->blk_loop.iterix++);
1864 SvREFCNT_dec(oldsv);
1870 if (PL_op->op_private & OPpITER_REVERSED) {
1871 /* In reverse, use itermax as the min :-) */
1872 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1875 if (SvMAGICAL(av) || AvREIFY(av)) {
1876 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1883 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1887 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1891 if (SvMAGICAL(av) || AvREIFY(av)) {
1892 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1899 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1903 if (sv && SvREFCNT(sv) == 0) {
1905 Perl_croak(aTHX_ "Use of freed value in iteration");
1912 if (av != PL_curstack && sv == &PL_sv_undef) {
1913 SV *lv = cx->blk_loop.iterlval;
1914 if (lv && SvREFCNT(lv) > 1) {
1919 SvREFCNT_dec(LvTARG(lv));
1921 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1922 sv_upgrade(lv, SVt_PVLV);
1924 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1926 LvTARG(lv) = SvREFCNT_inc(av);
1927 LvTARGOFF(lv) = cx->blk_loop.iterix;
1928 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1933 *itersvp = SvREFCNT_inc(sv);
1934 SvREFCNT_dec(oldsv);
1942 register PMOP *pm = cPMOP;
1958 register REGEXP *rx = PM_GETRE(pm);
1960 int force_on_match = 0;
1961 I32 oldsave = PL_savestack_ix;
1963 bool doutf8 = FALSE;
1964 #ifdef PERL_COPY_ON_WRITE
1969 /* known replacement string? */
1970 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1971 if (PL_op->op_flags & OPf_STACKED)
1973 else if (PL_op->op_private & OPpTARGET_MY)
1980 #ifdef PERL_COPY_ON_WRITE
1981 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1982 because they make integers such as 256 "false". */
1983 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1986 sv_force_normal_flags(TARG,0);
1989 #ifdef PERL_COPY_ON_WRITE
1993 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1994 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1995 DIE(aTHX_ PL_no_modify);
1998 s = SvPV(TARG, len);
1999 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2001 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2002 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2007 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2011 DIE(aTHX_ "panic: pp_subst");
2014 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2015 maxiters = 2 * slen + 10; /* We can match twice at each
2016 position, once with zero-length,
2017 second time with non-zero. */
2019 if (!rx->prelen && PL_curpm) {
2023 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2024 ? REXEC_COPY_STR : 0;
2026 r_flags |= REXEC_SCREAM;
2029 if (rx->reganch & RE_USE_INTUIT) {
2031 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2035 /* How to do it in subst? */
2036 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2038 && ((rx->reganch & ROPT_NOSCAN)
2039 || !((rx->reganch & RE_INTUIT_TAIL)
2040 && (r_flags & REXEC_SCREAM))))
2045 /* only replace once? */
2046 once = !(rpm->op_pmflags & PMf_GLOBAL);
2048 /* known replacement string? */
2050 /* replacement needing upgrading? */
2051 if (DO_UTF8(TARG) && !doutf8) {
2052 nsv = sv_newmortal();
2055 sv_recode_to_utf8(nsv, PL_encoding);
2057 sv_utf8_upgrade(nsv);
2058 c = SvPV(nsv, clen);
2062 c = SvPV(dstr, clen);
2063 doutf8 = DO_UTF8(dstr);
2071 /* can do inplace substitution? */
2073 #ifdef PERL_COPY_ON_WRITE
2076 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2077 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2078 && (!doutf8 || SvUTF8(TARG))) {
2079 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2080 r_flags | REXEC_CHECKED))
2084 LEAVE_SCOPE(oldsave);
2087 #ifdef PERL_COPY_ON_WRITE
2088 if (SvIsCOW(TARG)) {
2089 assert (!force_on_match);
2093 if (force_on_match) {
2095 s = SvPV_force(TARG, len);
2100 SvSCREAM_off(TARG); /* disable possible screamer */
2102 rxtainted |= RX_MATCH_TAINTED(rx);
2103 m = orig + rx->startp[0];
2104 d = orig + rx->endp[0];
2106 if (m - s > strend - d) { /* faster to shorten from end */
2108 Copy(c, m, clen, char);
2113 Move(d, m, i, char);
2117 SvCUR_set(TARG, m - s);
2120 else if ((i = m - s)) { /* faster from front */
2128 Copy(c, m, clen, char);
2133 Copy(c, d, clen, char);
2138 TAINT_IF(rxtainted & 1);
2144 if (iters++ > maxiters)
2145 DIE(aTHX_ "Substitution loop");
2146 rxtainted |= RX_MATCH_TAINTED(rx);
2147 m = rx->startp[0] + orig;
2151 Move(s, d, i, char);
2155 Copy(c, d, clen, char);
2158 s = rx->endp[0] + orig;
2159 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2161 /* don't match same null twice */
2162 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2165 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2166 Move(s, d, i+1, char); /* include the NUL */
2168 TAINT_IF(rxtainted & 1);
2170 PUSHs(sv_2mortal(newSViv((I32)iters)));
2172 (void)SvPOK_only_UTF8(TARG);
2173 TAINT_IF(rxtainted);
2174 if (SvSMAGICAL(TARG)) {
2182 LEAVE_SCOPE(oldsave);
2186 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2187 r_flags | REXEC_CHECKED))
2189 if (force_on_match) {
2191 s = SvPV_force(TARG, len);
2194 #ifdef PERL_COPY_ON_WRITE
2197 rxtainted |= RX_MATCH_TAINTED(rx);
2198 dstr = newSVpvn(m, s-m);
2203 register PERL_CONTEXT *cx;
2207 RETURNOP(cPMOP->op_pmreplroot);
2209 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2211 if (iters++ > maxiters)
2212 DIE(aTHX_ "Substitution loop");
2213 rxtainted |= RX_MATCH_TAINTED(rx);
2214 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2219 strend = s + (strend - m);
2221 m = rx->startp[0] + orig;
2222 if (doutf8 && !SvUTF8(dstr))
2223 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2225 sv_catpvn(dstr, s, m-s);
2226 s = rx->endp[0] + orig;
2228 sv_catpvn(dstr, c, clen);
2231 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2232 TARG, NULL, r_flags));
2233 if (doutf8 && !DO_UTF8(TARG))
2234 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2236 sv_catpvn(dstr, s, strend - s);
2238 #ifdef PERL_COPY_ON_WRITE
2239 /* The match may make the string COW. If so, brilliant, because that's
2240 just saved us one malloc, copy and free - the regexp has donated
2241 the old buffer, and we malloc an entirely new one, rather than the
2242 regexp malloc()ing a buffer and copying our original, only for
2243 us to throw it away here during the substitution. */
2244 if (SvIsCOW(TARG)) {
2245 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2251 SvPV_set(TARG, SvPVX(dstr));
2252 SvCUR_set(TARG, SvCUR(dstr));
2253 SvLEN_set(TARG, SvLEN(dstr));
2254 doutf8 |= DO_UTF8(dstr);
2255 SvPV_set(dstr, (char*)0);
2258 TAINT_IF(rxtainted & 1);
2260 PUSHs(sv_2mortal(newSViv((I32)iters)));
2262 (void)SvPOK_only(TARG);
2265 TAINT_IF(rxtainted);
2268 LEAVE_SCOPE(oldsave);
2277 LEAVE_SCOPE(oldsave);
2286 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2287 ++*PL_markstack_ptr;
2288 LEAVE; /* exit inner scope */
2291 if (PL_stack_base + *PL_markstack_ptr > SP) {
2293 I32 gimme = GIMME_V;
2295 LEAVE; /* exit outer scope */
2296 (void)POPMARK; /* pop src */
2297 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2298 (void)POPMARK; /* pop dst */
2299 SP = PL_stack_base + POPMARK; /* pop original mark */
2300 if (gimme == G_SCALAR) {
2301 if (PL_op->op_private & OPpGREP_LEX) {
2302 SV* sv = sv_newmortal();
2303 sv_setiv(sv, items);
2311 else if (gimme == G_ARRAY)
2318 ENTER; /* enter inner scope */
2321 src = PL_stack_base[*PL_markstack_ptr];
2323 if (PL_op->op_private & OPpGREP_LEX)
2324 PAD_SVl(PL_op->op_targ) = src;
2328 RETURNOP(cLOGOP->op_other);
2339 register PERL_CONTEXT *cx;
2343 cxstack_ix++; /* temporarily protect top context */
2346 if (gimme == G_SCALAR) {
2349 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2351 *MARK = SvREFCNT_inc(TOPs);
2356 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2358 *MARK = sv_mortalcopy(sv);
2363 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2367 *MARK = &PL_sv_undef;
2371 else if (gimme == G_ARRAY) {
2372 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2373 if (!SvTEMP(*MARK)) {
2374 *MARK = sv_mortalcopy(*MARK);
2375 TAINT_NOT; /* Each item is independent */
2383 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2384 PL_curpm = newpm; /* ... and pop $1 et al */
2387 return cx->blk_sub.retop;
2390 /* This duplicates the above code because the above code must not
2391 * get any slower by more conditions */
2399 register PERL_CONTEXT *cx;
2403 cxstack_ix++; /* temporarily protect top context */
2407 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2408 /* We are an argument to a function or grep().
2409 * This kind of lvalueness was legal before lvalue
2410 * subroutines too, so be backward compatible:
2411 * cannot report errors. */
2413 /* Scalar context *is* possible, on the LHS of -> only,
2414 * as in f()->meth(). But this is not an lvalue. */
2415 if (gimme == G_SCALAR)
2417 if (gimme == G_ARRAY) {
2418 if (!CvLVALUE(cx->blk_sub.cv))
2419 goto temporise_array;
2420 EXTEND_MORTAL(SP - newsp);
2421 for (mark = newsp + 1; mark <= SP; mark++) {
2424 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2425 *mark = sv_mortalcopy(*mark);
2427 /* Can be a localized value subject to deletion. */
2428 PL_tmps_stack[++PL_tmps_ix] = *mark;
2429 (void)SvREFCNT_inc(*mark);
2434 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2435 /* Here we go for robustness, not for speed, so we change all
2436 * the refcounts so the caller gets a live guy. Cannot set
2437 * TEMP, so sv_2mortal is out of question. */
2438 if (!CvLVALUE(cx->blk_sub.cv)) {
2444 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2446 if (gimme == G_SCALAR) {
2450 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2456 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2457 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2458 : "a readonly value" : "a temporary");
2460 else { /* Can be a localized value
2461 * subject to deletion. */
2462 PL_tmps_stack[++PL_tmps_ix] = *mark;
2463 (void)SvREFCNT_inc(*mark);
2466 else { /* Should not happen? */
2472 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2473 (MARK > SP ? "Empty array" : "Array"));
2477 else if (gimme == G_ARRAY) {
2478 EXTEND_MORTAL(SP - newsp);
2479 for (mark = newsp + 1; mark <= SP; mark++) {
2480 if (*mark != &PL_sv_undef
2481 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2482 /* Might be flattened array after $#array = */
2489 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2490 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2493 /* Can be a localized value subject to deletion. */
2494 PL_tmps_stack[++PL_tmps_ix] = *mark;
2495 (void)SvREFCNT_inc(*mark);
2501 if (gimme == G_SCALAR) {
2505 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2507 *MARK = SvREFCNT_inc(TOPs);
2512 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2514 *MARK = sv_mortalcopy(sv);
2519 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2523 *MARK = &PL_sv_undef;
2527 else if (gimme == G_ARRAY) {
2529 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2530 if (!SvTEMP(*MARK)) {
2531 *MARK = sv_mortalcopy(*MARK);
2532 TAINT_NOT; /* Each item is independent */
2541 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2542 PL_curpm = newpm; /* ... and pop $1 et al */
2545 return cx->blk_sub.retop;
2550 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2552 SV *dbsv = GvSV(PL_DBsub);
2555 if (!PERLDB_SUB_NN) {
2558 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2559 || strEQ(GvNAME(gv), "END")
2560 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2561 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2562 && (gv = (GV*)*svp) ))) {
2563 /* Use GV from the stack as a fallback. */
2564 /* GV is potentially non-unique, or contain different CV. */
2565 SV *tmp = newRV((SV*)cv);
2566 sv_setsv(dbsv, tmp);
2570 gv_efullname3(dbsv, gv, Nullch);
2574 const int type = SvTYPE(dbsv);
2575 if (type < SVt_PVIV && type != SVt_IV)
2576 sv_upgrade(dbsv, SVt_PVIV);
2577 (void)SvIOK_on(dbsv);
2578 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2582 PL_curcopdb = PL_curcop;
2583 cv = GvCV(PL_DBsub);
2593 register PERL_CONTEXT *cx;
2595 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2598 DIE(aTHX_ "Not a CODE reference");
2599 switch (SvTYPE(sv)) {
2600 /* This is overwhelming the most common case: */
2602 if (!(cv = GvCVu((GV*)sv)))
2603 cv = sv_2cv(sv, &stash, &gv, FALSE);
2613 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2615 SP = PL_stack_base + POPMARK;
2618 if (SvGMAGICAL(sv)) {
2622 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2626 sym = SvPV(sv, n_a);
2629 DIE(aTHX_ PL_no_usym, "a subroutine");
2630 if (PL_op->op_private & HINT_STRICT_REFS)
2631 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2632 cv = get_cv(sym, TRUE);
2637 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2638 tryAMAGICunDEREF(to_cv);
2641 if (SvTYPE(cv) == SVt_PVCV)
2646 DIE(aTHX_ "Not a CODE reference");
2647 /* This is the second most common case: */
2657 if (!CvROOT(cv) && !CvXSUB(cv)) {
2662 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2663 if (CvASSERTION(cv) && PL_DBassertion)
2664 sv_setiv(PL_DBassertion, 1);
2666 cv = get_db_sub(&sv, cv);
2667 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2668 DIE(aTHX_ "No DB::sub routine defined");
2671 if (!(CvXSUB(cv))) {
2672 /* This path taken at least 75% of the time */
2674 register I32 items = SP - MARK;
2675 AV* padlist = CvPADLIST(cv);
2676 PUSHBLOCK(cx, CXt_SUB, MARK);
2678 cx->blk_sub.retop = PL_op->op_next;
2680 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2681 * that eval'' ops within this sub know the correct lexical space.
2682 * Owing the speed considerations, we choose instead to search for
2683 * the cv using find_runcv() when calling doeval().
2685 if (CvDEPTH(cv) >= 2) {
2686 PERL_STACK_OVERFLOW_CHECK();
2687 pad_push(padlist, CvDEPTH(cv));
2689 PAD_SET_CUR(padlist, CvDEPTH(cv));
2694 DEBUG_S(PerlIO_printf(Perl_debug_log,
2695 "%p entersub preparing @_\n", thr));
2697 av = (AV*)PAD_SVl(0);
2699 /* @_ is normally not REAL--this should only ever
2700 * happen when DB::sub() calls things that modify @_ */
2705 cx->blk_sub.savearray = GvAV(PL_defgv);
2706 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2707 CX_CURPAD_SAVE(cx->blk_sub);
2708 cx->blk_sub.argarray = av;
2711 if (items > AvMAX(av) + 1) {
2712 SV **ary = AvALLOC(av);
2713 if (AvARRAY(av) != ary) {
2714 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2715 SvPV_set(av, (char*)ary);
2717 if (items > AvMAX(av) + 1) {
2718 AvMAX(av) = items - 1;
2719 Renew(ary,items,SV*);
2721 SvPV_set(av, (char*)ary);
2724 Copy(MARK,AvARRAY(av),items,SV*);
2725 AvFILLp(av) = items - 1;
2733 /* warning must come *after* we fully set up the context
2734 * stuff so that __WARN__ handlers can safely dounwind()
2737 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2738 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2739 sub_crush_depth(cv);
2741 DEBUG_S(PerlIO_printf(Perl_debug_log,
2742 "%p entersub returning %p\n", thr, CvSTART(cv)));
2744 RETURNOP(CvSTART(cv));
2747 #ifdef PERL_XSUB_OLDSTYLE
2748 if (CvOLDSTYLE(cv)) {
2749 I32 (*fp3)(int,int,int);
2751 register I32 items = SP - MARK;
2752 /* We dont worry to copy from @_. */
2757 PL_stack_sp = mark + 1;
2758 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2759 items = (*fp3)(CvXSUBANY(cv).any_i32,
2760 MARK - PL_stack_base + 1,
2762 PL_stack_sp = PL_stack_base + items;
2765 #endif /* PERL_XSUB_OLDSTYLE */
2767 I32 markix = TOPMARK;
2772 /* Need to copy @_ to stack. Alternative may be to
2773 * switch stack to @_, and copy return values
2774 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2775 AV * const av = GvAV(PL_defgv);
2776 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2779 /* Mark is at the end of the stack. */
2781 Copy(AvARRAY(av), SP + 1, items, SV*);
2786 /* We assume first XSUB in &DB::sub is the called one. */
2788 SAVEVPTR(PL_curcop);
2789 PL_curcop = PL_curcopdb;
2792 /* Do we need to open block here? XXXX */
2793 (void)(*CvXSUB(cv))(aTHX_ cv);
2795 /* Enforce some sanity in scalar context. */
2796 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2797 if (markix > PL_stack_sp - PL_stack_base)
2798 *(PL_stack_base + markix) = &PL_sv_undef;
2800 *(PL_stack_base + markix) = *PL_stack_sp;
2801 PL_stack_sp = PL_stack_base + markix;
2808 assert (0); /* Cannot get here. */
2809 /* This is deliberately moved here as spaghetti code to keep it out of the
2816 /* anonymous or undef'd function leaves us no recourse */
2817 if (CvANON(cv) || !(gv = CvGV(cv)))
2818 DIE(aTHX_ "Undefined subroutine called");
2820 /* autoloaded stub? */
2821 if (cv != GvCV(gv)) {
2824 /* should call AUTOLOAD now? */
2827 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2834 sub_name = sv_newmortal();
2835 gv_efullname3(sub_name, gv, Nullch);
2836 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2840 DIE(aTHX_ "Not a CODE reference");
2846 Perl_sub_crush_depth(pTHX_ CV *cv)
2849 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2851 SV* tmpstr = sv_newmortal();
2852 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2853 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2862 SV* const elemsv = POPs;
2863 IV elem = SvIV(elemsv);
2865 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2866 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2869 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2870 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2872 elem -= PL_curcop->cop_arybase;
2873 if (SvTYPE(av) != SVt_PVAV)
2875 svp = av_fetch(av, elem, lval && !defer);
2877 #ifdef PERL_MALLOC_WRAP
2878 if (SvUOK(elemsv)) {
2879 const UV uv = SvUV(elemsv);
2880 elem = uv > IV_MAX ? IV_MAX : uv;
2882 else if (SvNOK(elemsv))
2883 elem = (IV)SvNV(elemsv);
2885 static const char oom_array_extend[] =
2886 "Out of memory during array extend"; /* Duplicated in av.c */
2887 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2890 if (!svp || *svp == &PL_sv_undef) {
2893 DIE(aTHX_ PL_no_aelem, elem);
2894 lv = sv_newmortal();
2895 sv_upgrade(lv, SVt_PVLV);
2897 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2898 LvTARG(lv) = SvREFCNT_inc(av);
2899 LvTARGOFF(lv) = elem;
2904 if (PL_op->op_private & OPpLVAL_INTRO)
2905 save_aelem(av, elem, svp);
2906 else if (PL_op->op_private & OPpDEREF)
2907 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2909 sv = (svp ? *svp : &PL_sv_undef);
2910 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2911 sv = sv_mortalcopy(sv);
2917 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2923 Perl_croak(aTHX_ PL_no_modify);
2924 if (SvTYPE(sv) < SVt_RV)
2925 sv_upgrade(sv, SVt_RV);
2926 else if (SvTYPE(sv) >= SVt_PV) {
2933 SvRV_set(sv, NEWSV(355,0));
2936 SvRV_set(sv, (SV*)newAV());
2939 SvRV_set(sv, (SV*)newHV());
2954 if (SvTYPE(rsv) == SVt_PVCV) {
2960 SETs(method_common(sv, Null(U32*)));
2968 U32 hash = SvUVX(sv);
2970 XPUSHs(method_common(sv, &hash));
2975 S_method_common(pTHX_ SV* meth, U32* hashp)
2982 const char* packname = 0;
2983 SV *packsv = Nullsv;
2985 const char *name = SvPV(meth, namelen);
2987 sv = *(PL_stack_base + TOPMARK + 1);
2990 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2999 /* this isn't a reference */
3002 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3004 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3006 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3013 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3014 !(ob=(SV*)GvIO(iogv)))
3016 /* this isn't the name of a filehandle either */
3018 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3019 ? !isIDFIRST_utf8((U8*)packname)
3020 : !isIDFIRST(*packname)
3023 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3024 SvOK(sv) ? "without a package or object reference"
3025 : "on an undefined value");
3027 /* assume it's a package name */
3028 stash = gv_stashpvn(packname, packlen, FALSE);
3032 SV* ref = newSViv(PTR2IV(stash));
3033 hv_store(PL_stashcache, packname, packlen, ref, 0);
3037 /* it _is_ a filehandle name -- replace with a reference */
3038 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3041 /* if we got here, ob should be a reference or a glob */
3042 if (!ob || !(SvOBJECT(ob)
3043 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3046 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3050 stash = SvSTASH(ob);
3053 /* NOTE: stash may be null, hope hv_fetch_ent and
3054 gv_fetchmethod can cope (it seems they can) */
3056 /* shortcut for simple names */
3058 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3060 gv = (GV*)HeVAL(he);
3061 if (isGV(gv) && GvCV(gv) &&
3062 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3063 return (SV*)GvCV(gv);
3067 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3070 /* This code tries to figure out just what went wrong with
3071 gv_fetchmethod. It therefore needs to duplicate a lot of
3072 the internals of that function. We can't move it inside
3073 Perl_gv_fetchmethod_autoload(), however, since that would
3074 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3077 const char* leaf = name;
3078 const char* sep = Nullch;
3081 for (p = name; *p; p++) {
3083 sep = p, leaf = p + 1;
3084 else if (*p == ':' && *(p + 1) == ':')
3085 sep = p, leaf = p + 2;
3087 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3088 /* the method name is unqualified or starts with SUPER:: */
3089 packname = sep ? CopSTASHPV(PL_curcop) :
3090 stash ? HvNAME_get(stash) : packname;
3093 "Can't use anonymous symbol table for method lookup");
3095 packlen = strlen(packname);
3098 /* the method name is qualified */
3100 packlen = sep - name;
3103 /* we're relying on gv_fetchmethod not autovivifying the stash */
3104 if (gv_stashpvn(packname, packlen, FALSE)) {
3106 "Can't locate object method \"%s\" via package \"%.*s\"",
3107 leaf, (int)packlen, packname);
3111 "Can't locate object method \"%s\" via package \"%.*s\""
3112 " (perhaps you forgot to load \"%.*s\"?)",
3113 leaf, (int)packlen, packname, (int)packlen, packname);
3116 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3121 * c-indentation-style: bsd
3123 * indent-tabs-mode: t
3126 * ex: set ts=8 sts=4 sw=4 noet: