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 SvGETMAGIC(left); /* or mg_get(left) may happen here */
174 sv_setpvn(left, "", 0);
175 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
176 lbyte = !DO_UTF8(left);
181 if (lbyte != rbyte) {
183 sv_utf8_upgrade_nomg(TARG);
186 right = sv_2mortal(newSVpvn(rpv, rlen));
187 sv_utf8_upgrade_nomg(right);
188 rpv = SvPV_const(right, rlen);
191 sv_catpvn_nomg(TARG, rpv, rlen);
202 if (PL_op->op_flags & OPf_MOD) {
203 if (PL_op->op_private & OPpLVAL_INTRO)
204 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
205 if (PL_op->op_private & OPpDEREF) {
207 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
216 tryAMAGICunTARGET(iter, 0);
217 PL_last_in_gv = (GV*)(*PL_stack_sp--);
218 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
219 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
220 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
223 XPUSHs((SV*)PL_last_in_gv);
226 PL_last_in_gv = (GV*)(*PL_stack_sp--);
229 return do_readline();
234 dSP; tryAMAGICbinSET(eq,0);
235 #ifndef NV_PRESERVES_UV
236 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
238 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
242 #ifdef PERL_PRESERVE_IVUV
245 /* Unless the left argument is integer in range we are going
246 to have to use NV maths. Hence only attempt to coerce the
247 right argument if we know the left is integer. */
250 bool auvok = SvUOK(TOPm1s);
251 bool buvok = SvUOK(TOPs);
253 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
254 /* Casting IV to UV before comparison isn't going to matter
255 on 2s complement. On 1s complement or sign&magnitude
256 (if we have any of them) it could to make negative zero
257 differ from normal zero. As I understand it. (Need to
258 check - is negative zero implementation defined behaviour
260 UV buv = SvUVX(POPs);
261 UV auv = SvUVX(TOPs);
263 SETs(boolSV(auv == buv));
266 { /* ## Mixed IV,UV ## */
270 /* == is commutative so doesn't matter which is left or right */
272 /* top of stack (b) is the iv */
281 /* As uv is a UV, it's >0, so it cannot be == */
285 /* we know iv is >= 0 */
286 SETs(boolSV((UV)iv == SvUVX(uvp)));
294 SETs(boolSV(TOPn == value));
302 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
303 DIE(aTHX_ PL_no_modify);
304 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
305 && SvIVX(TOPs) != IV_MAX)
307 SvIV_set(TOPs, SvIVX(TOPs) + 1);
308 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
310 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
323 RETURNOP(cLOGOP->op_other);
329 /* Most of this is lifted straight from pp_defined */
331 register SV* const sv = TOPs;
333 if (!sv || !SvANY(sv)) {
335 RETURNOP(cLOGOP->op_other);
338 switch (SvTYPE(sv)) {
340 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
344 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
348 if (CvROOT(sv) || CvXSUB(sv))
358 RETURNOP(cLOGOP->op_other);
363 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
364 useleft = USE_LEFT(TOPm1s);
365 #ifdef PERL_PRESERVE_IVUV
366 /* We must see if we can perform the addition with integers if possible,
367 as the integer code detects overflow while the NV code doesn't.
368 If either argument hasn't had a numeric conversion yet attempt to get
369 the IV. It's important to do this now, rather than just assuming that
370 it's not IOK as a PV of "9223372036854775806" may not take well to NV
371 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
372 integer in case the second argument is IV=9223372036854775806
373 We can (now) rely on sv_2iv to do the right thing, only setting the
374 public IOK flag if the value in the NV (or PV) slot is truly integer.
376 A side effect is that this also aggressively prefers integer maths over
377 fp maths for integer values.
379 How to detect overflow?
381 C 99 section 6.2.6.1 says
383 The range of nonnegative values of a signed integer type is a subrange
384 of the corresponding unsigned integer type, and the representation of
385 the same value in each type is the same. A computation involving
386 unsigned operands can never overflow, because a result that cannot be
387 represented by the resulting unsigned integer type is reduced modulo
388 the number that is one greater than the largest value that can be
389 represented by the resulting type.
393 which I read as "unsigned ints wrap."
395 signed integer overflow seems to be classed as "exception condition"
397 If an exceptional condition occurs during the evaluation of an
398 expression (that is, if the result is not mathematically defined or not
399 in the range of representable values for its type), the behavior is
402 (6.5, the 5th paragraph)
404 I had assumed that on 2s complement machines signed arithmetic would
405 wrap, hence coded pp_add and pp_subtract on the assumption that
406 everything perl builds on would be happy. After much wailing and
407 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
408 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
409 unsigned code below is actually shorter than the old code. :-)
414 /* Unless the left argument is integer in range we are going to have to
415 use NV maths. Hence only attempt to coerce the right argument if
416 we know the left is integer. */
424 /* left operand is undef, treat as zero. + 0 is identity,
425 Could SETi or SETu right now, but space optimise by not adding
426 lots of code to speed up what is probably a rarish case. */
428 /* Left operand is defined, so is it IV? */
431 if ((auvok = SvUOK(TOPm1s)))
434 register const IV aiv = SvIVX(TOPm1s);
437 auvok = 1; /* Now acting as a sign flag. */
438 } else { /* 2s complement assumption for IV_MIN */
446 bool result_good = 0;
449 bool buvok = SvUOK(TOPs);
454 register const IV biv = SvIVX(TOPs);
461 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
462 else "IV" now, independent of how it came in.
463 if a, b represents positive, A, B negative, a maps to -A etc
468 all UV maths. negate result if A negative.
469 add if signs same, subtract if signs differ. */
475 /* Must get smaller */
481 /* result really should be -(auv-buv). as its negation
482 of true value, need to swap our result flag */
499 if (result <= (UV)IV_MIN)
502 /* result valid, but out of range for IV. */
507 } /* Overflow, drop through to NVs. */
514 /* left operand is undef, treat as zero. + 0.0 is identity. */
518 SETn( value + TOPn );
526 AV *av = PL_op->op_flags & OPf_SPECIAL ?
527 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
528 const U32 lval = PL_op->op_flags & OPf_MOD;
529 SV** svp = av_fetch(av, PL_op->op_private, lval);
530 SV *sv = (svp ? *svp : &PL_sv_undef);
532 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
533 sv = sv_mortalcopy(sv);
542 do_join(TARG, *MARK, MARK, SP);
553 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
554 * will be enough to hold an OP*.
556 SV* sv = sv_newmortal();
557 sv_upgrade(sv, SVt_PVLV);
559 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
567 /* Oversized hot code. */
571 dVAR; dSP; dMARK; dORIGMARK;
577 if (PL_op->op_flags & OPf_STACKED)
582 if (gv && (io = GvIO(gv))
583 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
586 if (MARK == ORIGMARK) {
587 /* If using default handle then we need to make space to
588 * pass object as 1st arg, so move other args up ...
592 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
596 *MARK = SvTIED_obj((SV*)io, mg);
599 call_method("PRINT", G_SCALAR);
607 if (!(io = GvIO(gv))) {
608 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
609 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
611 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
612 report_evil_fh(gv, io, PL_op->op_type);
613 SETERRNO(EBADF,RMS_IFI);
616 else if (!(fp = IoOFP(io))) {
617 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
619 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
620 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
621 report_evil_fh(gv, io, PL_op->op_type);
623 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
628 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
630 if (!do_print(*MARK, fp))
634 if (!do_print(PL_ofs_sv, fp)) { /* $, */
643 if (!do_print(*MARK, fp))
651 if (PL_ors_sv && SvOK(PL_ors_sv))
652 if (!do_print(PL_ors_sv, fp)) /* $\ */
655 if (IoFLAGS(io) & IOf_FLUSH)
656 if (PerlIO_flush(fp) == EOF)
677 tryAMAGICunDEREF(to_av);
680 if (SvTYPE(av) != SVt_PVAV)
681 DIE(aTHX_ "Not an ARRAY reference");
682 if (PL_op->op_flags & OPf_REF) {
687 if (GIMME == G_SCALAR)
688 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
692 else if (PL_op->op_flags & OPf_MOD
693 && PL_op->op_private & OPpLVAL_INTRO)
694 Perl_croak(aTHX_ PL_no_localize_ref);
697 if (SvTYPE(sv) == SVt_PVAV) {
699 if (PL_op->op_flags & OPf_REF) {
704 if (GIMME == G_SCALAR)
705 Perl_croak(aTHX_ "Can't return array to lvalue"
714 if (SvTYPE(sv) != SVt_PVGV) {
715 if (SvGMAGICAL(sv)) {
721 if (PL_op->op_flags & OPf_REF ||
722 PL_op->op_private & HINT_STRICT_REFS)
723 DIE(aTHX_ PL_no_usym, "an ARRAY");
724 if (ckWARN(WARN_UNINITIALIZED))
726 if (GIMME == G_ARRAY) {
732 if ((PL_op->op_flags & OPf_SPECIAL) &&
733 !(PL_op->op_flags & OPf_MOD))
735 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
737 && (!is_gv_magical_sv(sv,0)
738 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
744 if (PL_op->op_private & HINT_STRICT_REFS)
745 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
746 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
753 if (PL_op->op_private & OPpLVAL_INTRO)
755 if (PL_op->op_flags & OPf_REF) {
760 if (GIMME == G_SCALAR)
761 Perl_croak(aTHX_ "Can't return array to lvalue"
769 if (GIMME == G_ARRAY) {
770 const I32 maxarg = AvFILL(av) + 1;
771 (void)POPs; /* XXXX May be optimized away? */
773 if (SvRMAGICAL(av)) {
775 for (i=0; i < (U32)maxarg; i++) {
776 SV **svp = av_fetch(av, i, FALSE);
777 /* See note in pp_helem, and bug id #27839 */
779 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
784 Copy(AvARRAY(av), SP+1, maxarg, SV*);
788 else if (GIMME_V == G_SCALAR) {
790 const I32 maxarg = AvFILL(av) + 1;
800 const I32 gimme = GIMME_V;
801 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
805 tryAMAGICunDEREF(to_hv);
808 if (SvTYPE(hv) != SVt_PVHV)
809 DIE(aTHX_ "Not a HASH reference");
810 if (PL_op->op_flags & OPf_REF) {
815 if (gimme != G_ARRAY)
816 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
820 else if (PL_op->op_flags & OPf_MOD
821 && PL_op->op_private & OPpLVAL_INTRO)
822 Perl_croak(aTHX_ PL_no_localize_ref);
825 if (SvTYPE(sv) == SVt_PVHV) {
827 if (PL_op->op_flags & OPf_REF) {
832 if (gimme != G_ARRAY)
833 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
841 if (SvTYPE(sv) != SVt_PVGV) {
842 if (SvGMAGICAL(sv)) {
848 if (PL_op->op_flags & OPf_REF ||
849 PL_op->op_private & HINT_STRICT_REFS)
850 DIE(aTHX_ PL_no_usym, "a HASH");
851 if (ckWARN(WARN_UNINITIALIZED))
853 if (gimme == G_ARRAY) {
859 if ((PL_op->op_flags & OPf_SPECIAL) &&
860 !(PL_op->op_flags & OPf_MOD))
862 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
864 && (!is_gv_magical_sv(sv,0)
865 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
871 if (PL_op->op_private & HINT_STRICT_REFS)
872 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
873 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
880 if (PL_op->op_private & OPpLVAL_INTRO)
882 if (PL_op->op_flags & OPf_REF) {
887 if (gimme != G_ARRAY)
888 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
895 if (gimme == G_ARRAY) { /* array wanted */
896 *PL_stack_sp = (SV*)hv;
899 else if (gimme == G_SCALAR) {
901 TARG = Perl_hv_scalar(aTHX_ hv);
908 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
914 if (ckWARN(WARN_MISC)) {
916 if (relem == firstrelem &&
918 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
919 SvTYPE(SvRV(*relem)) == SVt_PVHV))
921 err = "Reference found where even-sized list expected";
924 err = "Odd number of elements in hash assignment";
925 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
928 tmpstr = NEWSV(29,0);
929 didstore = hv_store_ent(hash,*relem,tmpstr,0);
930 if (SvMAGICAL(hash)) {
931 if (SvSMAGICAL(tmpstr))
943 SV **lastlelem = PL_stack_sp;
944 SV **lastrelem = PL_stack_base + POPMARK;
945 SV **firstrelem = PL_stack_base + POPMARK + 1;
946 SV **firstlelem = lastrelem + 1;
959 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
962 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
965 /* If there's a common identifier on both sides we have to take
966 * special care that assigning the identifier on the left doesn't
967 * clobber a value on the right that's used later in the list.
969 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
970 EXTEND_MORTAL(lastrelem - firstrelem + 1);
971 for (relem = firstrelem; relem <= lastrelem; relem++) {
973 TAINT_NOT; /* Each item is independent */
974 *relem = sv_mortalcopy(sv);
984 while (lelem <= lastlelem) {
985 TAINT_NOT; /* Each item stands on its own, taintwise. */
987 switch (SvTYPE(sv)) {
990 magic = SvMAGICAL(ary) != 0;
992 av_extend(ary, lastrelem - relem);
994 while (relem <= lastrelem) { /* gobble up all the rest */
997 sv = newSVsv(*relem);
999 didstore = av_store(ary,i++,sv);
1009 case SVt_PVHV: { /* normal hash */
1013 magic = SvMAGICAL(hash) != 0;
1015 firsthashrelem = relem;
1017 while (relem < lastrelem) { /* gobble up all the rest */
1022 sv = &PL_sv_no, relem++;
1023 tmpstr = NEWSV(29,0);
1025 sv_setsv(tmpstr,*relem); /* value */
1026 *(relem++) = tmpstr;
1027 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1028 /* key overwrites an existing entry */
1030 didstore = hv_store_ent(hash,sv,tmpstr,0);
1032 if (SvSMAGICAL(tmpstr))
1039 if (relem == lastrelem) {
1040 do_oddball(hash, relem, firstrelem);
1046 if (SvIMMORTAL(sv)) {
1047 if (relem <= lastrelem)
1051 if (relem <= lastrelem) {
1052 sv_setsv(sv, *relem);
1056 sv_setsv(sv, &PL_sv_undef);
1061 if (PL_delaymagic & ~DM_DELAY) {
1062 if (PL_delaymagic & DM_UID) {
1063 #ifdef HAS_SETRESUID
1064 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1065 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1068 # ifdef HAS_SETREUID
1069 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1070 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1073 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1074 (void)setruid(PL_uid);
1075 PL_delaymagic &= ~DM_RUID;
1077 # endif /* HAS_SETRUID */
1079 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1080 (void)seteuid(PL_euid);
1081 PL_delaymagic &= ~DM_EUID;
1083 # endif /* HAS_SETEUID */
1084 if (PL_delaymagic & DM_UID) {
1085 if (PL_uid != PL_euid)
1086 DIE(aTHX_ "No setreuid available");
1087 (void)PerlProc_setuid(PL_uid);
1089 # endif /* HAS_SETREUID */
1090 #endif /* HAS_SETRESUID */
1091 PL_uid = PerlProc_getuid();
1092 PL_euid = PerlProc_geteuid();
1094 if (PL_delaymagic & DM_GID) {
1095 #ifdef HAS_SETRESGID
1096 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1097 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1100 # ifdef HAS_SETREGID
1101 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1102 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1105 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1106 (void)setrgid(PL_gid);
1107 PL_delaymagic &= ~DM_RGID;
1109 # endif /* HAS_SETRGID */
1111 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1112 (void)setegid(PL_egid);
1113 PL_delaymagic &= ~DM_EGID;
1115 # endif /* HAS_SETEGID */
1116 if (PL_delaymagic & DM_GID) {
1117 if (PL_gid != PL_egid)
1118 DIE(aTHX_ "No setregid available");
1119 (void)PerlProc_setgid(PL_gid);
1121 # endif /* HAS_SETREGID */
1122 #endif /* HAS_SETRESGID */
1123 PL_gid = PerlProc_getgid();
1124 PL_egid = PerlProc_getegid();
1126 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1130 if (gimme == G_VOID)
1131 SP = firstrelem - 1;
1132 else if (gimme == G_SCALAR) {
1135 SETi(lastrelem - firstrelem + 1 - duplicates);
1142 /* Removes from the stack the entries which ended up as
1143 * duplicated keys in the hash (fix for [perl #24380]) */
1144 Move(firsthashrelem + duplicates,
1145 firsthashrelem, duplicates, SV**);
1146 lastrelem -= duplicates;
1151 SP = firstrelem + (lastlelem - firstlelem);
1152 lelem = firstlelem + (relem - firstrelem);
1154 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1162 register PMOP *pm = cPMOP;
1163 SV *rv = sv_newmortal();
1164 SV *sv = newSVrv(rv, "Regexp");
1165 if (pm->op_pmdynflags & PMdf_TAINTED)
1167 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1174 register PMOP *pm = cPMOP;
1176 const register char *t;
1177 const register char *s;
1180 I32 r_flags = REXEC_CHECKED;
1181 const char *truebase; /* Start of string */
1182 register REGEXP *rx = PM_GETRE(pm);
1184 const I32 gimme = GIMME;
1187 const I32 oldsave = PL_savestack_ix;
1188 I32 update_minmatch = 1;
1189 I32 had_zerolen = 0;
1191 if (PL_op->op_flags & OPf_STACKED)
1193 else if (PL_op->op_private & OPpTARGET_MY)
1200 PUTBACK; /* EVAL blocks need stack_sp. */
1201 s = SvPV_const(TARG, len);
1203 DIE(aTHX_ "panic: pp_match");
1205 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1206 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1209 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1211 /* PMdf_USED is set after a ?? matches once */
1212 if (pm->op_pmdynflags & PMdf_USED) {
1214 if (gimme == G_ARRAY)
1219 /* empty pattern special-cased to use last successful pattern if possible */
1220 if (!rx->prelen && PL_curpm) {
1225 if (rx->minlen > (I32)len)
1230 /* XXXX What part of this is needed with true \G-support? */
1231 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1233 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1234 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1235 if (mg && mg->mg_len >= 0) {
1236 if (!(rx->reganch & ROPT_GPOS_SEEN))
1237 rx->endp[0] = rx->startp[0] = mg->mg_len;
1238 else if (rx->reganch & ROPT_ANCH_GPOS) {
1239 r_flags |= REXEC_IGNOREPOS;
1240 rx->endp[0] = rx->startp[0] = mg->mg_len;
1242 minmatch = (mg->mg_flags & MGf_MINMATCH);
1243 update_minmatch = 0;
1247 if ((!global && rx->nparens)
1248 || SvTEMP(TARG) || PL_sawampersand)
1249 r_flags |= REXEC_COPY_STR;
1251 r_flags |= REXEC_SCREAM;
1254 if (global && rx->startp[0] != -1) {
1255 t = s = rx->endp[0] + truebase;
1256 if ((s + rx->minlen) > strend)
1258 if (update_minmatch++)
1259 minmatch = had_zerolen;
1261 if (rx->reganch & RE_USE_INTUIT &&
1262 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1263 /* FIXME - can PL_bostr be made const char *? */
1264 PL_bostr = (char *)truebase;
1265 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1269 if ( (rx->reganch & ROPT_CHECK_ALL)
1271 && ((rx->reganch & ROPT_NOSCAN)
1272 || !((rx->reganch & RE_INTUIT_TAIL)
1273 && (r_flags & REXEC_SCREAM)))
1274 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1277 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1280 if (dynpm->op_pmflags & PMf_ONCE)
1281 dynpm->op_pmdynflags |= PMdf_USED;
1290 RX_MATCH_TAINTED_on(rx);
1291 TAINT_IF(RX_MATCH_TAINTED(rx));
1292 if (gimme == G_ARRAY) {
1293 const I32 nparens = rx->nparens;
1294 I32 i = (global && !nparens) ? 1 : 0;
1296 SPAGAIN; /* EVAL blocks could move the stack. */
1297 EXTEND(SP, nparens + i);
1298 EXTEND_MORTAL(nparens + i);
1299 for (i = !i; i <= nparens; i++) {
1300 PUSHs(sv_newmortal());
1301 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1302 const I32 len = rx->endp[i] - rx->startp[i];
1303 s = rx->startp[i] + truebase;
1304 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1305 len < 0 || len > strend - s)
1306 DIE(aTHX_ "panic: pp_match start/end pointers");
1307 sv_setpvn(*SP, s, len);
1308 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1313 if (dynpm->op_pmflags & PMf_CONTINUE) {
1315 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1316 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1318 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1319 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1321 if (rx->startp[0] != -1) {
1322 mg->mg_len = rx->endp[0];
1323 if (rx->startp[0] == rx->endp[0])
1324 mg->mg_flags |= MGf_MINMATCH;
1326 mg->mg_flags &= ~MGf_MINMATCH;
1329 had_zerolen = (rx->startp[0] != -1
1330 && rx->startp[0] == rx->endp[0]);
1331 PUTBACK; /* EVAL blocks may use stack */
1332 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1337 LEAVE_SCOPE(oldsave);
1343 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1344 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1346 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1347 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1349 if (rx->startp[0] != -1) {
1350 mg->mg_len = rx->endp[0];
1351 if (rx->startp[0] == rx->endp[0])
1352 mg->mg_flags |= MGf_MINMATCH;
1354 mg->mg_flags &= ~MGf_MINMATCH;
1357 LEAVE_SCOPE(oldsave);
1361 yup: /* Confirmed by INTUIT */
1363 RX_MATCH_TAINTED_on(rx);
1364 TAINT_IF(RX_MATCH_TAINTED(rx));
1366 if (dynpm->op_pmflags & PMf_ONCE)
1367 dynpm->op_pmdynflags |= PMdf_USED;
1368 if (RX_MATCH_COPIED(rx))
1369 Safefree(rx->subbeg);
1370 RX_MATCH_COPIED_off(rx);
1371 rx->subbeg = Nullch;
1373 /* FIXME - should rx->subbeg be const char *? */
1374 rx->subbeg = (char *) truebase;
1375 rx->startp[0] = s - truebase;
1376 if (RX_MATCH_UTF8(rx)) {
1377 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1378 rx->endp[0] = t - truebase;
1381 rx->endp[0] = s - truebase + rx->minlen;
1383 rx->sublen = strend - truebase;
1386 if (PL_sawampersand) {
1388 #ifdef PERL_OLD_COPY_ON_WRITE
1389 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1391 PerlIO_printf(Perl_debug_log,
1392 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1393 (int) SvTYPE(TARG), truebase, t,
1396 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1397 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1398 assert (SvPOKp(rx->saved_copy));
1403 rx->subbeg = savepvn(t, strend - t);
1404 #ifdef PERL_OLD_COPY_ON_WRITE
1405 rx->saved_copy = Nullsv;
1408 rx->sublen = strend - t;
1409 RX_MATCH_COPIED_on(rx);
1410 off = rx->startp[0] = s - t;
1411 rx->endp[0] = off + rx->minlen;
1413 else { /* startp/endp are used by @- @+. */
1414 rx->startp[0] = s - truebase;
1415 rx->endp[0] = s - truebase + rx->minlen;
1417 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1418 LEAVE_SCOPE(oldsave);
1423 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1424 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1425 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1430 LEAVE_SCOPE(oldsave);
1431 if (gimme == G_ARRAY)
1437 Perl_do_readline(pTHX)
1439 dVAR; dSP; dTARGETSTACKED;
1444 register IO * const io = GvIO(PL_last_in_gv);
1445 register const I32 type = PL_op->op_type;
1446 const I32 gimme = GIMME_V;
1449 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1451 XPUSHs(SvTIED_obj((SV*)io, mg));
1454 call_method("READLINE", gimme);
1457 if (gimme == G_SCALAR) {
1459 SvSetSV_nosteal(TARG, result);
1468 if (IoFLAGS(io) & IOf_ARGV) {
1469 if (IoFLAGS(io) & IOf_START) {
1471 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1472 IoFLAGS(io) &= ~IOf_START;
1473 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1474 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1475 SvSETMAGIC(GvSV(PL_last_in_gv));
1480 fp = nextargv(PL_last_in_gv);
1481 if (!fp) { /* Note: fp != IoIFP(io) */
1482 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1485 else if (type == OP_GLOB)
1486 fp = Perl_start_glob(aTHX_ POPs, io);
1488 else if (type == OP_GLOB)
1490 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1491 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1495 if ((!io || !(IoFLAGS(io) & IOf_START))
1496 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1498 if (type == OP_GLOB)
1499 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1500 "glob failed (can't start child: %s)",
1503 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1505 if (gimme == G_SCALAR) {
1506 /* undef TARG, and push that undefined value */
1507 if (type != OP_RCATLINE) {
1508 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1516 if (gimme == G_SCALAR) {
1520 SvUPGRADE(sv, SVt_PV);
1521 tmplen = SvLEN(sv); /* remember if already alloced */
1522 if (!tmplen && !SvREADONLY(sv))
1523 Sv_Grow(sv, 80); /* try short-buffering it */
1525 if (type == OP_RCATLINE && SvOK(sv)) {
1527 SvPV_force_nolen(sv);
1533 sv = sv_2mortal(NEWSV(57, 80));
1537 /* This should not be marked tainted if the fp is marked clean */
1538 #define MAYBE_TAINT_LINE(io, sv) \
1539 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1544 /* delay EOF state for a snarfed empty file */
1545 #define SNARF_EOF(gimme,rs,io,sv) \
1546 (gimme != G_SCALAR || SvCUR(sv) \
1547 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1551 if (!sv_gets(sv, fp, offset)
1553 || SNARF_EOF(gimme, PL_rs, io, sv)
1554 || PerlIO_error(fp)))
1556 PerlIO_clearerr(fp);
1557 if (IoFLAGS(io) & IOf_ARGV) {
1558 fp = nextargv(PL_last_in_gv);
1561 (void)do_close(PL_last_in_gv, FALSE);
1563 else if (type == OP_GLOB) {
1564 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1565 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1566 "glob failed (child exited with status %d%s)",
1567 (int)(STATUS_CURRENT >> 8),
1568 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1571 if (gimme == G_SCALAR) {
1572 if (type != OP_RCATLINE) {
1573 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1579 MAYBE_TAINT_LINE(io, sv);
1582 MAYBE_TAINT_LINE(io, sv);
1584 IoFLAGS(io) |= IOf_NOLINE;
1588 if (type == OP_GLOB) {
1592 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1593 tmps = SvEND(sv) - 1;
1594 if (*tmps == *SvPVX_const(PL_rs)) {
1596 SvCUR_set(sv, SvCUR(sv) - 1);
1599 for (t1 = SvPVX_const(sv); *t1; t1++)
1600 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1601 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1603 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1604 (void)POPs; /* Unmatched wildcard? Chuck it... */
1607 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1608 const U8 *s = (const U8*)SvPVX_const(sv) + offset;
1609 const STRLEN len = SvCUR(sv) - offset;
1612 if (ckWARN(WARN_UTF8) &&
1613 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1614 /* Emulate :encoding(utf8) warning in the same case. */
1615 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1616 "utf8 \"\\x%02X\" does not map to Unicode",
1617 f < (U8*)SvEND(sv) ? *f : 0);
1619 if (gimme == G_ARRAY) {
1620 if (SvLEN(sv) - SvCUR(sv) > 20) {
1621 SvPV_shrink_to_cur(sv);
1623 sv = sv_2mortal(NEWSV(58, 80));
1626 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1627 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1628 const STRLEN new_len
1629 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1630 SvPV_renew(sv, new_len);
1639 register PERL_CONTEXT *cx;
1640 I32 gimme = OP_GIMME(PL_op, -1);
1643 if (cxstack_ix >= 0)
1644 gimme = cxstack[cxstack_ix].blk_gimme;
1652 PUSHBLOCK(cx, CXt_BLOCK, SP);
1664 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1665 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1667 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1670 if (SvTYPE(hv) == SVt_PVHV) {
1671 if (PL_op->op_private & OPpLVAL_INTRO) {
1674 /* does the element we're localizing already exist? */
1676 /* can we determine whether it exists? */
1678 || mg_find((SV*)hv, PERL_MAGIC_env)
1679 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1680 /* Try to preserve the existenceness of a tied hash
1681 * element by using EXISTS and DELETE if possible.
1682 * Fallback to FETCH and STORE otherwise */
1683 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1684 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1685 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1687 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1690 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1691 svp = he ? &HeVAL(he) : 0;
1697 if (!svp || *svp == &PL_sv_undef) {
1701 DIE(aTHX_ PL_no_helem_sv, keysv);
1703 lv = sv_newmortal();
1704 sv_upgrade(lv, SVt_PVLV);
1706 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1707 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1708 LvTARG(lv) = SvREFCNT_inc(hv);
1713 if (PL_op->op_private & OPpLVAL_INTRO) {
1714 if (HvNAME_get(hv) && isGV(*svp))
1715 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1719 const char * const key = SvPV_const(keysv, keylen);
1720 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1722 save_helem(hv, keysv, svp);
1725 else if (PL_op->op_private & OPpDEREF)
1726 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1728 sv = (svp ? *svp : &PL_sv_undef);
1729 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1730 * Pushing the magical RHS on to the stack is useless, since
1731 * that magic is soon destined to be misled by the local(),
1732 * and thus the later pp_sassign() will fail to mg_get() the
1733 * old value. This should also cure problems with delayed
1734 * mg_get()s. GSAR 98-07-03 */
1735 if (!lval && SvGMAGICAL(sv))
1736 sv = sv_mortalcopy(sv);
1744 register PERL_CONTEXT *cx;
1749 if (PL_op->op_flags & OPf_SPECIAL) {
1750 cx = &cxstack[cxstack_ix];
1751 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1756 gimme = OP_GIMME(PL_op, -1);
1758 if (cxstack_ix >= 0)
1759 gimme = cxstack[cxstack_ix].blk_gimme;
1765 if (gimme == G_VOID)
1767 else if (gimme == G_SCALAR) {
1771 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1774 *MARK = sv_mortalcopy(TOPs);
1777 *MARK = &PL_sv_undef;
1781 else if (gimme == G_ARRAY) {
1782 /* in case LEAVE wipes old return values */
1784 for (mark = newsp + 1; mark <= SP; mark++) {
1785 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1786 *mark = sv_mortalcopy(*mark);
1787 TAINT_NOT; /* Each item is independent */
1791 PL_curpm = newpm; /* Don't pop $1 et al till now */
1801 register PERL_CONTEXT *cx;
1807 cx = &cxstack[cxstack_ix];
1808 if (CxTYPE(cx) != CXt_LOOP)
1809 DIE(aTHX_ "panic: pp_iter");
1811 itersvp = CxITERVAR(cx);
1812 av = cx->blk_loop.iterary;
1813 if (SvTYPE(av) != SVt_PVAV) {
1814 /* iterate ($min .. $max) */
1815 if (cx->blk_loop.iterlval) {
1816 /* string increment */
1817 register SV* cur = cx->blk_loop.iterlval;
1819 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1820 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1821 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1822 /* safe to reuse old SV */
1823 sv_setsv(*itersvp, cur);
1827 /* we need a fresh SV every time so that loop body sees a
1828 * completely new SV for closures/references to work as
1831 *itersvp = newSVsv(cur);
1832 SvREFCNT_dec(oldsv);
1834 if (strEQ(SvPVX_const(cur), max))
1835 sv_setiv(cur, 0); /* terminate next time */
1842 /* integer increment */
1843 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1846 /* don't risk potential race */
1847 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1848 /* safe to reuse old SV */
1849 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1853 /* we need a fresh SV every time so that loop body sees a
1854 * completely new SV for closures/references to work as they
1857 *itersvp = newSViv(cx->blk_loop.iterix++);
1858 SvREFCNT_dec(oldsv);
1864 if (PL_op->op_private & OPpITER_REVERSED) {
1865 /* In reverse, use itermax as the min :-) */
1866 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1869 if (SvMAGICAL(av) || AvREIFY(av)) {
1870 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1877 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1881 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1885 if (SvMAGICAL(av) || AvREIFY(av)) {
1886 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1893 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1897 if (sv && SvREFCNT(sv) == 0) {
1899 Perl_croak(aTHX_ "Use of freed value in iteration");
1906 if (av != PL_curstack && sv == &PL_sv_undef) {
1907 SV *lv = cx->blk_loop.iterlval;
1908 if (lv && SvREFCNT(lv) > 1) {
1913 SvREFCNT_dec(LvTARG(lv));
1915 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1916 sv_upgrade(lv, SVt_PVLV);
1918 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1920 LvTARG(lv) = SvREFCNT_inc(av);
1921 LvTARGOFF(lv) = cx->blk_loop.iterix;
1922 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1927 *itersvp = SvREFCNT_inc(sv);
1928 SvREFCNT_dec(oldsv);
1936 register PMOP *pm = cPMOP;
1952 register REGEXP *rx = PM_GETRE(pm);
1954 int force_on_match = 0;
1955 I32 oldsave = PL_savestack_ix;
1957 bool doutf8 = FALSE;
1958 #ifdef PERL_OLD_COPY_ON_WRITE
1963 /* known replacement string? */
1964 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1965 if (PL_op->op_flags & OPf_STACKED)
1967 else if (PL_op->op_private & OPpTARGET_MY)
1974 #ifdef PERL_OLD_COPY_ON_WRITE
1975 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1976 because they make integers such as 256 "false". */
1977 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1980 sv_force_normal_flags(TARG,0);
1983 #ifdef PERL_OLD_COPY_ON_WRITE
1987 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1988 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1989 DIE(aTHX_ PL_no_modify);
1992 s = SvPV_mutable(TARG, len);
1993 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1995 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1996 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2001 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2005 DIE(aTHX_ "panic: pp_subst");
2008 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2009 maxiters = 2 * slen + 10; /* We can match twice at each
2010 position, once with zero-length,
2011 second time with non-zero. */
2013 if (!rx->prelen && PL_curpm) {
2017 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2018 ? REXEC_COPY_STR : 0;
2020 r_flags |= REXEC_SCREAM;
2023 if (rx->reganch & RE_USE_INTUIT) {
2025 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2029 /* How to do it in subst? */
2030 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2032 && ((rx->reganch & ROPT_NOSCAN)
2033 || !((rx->reganch & RE_INTUIT_TAIL)
2034 && (r_flags & REXEC_SCREAM))))
2039 /* only replace once? */
2040 once = !(rpm->op_pmflags & PMf_GLOBAL);
2042 /* known replacement string? */
2044 /* replacement needing upgrading? */
2045 if (DO_UTF8(TARG) && !doutf8) {
2046 nsv = sv_newmortal();
2049 sv_recode_to_utf8(nsv, PL_encoding);
2051 sv_utf8_upgrade(nsv);
2052 c = SvPV_const(nsv, clen);
2056 c = SvPV_const(dstr, clen);
2057 doutf8 = DO_UTF8(dstr);
2065 /* can do inplace substitution? */
2067 #ifdef PERL_OLD_COPY_ON_WRITE
2070 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2071 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2072 && (!doutf8 || SvUTF8(TARG))) {
2073 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2074 r_flags | REXEC_CHECKED))
2078 LEAVE_SCOPE(oldsave);
2081 #ifdef PERL_OLD_COPY_ON_WRITE
2082 if (SvIsCOW(TARG)) {
2083 assert (!force_on_match);
2087 if (force_on_match) {
2089 s = SvPV_force(TARG, len);
2094 SvSCREAM_off(TARG); /* disable possible screamer */
2096 rxtainted |= RX_MATCH_TAINTED(rx);
2097 m = orig + rx->startp[0];
2098 d = orig + rx->endp[0];
2100 if (m - s > strend - d) { /* faster to shorten from end */
2102 Copy(c, m, clen, char);
2107 Move(d, m, i, char);
2111 SvCUR_set(TARG, m - s);
2113 else if ((i = m - s)) { /* faster from front */
2121 Copy(c, m, clen, char);
2126 Copy(c, d, clen, char);
2131 TAINT_IF(rxtainted & 1);
2137 if (iters++ > maxiters)
2138 DIE(aTHX_ "Substitution loop");
2139 rxtainted |= RX_MATCH_TAINTED(rx);
2140 m = rx->startp[0] + orig;
2143 Move(s, d, i, char);
2147 Copy(c, d, clen, char);
2150 s = rx->endp[0] + orig;
2151 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2153 /* don't match same null twice */
2154 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2157 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2158 Move(s, d, i+1, char); /* include the NUL */
2160 TAINT_IF(rxtainted & 1);
2162 PUSHs(sv_2mortal(newSViv((I32)iters)));
2164 (void)SvPOK_only_UTF8(TARG);
2165 TAINT_IF(rxtainted);
2166 if (SvSMAGICAL(TARG)) {
2174 LEAVE_SCOPE(oldsave);
2178 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2179 r_flags | REXEC_CHECKED))
2181 if (force_on_match) {
2183 s = SvPV_force(TARG, len);
2186 #ifdef PERL_OLD_COPY_ON_WRITE
2189 rxtainted |= RX_MATCH_TAINTED(rx);
2190 dstr = newSVpvn(m, s-m);
2195 register PERL_CONTEXT *cx;
2197 (void)ReREFCNT_inc(rx);
2199 RETURNOP(cPMOP->op_pmreplroot);
2201 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2203 if (iters++ > maxiters)
2204 DIE(aTHX_ "Substitution loop");
2205 rxtainted |= RX_MATCH_TAINTED(rx);
2206 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2211 strend = s + (strend - m);
2213 m = rx->startp[0] + orig;
2214 if (doutf8 && !SvUTF8(dstr))
2215 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2217 sv_catpvn(dstr, s, m-s);
2218 s = rx->endp[0] + orig;
2220 sv_catpvn(dstr, c, clen);
2223 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2224 TARG, NULL, r_flags));
2225 if (doutf8 && !DO_UTF8(TARG))
2226 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2228 sv_catpvn(dstr, s, strend - s);
2230 #ifdef PERL_OLD_COPY_ON_WRITE
2231 /* The match may make the string COW. If so, brilliant, because that's
2232 just saved us one malloc, copy and free - the regexp has donated
2233 the old buffer, and we malloc an entirely new one, rather than the
2234 regexp malloc()ing a buffer and copying our original, only for
2235 us to throw it away here during the substitution. */
2236 if (SvIsCOW(TARG)) {
2237 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2243 SvPV_set(TARG, SvPVX(dstr));
2244 SvCUR_set(TARG, SvCUR(dstr));
2245 SvLEN_set(TARG, SvLEN(dstr));
2246 doutf8 |= DO_UTF8(dstr);
2247 SvPV_set(dstr, (char*)0);
2250 TAINT_IF(rxtainted & 1);
2252 PUSHs(sv_2mortal(newSViv((I32)iters)));
2254 (void)SvPOK_only(TARG);
2257 TAINT_IF(rxtainted);
2260 LEAVE_SCOPE(oldsave);
2269 LEAVE_SCOPE(oldsave);
2278 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2279 ++*PL_markstack_ptr;
2280 LEAVE; /* exit inner scope */
2283 if (PL_stack_base + *PL_markstack_ptr > SP) {
2285 I32 gimme = GIMME_V;
2287 LEAVE; /* exit outer scope */
2288 (void)POPMARK; /* pop src */
2289 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2290 (void)POPMARK; /* pop dst */
2291 SP = PL_stack_base + POPMARK; /* pop original mark */
2292 if (gimme == G_SCALAR) {
2293 if (PL_op->op_private & OPpGREP_LEX) {
2294 SV* sv = sv_newmortal();
2295 sv_setiv(sv, items);
2303 else if (gimme == G_ARRAY)
2310 ENTER; /* enter inner scope */
2313 src = PL_stack_base[*PL_markstack_ptr];
2315 if (PL_op->op_private & OPpGREP_LEX)
2316 PAD_SVl(PL_op->op_targ) = src;
2320 RETURNOP(cLOGOP->op_other);
2331 register PERL_CONTEXT *cx;
2335 cxstack_ix++; /* temporarily protect top context */
2338 if (gimme == G_SCALAR) {
2341 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2343 *MARK = SvREFCNT_inc(TOPs);
2348 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2350 *MARK = sv_mortalcopy(sv);
2355 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2359 *MARK = &PL_sv_undef;
2363 else if (gimme == G_ARRAY) {
2364 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2365 if (!SvTEMP(*MARK)) {
2366 *MARK = sv_mortalcopy(*MARK);
2367 TAINT_NOT; /* Each item is independent */
2375 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2376 PL_curpm = newpm; /* ... and pop $1 et al */
2379 return cx->blk_sub.retop;
2382 /* This duplicates the above code because the above code must not
2383 * get any slower by more conditions */
2391 register PERL_CONTEXT *cx;
2395 cxstack_ix++; /* temporarily protect top context */
2399 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2400 /* We are an argument to a function or grep().
2401 * This kind of lvalueness was legal before lvalue
2402 * subroutines too, so be backward compatible:
2403 * cannot report errors. */
2405 /* Scalar context *is* possible, on the LHS of -> only,
2406 * as in f()->meth(). But this is not an lvalue. */
2407 if (gimme == G_SCALAR)
2409 if (gimme == G_ARRAY) {
2410 if (!CvLVALUE(cx->blk_sub.cv))
2411 goto temporise_array;
2412 EXTEND_MORTAL(SP - newsp);
2413 for (mark = newsp + 1; mark <= SP; mark++) {
2416 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2417 *mark = sv_mortalcopy(*mark);
2419 /* Can be a localized value subject to deletion. */
2420 PL_tmps_stack[++PL_tmps_ix] = *mark;
2421 (void)SvREFCNT_inc(*mark);
2426 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2427 /* Here we go for robustness, not for speed, so we change all
2428 * the refcounts so the caller gets a live guy. Cannot set
2429 * TEMP, so sv_2mortal is out of question. */
2430 if (!CvLVALUE(cx->blk_sub.cv)) {
2436 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2438 if (gimme == G_SCALAR) {
2442 /* Temporaries are bad unless they happen to be elements
2443 * of a tied hash or array */
2444 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2445 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2451 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2452 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2453 : "a readonly value" : "a temporary");
2455 else { /* Can be a localized value
2456 * subject to deletion. */
2457 PL_tmps_stack[++PL_tmps_ix] = *mark;
2458 (void)SvREFCNT_inc(*mark);
2461 else { /* Should not happen? */
2467 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2468 (MARK > SP ? "Empty array" : "Array"));
2472 else if (gimme == G_ARRAY) {
2473 EXTEND_MORTAL(SP - newsp);
2474 for (mark = newsp + 1; mark <= SP; mark++) {
2475 if (*mark != &PL_sv_undef
2476 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2477 /* Might be flattened array after $#array = */
2484 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2485 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2488 /* Can be a localized value subject to deletion. */
2489 PL_tmps_stack[++PL_tmps_ix] = *mark;
2490 (void)SvREFCNT_inc(*mark);
2496 if (gimme == G_SCALAR) {
2500 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2502 *MARK = SvREFCNT_inc(TOPs);
2507 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2509 *MARK = sv_mortalcopy(sv);
2514 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2518 *MARK = &PL_sv_undef;
2522 else if (gimme == G_ARRAY) {
2524 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2525 if (!SvTEMP(*MARK)) {
2526 *MARK = sv_mortalcopy(*MARK);
2527 TAINT_NOT; /* Each item is independent */
2536 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2537 PL_curpm = newpm; /* ... and pop $1 et al */
2540 return cx->blk_sub.retop;
2545 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2547 SV *dbsv = GvSVn(PL_DBsub);
2550 if (!PERLDB_SUB_NN) {
2553 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2554 || strEQ(GvNAME(gv), "END")
2555 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2556 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2557 && (gv = (GV*)*svp) ))) {
2558 /* Use GV from the stack as a fallback. */
2559 /* GV is potentially non-unique, or contain different CV. */
2560 SV *tmp = newRV((SV*)cv);
2561 sv_setsv(dbsv, tmp);
2565 gv_efullname3(dbsv, gv, Nullch);
2569 const int type = SvTYPE(dbsv);
2570 if (type < SVt_PVIV && type != SVt_IV)
2571 sv_upgrade(dbsv, SVt_PVIV);
2572 (void)SvIOK_on(dbsv);
2573 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2577 PL_curcopdb = PL_curcop;
2578 cv = GvCV(PL_DBsub);
2588 register PERL_CONTEXT *cx;
2590 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2593 DIE(aTHX_ "Not a CODE reference");
2594 switch (SvTYPE(sv)) {
2595 /* This is overwhelming the most common case: */
2597 if (!(cv = GvCVu((GV*)sv)))
2598 cv = sv_2cv(sv, &stash, &gv, FALSE);
2608 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2610 SP = PL_stack_base + POPMARK;
2613 if (SvGMAGICAL(sv)) {
2617 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2620 sym = SvPV_nolen_const(sv);
2623 DIE(aTHX_ PL_no_usym, "a subroutine");
2624 if (PL_op->op_private & HINT_STRICT_REFS)
2625 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2626 cv = get_cv(sym, TRUE);
2631 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2632 tryAMAGICunDEREF(to_cv);
2635 if (SvTYPE(cv) == SVt_PVCV)
2640 DIE(aTHX_ "Not a CODE reference");
2641 /* This is the second most common case: */
2651 if (!CvROOT(cv) && !CvXSUB(cv)) {
2656 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2657 if (CvASSERTION(cv) && PL_DBassertion)
2658 sv_setiv(PL_DBassertion, 1);
2660 cv = get_db_sub(&sv, cv);
2661 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2662 DIE(aTHX_ "No DB::sub routine defined");
2665 if (!(CvXSUB(cv))) {
2666 /* This path taken at least 75% of the time */
2668 register I32 items = SP - MARK;
2669 AV* padlist = CvPADLIST(cv);
2670 PUSHBLOCK(cx, CXt_SUB, MARK);
2672 cx->blk_sub.retop = PL_op->op_next;
2674 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2675 * that eval'' ops within this sub know the correct lexical space.
2676 * Owing the speed considerations, we choose instead to search for
2677 * the cv using find_runcv() when calling doeval().
2679 if (CvDEPTH(cv) >= 2) {
2680 PERL_STACK_OVERFLOW_CHECK();
2681 pad_push(padlist, CvDEPTH(cv));
2684 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2689 DEBUG_S(PerlIO_printf(Perl_debug_log,
2690 "%p entersub preparing @_\n", thr));
2692 av = (AV*)PAD_SVl(0);
2694 /* @_ is normally not REAL--this should only ever
2695 * happen when DB::sub() calls things that modify @_ */
2700 cx->blk_sub.savearray = GvAV(PL_defgv);
2701 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2702 CX_CURPAD_SAVE(cx->blk_sub);
2703 cx->blk_sub.argarray = av;
2706 if (items > AvMAX(av) + 1) {
2707 SV **ary = AvALLOC(av);
2708 if (AvARRAY(av) != ary) {
2709 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2710 SvPV_set(av, (char*)ary);
2712 if (items > AvMAX(av) + 1) {
2713 AvMAX(av) = items - 1;
2714 Renew(ary,items,SV*);
2716 SvPV_set(av, (char*)ary);
2719 Copy(MARK,AvARRAY(av),items,SV*);
2720 AvFILLp(av) = items - 1;
2728 /* warning must come *after* we fully set up the context
2729 * stuff so that __WARN__ handlers can safely dounwind()
2732 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2733 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2734 sub_crush_depth(cv);
2736 DEBUG_S(PerlIO_printf(Perl_debug_log,
2737 "%p entersub returning %p\n", thr, CvSTART(cv)));
2739 RETURNOP(CvSTART(cv));
2742 #ifdef PERL_XSUB_OLDSTYLE
2743 if (CvOLDSTYLE(cv)) {
2744 I32 (*fp3)(int,int,int);
2746 register I32 items = SP - MARK;
2747 /* We dont worry to copy from @_. */
2752 PL_stack_sp = mark + 1;
2753 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2754 items = (*fp3)(CvXSUBANY(cv).any_i32,
2755 MARK - PL_stack_base + 1,
2757 PL_stack_sp = PL_stack_base + items;
2760 #endif /* PERL_XSUB_OLDSTYLE */
2762 I32 markix = TOPMARK;
2767 /* Need to copy @_ to stack. Alternative may be to
2768 * switch stack to @_, and copy return values
2769 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2770 AV * const av = GvAV(PL_defgv);
2771 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2774 /* Mark is at the end of the stack. */
2776 Copy(AvARRAY(av), SP + 1, items, SV*);
2781 /* We assume first XSUB in &DB::sub is the called one. */
2783 SAVEVPTR(PL_curcop);
2784 PL_curcop = PL_curcopdb;
2787 /* Do we need to open block here? XXXX */
2788 (void)(*CvXSUB(cv))(aTHX_ cv);
2790 /* Enforce some sanity in scalar context. */
2791 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2792 if (markix > PL_stack_sp - PL_stack_base)
2793 *(PL_stack_base + markix) = &PL_sv_undef;
2795 *(PL_stack_base + markix) = *PL_stack_sp;
2796 PL_stack_sp = PL_stack_base + markix;
2804 assert (0); /* Cannot get here. */
2805 /* This is deliberately moved here as spaghetti code to keep it out of the
2812 /* anonymous or undef'd function leaves us no recourse */
2813 if (CvANON(cv) || !(gv = CvGV(cv)))
2814 DIE(aTHX_ "Undefined subroutine called");
2816 /* autoloaded stub? */
2817 if (cv != GvCV(gv)) {
2820 /* should call AUTOLOAD now? */
2823 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2830 sub_name = sv_newmortal();
2831 gv_efullname3(sub_name, gv, Nullch);
2832 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2836 DIE(aTHX_ "Not a CODE reference");
2842 Perl_sub_crush_depth(pTHX_ CV *cv)
2845 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2847 SV* const tmpstr = sv_newmortal();
2848 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2849 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2858 SV* const elemsv = POPs;
2859 IV elem = SvIV(elemsv);
2861 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2862 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2865 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2866 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2868 elem -= PL_curcop->cop_arybase;
2869 if (SvTYPE(av) != SVt_PVAV)
2871 svp = av_fetch(av, elem, lval && !defer);
2873 #ifdef PERL_MALLOC_WRAP
2874 if (SvUOK(elemsv)) {
2875 const UV uv = SvUV(elemsv);
2876 elem = uv > IV_MAX ? IV_MAX : uv;
2878 else if (SvNOK(elemsv))
2879 elem = (IV)SvNV(elemsv);
2881 static const char oom_array_extend[] =
2882 "Out of memory during array extend"; /* Duplicated in av.c */
2883 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2886 if (!svp || *svp == &PL_sv_undef) {
2889 DIE(aTHX_ PL_no_aelem, elem);
2890 lv = sv_newmortal();
2891 sv_upgrade(lv, SVt_PVLV);
2893 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2894 LvTARG(lv) = SvREFCNT_inc(av);
2895 LvTARGOFF(lv) = elem;
2900 if (PL_op->op_private & OPpLVAL_INTRO)
2901 save_aelem(av, elem, svp);
2902 else if (PL_op->op_private & OPpDEREF)
2903 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2905 sv = (svp ? *svp : &PL_sv_undef);
2906 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2907 sv = sv_mortalcopy(sv);
2913 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2918 Perl_croak(aTHX_ PL_no_modify);
2919 if (SvTYPE(sv) < SVt_RV)
2920 sv_upgrade(sv, SVt_RV);
2921 else if (SvTYPE(sv) >= SVt_PV) {
2928 SvRV_set(sv, NEWSV(355,0));
2931 SvRV_set(sv, (SV*)newAV());
2934 SvRV_set(sv, (SV*)newHV());
2945 SV* const sv = TOPs;
2948 SV* const rsv = SvRV(sv);
2949 if (SvTYPE(rsv) == SVt_PVCV) {
2955 SETs(method_common(sv, Null(U32*)));
2962 SV* const sv = cSVOP_sv;
2963 U32 hash = SvSHARED_HASH(sv);
2965 XPUSHs(method_common(sv, &hash));
2970 S_method_common(pTHX_ SV* meth, U32* hashp)
2976 const char* packname = Nullch;
2977 SV *packsv = Nullsv;
2979 const char * const name = SvPV_const(meth, namelen);
2980 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2983 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2991 /* this isn't a reference */
2992 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2993 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2995 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3002 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3003 !(ob=(SV*)GvIO(iogv)))
3005 /* this isn't the name of a filehandle either */
3007 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3008 ? !isIDFIRST_utf8((U8*)packname)
3009 : !isIDFIRST(*packname)
3012 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3013 SvOK(sv) ? "without a package or object reference"
3014 : "on an undefined value");
3016 /* assume it's a package name */
3017 stash = gv_stashpvn(packname, packlen, FALSE);
3021 SV* ref = newSViv(PTR2IV(stash));
3022 hv_store(PL_stashcache, packname, packlen, ref, 0);
3026 /* it _is_ a filehandle name -- replace with a reference */
3027 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3030 /* if we got here, ob should be a reference or a glob */
3031 if (!ob || !(SvOBJECT(ob)
3032 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3035 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3039 stash = SvSTASH(ob);
3042 /* NOTE: stash may be null, hope hv_fetch_ent and
3043 gv_fetchmethod can cope (it seems they can) */
3045 /* shortcut for simple names */
3047 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3049 gv = (GV*)HeVAL(he);
3050 if (isGV(gv) && GvCV(gv) &&
3051 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3052 return (SV*)GvCV(gv);
3056 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3059 /* This code tries to figure out just what went wrong with
3060 gv_fetchmethod. It therefore needs to duplicate a lot of
3061 the internals of that function. We can't move it inside
3062 Perl_gv_fetchmethod_autoload(), however, since that would
3063 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3066 const char* leaf = name;
3067 const char* sep = Nullch;
3070 for (p = name; *p; p++) {
3072 sep = p, leaf = p + 1;
3073 else if (*p == ':' && *(p + 1) == ':')
3074 sep = p, leaf = p + 2;
3076 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3077 /* the method name is unqualified or starts with SUPER:: */
3078 bool need_strlen = 1;
3080 packname = CopSTASHPV(PL_curcop);
3083 HEK * const packhek = HvNAME_HEK(stash);
3085 packname = HEK_KEY(packhek);
3086 packlen = HEK_LEN(packhek);
3096 "Can't use anonymous symbol table for method lookup");
3098 else if (need_strlen)
3099 packlen = strlen(packname);
3103 /* the method name is qualified */
3105 packlen = sep - name;
3108 /* we're relying on gv_fetchmethod not autovivifying the stash */
3109 if (gv_stashpvn(packname, packlen, FALSE)) {
3111 "Can't locate object method \"%s\" via package \"%.*s\"",
3112 leaf, (int)packlen, packname);
3116 "Can't locate object method \"%s\" via package \"%.*s\""
3117 " (perhaps you forgot to load \"%.*s\"?)",
3118 leaf, (int)packlen, packname, (int)packlen, packname);
3121 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3126 * c-indentation-style: bsd
3128 * indent-tabs-mode: t
3131 * ex: set ts=8 sts=4 sw=4 noet: