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 */
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 */
335 if (!sv || !SvANY(sv)) {
337 RETURNOP(cLOGOP->op_other);
340 switch (SvTYPE(sv)) {
342 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
346 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
350 if (CvROOT(sv) || CvXSUB(sv))
361 RETURNOP(cLOGOP->op_other);
366 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
367 useleft = USE_LEFT(TOPm1s);
368 #ifdef PERL_PRESERVE_IVUV
369 /* We must see if we can perform the addition with integers if possible,
370 as the integer code detects overflow while the NV code doesn't.
371 If either argument hasn't had a numeric conversion yet attempt to get
372 the IV. It's important to do this now, rather than just assuming that
373 it's not IOK as a PV of "9223372036854775806" may not take well to NV
374 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
375 integer in case the second argument is IV=9223372036854775806
376 We can (now) rely on sv_2iv to do the right thing, only setting the
377 public IOK flag if the value in the NV (or PV) slot is truly integer.
379 A side effect is that this also aggressively prefers integer maths over
380 fp maths for integer values.
382 How to detect overflow?
384 C 99 section 6.2.6.1 says
386 The range of nonnegative values of a signed integer type is a subrange
387 of the corresponding unsigned integer type, and the representation of
388 the same value in each type is the same. A computation involving
389 unsigned operands can never overflow, because a result that cannot be
390 represented by the resulting unsigned integer type is reduced modulo
391 the number that is one greater than the largest value that can be
392 represented by the resulting type.
396 which I read as "unsigned ints wrap."
398 signed integer overflow seems to be classed as "exception condition"
400 If an exceptional condition occurs during the evaluation of an
401 expression (that is, if the result is not mathematically defined or not
402 in the range of representable values for its type), the behavior is
405 (6.5, the 5th paragraph)
407 I had assumed that on 2s complement machines signed arithmetic would
408 wrap, hence coded pp_add and pp_subtract on the assumption that
409 everything perl builds on would be happy. After much wailing and
410 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
411 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
412 unsigned code below is actually shorter than the old code. :-)
417 /* Unless the left argument is integer in range we are going to have to
418 use NV maths. Hence only attempt to coerce the right argument if
419 we know the left is integer. */
427 /* left operand is undef, treat as zero. + 0 is identity,
428 Could SETi or SETu right now, but space optimise by not adding
429 lots of code to speed up what is probably a rarish case. */
431 /* Left operand is defined, so is it IV? */
434 if ((auvok = SvUOK(TOPm1s)))
437 register IV aiv = SvIVX(TOPm1s);
440 auvok = 1; /* Now acting as a sign flag. */
441 } else { /* 2s complement assumption for IV_MIN */
449 bool result_good = 0;
452 bool buvok = SvUOK(TOPs);
457 register IV biv = SvIVX(TOPs);
464 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
465 else "IV" now, independent of how it came in.
466 if a, b represents positive, A, B negative, a maps to -A etc
471 all UV maths. negate result if A negative.
472 add if signs same, subtract if signs differ. */
478 /* Must get smaller */
484 /* result really should be -(auv-buv). as its negation
485 of true value, need to swap our result flag */
502 if (result <= (UV)IV_MIN)
505 /* result valid, but out of range for IV. */
510 } /* Overflow, drop through to NVs. */
517 /* left operand is undef, treat as zero. + 0.0 is identity. */
521 SETn( value + TOPn );
529 AV *av = PL_op->op_flags & OPf_SPECIAL ?
530 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
531 U32 lval = PL_op->op_flags & OPf_MOD;
532 SV** svp = av_fetch(av, PL_op->op_private, lval);
533 SV *sv = (svp ? *svp : &PL_sv_undef);
535 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
536 sv = sv_mortalcopy(sv);
545 do_join(TARG, *MARK, MARK, SP);
556 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
557 * will be enough to hold an OP*.
559 SV* sv = sv_newmortal();
560 sv_upgrade(sv, SVt_PVLV);
562 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
570 /* Oversized hot code. */
574 dVAR; dSP; dMARK; dORIGMARK;
580 if (PL_op->op_flags & OPf_STACKED)
585 if (gv && (io = GvIO(gv))
586 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
589 if (MARK == ORIGMARK) {
590 /* If using default handle then we need to make space to
591 * pass object as 1st arg, so move other args up ...
595 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
599 *MARK = SvTIED_obj((SV*)io, mg);
602 call_method("PRINT", G_SCALAR);
610 if (!(io = GvIO(gv))) {
611 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
612 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
614 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
615 report_evil_fh(gv, io, PL_op->op_type);
616 SETERRNO(EBADF,RMS_IFI);
619 else if (!(fp = IoOFP(io))) {
620 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
622 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
623 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
624 report_evil_fh(gv, io, PL_op->op_type);
626 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
631 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
633 if (!do_print(*MARK, fp))
637 if (!do_print(PL_ofs_sv, fp)) { /* $, */
646 if (!do_print(*MARK, fp))
654 if (PL_ors_sv && SvOK(PL_ors_sv))
655 if (!do_print(PL_ors_sv, fp)) /* $\ */
658 if (IoFLAGS(io) & IOf_FLUSH)
659 if (PerlIO_flush(fp) == EOF)
680 tryAMAGICunDEREF(to_av);
683 if (SvTYPE(av) != SVt_PVAV)
684 DIE(aTHX_ "Not an ARRAY reference");
685 if (PL_op->op_flags & OPf_REF) {
690 if (GIMME == G_SCALAR)
691 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
695 else if (PL_op->op_flags & OPf_MOD
696 && PL_op->op_private & OPpLVAL_INTRO)
697 Perl_croak(aTHX_ PL_no_localize_ref);
700 if (SvTYPE(sv) == SVt_PVAV) {
702 if (PL_op->op_flags & OPf_REF) {
707 if (GIMME == G_SCALAR)
708 Perl_croak(aTHX_ "Can't return array to lvalue"
717 if (SvTYPE(sv) != SVt_PVGV) {
718 if (SvGMAGICAL(sv)) {
724 if (PL_op->op_flags & OPf_REF ||
725 PL_op->op_private & HINT_STRICT_REFS)
726 DIE(aTHX_ PL_no_usym, "an ARRAY");
727 if (ckWARN(WARN_UNINITIALIZED))
729 if (GIMME == G_ARRAY) {
735 if ((PL_op->op_flags & OPf_SPECIAL) &&
736 !(PL_op->op_flags & OPf_MOD))
738 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
740 && (!is_gv_magical_sv(sv,0)
741 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
747 if (PL_op->op_private & HINT_STRICT_REFS)
748 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
749 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
756 if (PL_op->op_private & OPpLVAL_INTRO)
758 if (PL_op->op_flags & OPf_REF) {
763 if (GIMME == G_SCALAR)
764 Perl_croak(aTHX_ "Can't return array to lvalue"
772 if (GIMME == G_ARRAY) {
773 I32 maxarg = AvFILL(av) + 1;
774 (void)POPs; /* XXXX May be optimized away? */
776 if (SvRMAGICAL(av)) {
778 for (i=0; i < (U32)maxarg; i++) {
779 SV **svp = av_fetch(av, i, FALSE);
780 /* See note in pp_helem, and bug id #27839 */
782 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
787 Copy(AvARRAY(av), SP+1, maxarg, SV*);
791 else if (GIMME_V == G_SCALAR) {
793 I32 maxarg = AvFILL(av) + 1;
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_ "Can't return hash to lvalue scalar context");
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_ "Can't return hash to lvalue"
844 if (SvTYPE(sv) != SVt_PVGV) {
845 if (SvGMAGICAL(sv)) {
851 if (PL_op->op_flags & OPf_REF ||
852 PL_op->op_private & HINT_STRICT_REFS)
853 DIE(aTHX_ PL_no_usym, "a HASH");
854 if (ckWARN(WARN_UNINITIALIZED))
856 if (gimme == G_ARRAY) {
862 if ((PL_op->op_flags & OPf_SPECIAL) &&
863 !(PL_op->op_flags & OPf_MOD))
865 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
867 && (!is_gv_magical_sv(sv,0)
868 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
874 if (PL_op->op_private & HINT_STRICT_REFS)
875 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
876 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
883 if (PL_op->op_private & OPpLVAL_INTRO)
885 if (PL_op->op_flags & OPf_REF) {
890 if (gimme != G_ARRAY)
891 Perl_croak(aTHX_ "Can't return hash to lvalue"
899 if (gimme == G_ARRAY) { /* array wanted */
900 *PL_stack_sp = (SV*)hv;
903 else if (gimme == G_SCALAR) {
905 TARG = Perl_hv_scalar(aTHX_ hv);
912 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
918 if (ckWARN(WARN_MISC)) {
919 if (relem == firstrelem &&
921 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
922 SvTYPE(SvRV(*relem)) == SVt_PVHV))
924 Perl_warner(aTHX_ packWARN(WARN_MISC),
925 "Reference found where even-sized list expected");
928 Perl_warner(aTHX_ packWARN(WARN_MISC),
929 "Odd number of elements in hash assignment");
932 tmpstr = NEWSV(29,0);
933 didstore = hv_store_ent(hash,*relem,tmpstr,0);
934 if (SvMAGICAL(hash)) {
935 if (SvSMAGICAL(tmpstr))
947 SV **lastlelem = PL_stack_sp;
948 SV **lastrelem = PL_stack_base + POPMARK;
949 SV **firstrelem = PL_stack_base + POPMARK + 1;
950 SV **firstlelem = lastrelem + 1;
963 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
966 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
969 /* If there's a common identifier on both sides we have to take
970 * special care that assigning the identifier on the left doesn't
971 * clobber a value on the right that's used later in the list.
973 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
974 EXTEND_MORTAL(lastrelem - firstrelem + 1);
975 for (relem = firstrelem; relem <= lastrelem; relem++) {
978 TAINT_NOT; /* Each item is independent */
979 *relem = sv_mortalcopy(sv);
989 while (lelem <= lastlelem) {
990 TAINT_NOT; /* Each item stands on its own, taintwise. */
992 switch (SvTYPE(sv)) {
995 magic = SvMAGICAL(ary) != 0;
997 av_extend(ary, lastrelem - relem);
999 while (relem <= lastrelem) { /* gobble up all the rest */
1002 sv = newSVsv(*relem);
1004 didstore = av_store(ary,i++,sv);
1014 case SVt_PVHV: { /* normal hash */
1018 magic = SvMAGICAL(hash) != 0;
1020 firsthashrelem = relem;
1022 while (relem < lastrelem) { /* gobble up all the rest */
1027 sv = &PL_sv_no, relem++;
1028 tmpstr = NEWSV(29,0);
1030 sv_setsv(tmpstr,*relem); /* value */
1031 *(relem++) = tmpstr;
1032 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1033 /* key overwrites an existing entry */
1035 didstore = hv_store_ent(hash,sv,tmpstr,0);
1037 if (SvSMAGICAL(tmpstr))
1044 if (relem == lastrelem) {
1045 do_oddball(hash, relem, firstrelem);
1051 if (SvIMMORTAL(sv)) {
1052 if (relem <= lastrelem)
1056 if (relem <= lastrelem) {
1057 sv_setsv(sv, *relem);
1061 sv_setsv(sv, &PL_sv_undef);
1066 if (PL_delaymagic & ~DM_DELAY) {
1067 if (PL_delaymagic & DM_UID) {
1068 #ifdef HAS_SETRESUID
1069 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1070 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1073 # ifdef HAS_SETREUID
1074 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1075 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1078 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1079 (void)setruid(PL_uid);
1080 PL_delaymagic &= ~DM_RUID;
1082 # endif /* HAS_SETRUID */
1084 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1085 (void)seteuid(PL_euid);
1086 PL_delaymagic &= ~DM_EUID;
1088 # endif /* HAS_SETEUID */
1089 if (PL_delaymagic & DM_UID) {
1090 if (PL_uid != PL_euid)
1091 DIE(aTHX_ "No setreuid available");
1092 (void)PerlProc_setuid(PL_uid);
1094 # endif /* HAS_SETREUID */
1095 #endif /* HAS_SETRESUID */
1096 PL_uid = PerlProc_getuid();
1097 PL_euid = PerlProc_geteuid();
1099 if (PL_delaymagic & DM_GID) {
1100 #ifdef HAS_SETRESGID
1101 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1102 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1105 # ifdef HAS_SETREGID
1106 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1107 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1110 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1111 (void)setrgid(PL_gid);
1112 PL_delaymagic &= ~DM_RGID;
1114 # endif /* HAS_SETRGID */
1116 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1117 (void)setegid(PL_egid);
1118 PL_delaymagic &= ~DM_EGID;
1120 # endif /* HAS_SETEGID */
1121 if (PL_delaymagic & DM_GID) {
1122 if (PL_gid != PL_egid)
1123 DIE(aTHX_ "No setregid available");
1124 (void)PerlProc_setgid(PL_gid);
1126 # endif /* HAS_SETREGID */
1127 #endif /* HAS_SETRESGID */
1128 PL_gid = PerlProc_getgid();
1129 PL_egid = PerlProc_getegid();
1131 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1135 if (gimme == G_VOID)
1136 SP = firstrelem - 1;
1137 else if (gimme == G_SCALAR) {
1140 SETi(lastrelem - firstrelem + 1 - duplicates);
1147 /* Removes from the stack the entries which ended up as
1148 * duplicated keys in the hash (fix for [perl #24380]) */
1149 Move(firsthashrelem + duplicates,
1150 firsthashrelem, duplicates, SV**);
1151 lastrelem -= duplicates;
1156 SP = firstrelem + (lastlelem - firstlelem);
1157 lelem = firstlelem + (relem - firstrelem);
1159 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1167 register PMOP *pm = cPMOP;
1168 SV *rv = sv_newmortal();
1169 SV *sv = newSVrv(rv, "Regexp");
1170 if (pm->op_pmdynflags & PMdf_TAINTED)
1172 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1179 register PMOP *pm = cPMOP;
1185 I32 r_flags = REXEC_CHECKED;
1186 char *truebase; /* Start of string */
1187 register REGEXP *rx = PM_GETRE(pm);
1192 I32 oldsave = PL_savestack_ix;
1193 I32 update_minmatch = 1;
1194 I32 had_zerolen = 0;
1196 if (PL_op->op_flags & OPf_STACKED)
1198 else if (PL_op->op_private & OPpTARGET_MY)
1205 PUTBACK; /* EVAL blocks need stack_sp. */
1206 s = SvPV(TARG, len);
1209 DIE(aTHX_ "panic: pp_match");
1210 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1211 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1214 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1216 /* PMdf_USED is set after a ?? matches once */
1217 if (pm->op_pmdynflags & PMdf_USED) {
1219 if (gimme == G_ARRAY)
1224 /* empty pattern special-cased to use last successful pattern if possible */
1225 if (!rx->prelen && PL_curpm) {
1230 if (rx->minlen > (I32)len)
1235 /* XXXX What part of this is needed with true \G-support? */
1236 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1238 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1239 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1240 if (mg && mg->mg_len >= 0) {
1241 if (!(rx->reganch & ROPT_GPOS_SEEN))
1242 rx->endp[0] = rx->startp[0] = mg->mg_len;
1243 else if (rx->reganch & ROPT_ANCH_GPOS) {
1244 r_flags |= REXEC_IGNOREPOS;
1245 rx->endp[0] = rx->startp[0] = mg->mg_len;
1247 minmatch = (mg->mg_flags & MGf_MINMATCH);
1248 update_minmatch = 0;
1252 if ((!global && rx->nparens)
1253 || SvTEMP(TARG) || PL_sawampersand)
1254 r_flags |= REXEC_COPY_STR;
1256 r_flags |= REXEC_SCREAM;
1259 if (global && rx->startp[0] != -1) {
1260 t = s = rx->endp[0] + truebase;
1261 if ((s + rx->minlen) > strend)
1263 if (update_minmatch++)
1264 minmatch = had_zerolen;
1266 if (rx->reganch & RE_USE_INTUIT &&
1267 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1268 PL_bostr = truebase;
1269 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1273 if ( (rx->reganch & ROPT_CHECK_ALL)
1275 && ((rx->reganch & ROPT_NOSCAN)
1276 || !((rx->reganch & RE_INTUIT_TAIL)
1277 && (r_flags & REXEC_SCREAM)))
1278 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1281 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1284 if (dynpm->op_pmflags & PMf_ONCE)
1285 dynpm->op_pmdynflags |= PMdf_USED;
1294 RX_MATCH_TAINTED_on(rx);
1295 TAINT_IF(RX_MATCH_TAINTED(rx));
1296 if (gimme == G_ARRAY) {
1297 I32 nparens, i, len;
1299 nparens = rx->nparens;
1300 if (global && !nparens)
1304 SPAGAIN; /* EVAL blocks could move the stack. */
1305 EXTEND(SP, nparens + i);
1306 EXTEND_MORTAL(nparens + i);
1307 for (i = !i; i <= nparens; i++) {
1308 PUSHs(sv_newmortal());
1310 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1311 len = rx->endp[i] - rx->startp[i];
1312 s = rx->startp[i] + truebase;
1313 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1314 len < 0 || len > strend - s)
1315 DIE(aTHX_ "panic: pp_match start/end pointers");
1316 sv_setpvn(*SP, s, len);
1317 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1322 if (dynpm->op_pmflags & PMf_CONTINUE) {
1324 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1325 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1327 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1328 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1330 if (rx->startp[0] != -1) {
1331 mg->mg_len = rx->endp[0];
1332 if (rx->startp[0] == rx->endp[0])
1333 mg->mg_flags |= MGf_MINMATCH;
1335 mg->mg_flags &= ~MGf_MINMATCH;
1338 had_zerolen = (rx->startp[0] != -1
1339 && rx->startp[0] == rx->endp[0]);
1340 PUTBACK; /* EVAL blocks may use stack */
1341 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1346 LEAVE_SCOPE(oldsave);
1352 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1353 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1355 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1356 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1358 if (rx->startp[0] != -1) {
1359 mg->mg_len = rx->endp[0];
1360 if (rx->startp[0] == rx->endp[0])
1361 mg->mg_flags |= MGf_MINMATCH;
1363 mg->mg_flags &= ~MGf_MINMATCH;
1366 LEAVE_SCOPE(oldsave);
1370 yup: /* Confirmed by INTUIT */
1372 RX_MATCH_TAINTED_on(rx);
1373 TAINT_IF(RX_MATCH_TAINTED(rx));
1375 if (dynpm->op_pmflags & PMf_ONCE)
1376 dynpm->op_pmdynflags |= PMdf_USED;
1377 if (RX_MATCH_COPIED(rx))
1378 Safefree(rx->subbeg);
1379 RX_MATCH_COPIED_off(rx);
1380 rx->subbeg = Nullch;
1382 rx->subbeg = truebase;
1383 rx->startp[0] = s - truebase;
1384 if (RX_MATCH_UTF8(rx)) {
1385 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1386 rx->endp[0] = t - truebase;
1389 rx->endp[0] = s - truebase + rx->minlen;
1391 rx->sublen = strend - truebase;
1394 if (PL_sawampersand) {
1396 #ifdef PERL_COPY_ON_WRITE
1397 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1399 PerlIO_printf(Perl_debug_log,
1400 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1401 (int) SvTYPE(TARG), truebase, t,
1404 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1405 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1406 assert (SvPOKp(rx->saved_copy));
1411 rx->subbeg = savepvn(t, strend - t);
1412 #ifdef PERL_COPY_ON_WRITE
1413 rx->saved_copy = Nullsv;
1416 rx->sublen = strend - t;
1417 RX_MATCH_COPIED_on(rx);
1418 off = rx->startp[0] = s - t;
1419 rx->endp[0] = off + rx->minlen;
1421 else { /* startp/endp are used by @- @+. */
1422 rx->startp[0] = s - truebase;
1423 rx->endp[0] = s - truebase + rx->minlen;
1425 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1426 LEAVE_SCOPE(oldsave);
1431 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1432 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1433 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1438 LEAVE_SCOPE(oldsave);
1439 if (gimme == G_ARRAY)
1445 Perl_do_readline(pTHX)
1447 dVAR; dSP; dTARGETSTACKED;
1452 register IO *io = GvIO(PL_last_in_gv);
1453 register I32 type = PL_op->op_type;
1454 I32 gimme = GIMME_V;
1457 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1459 XPUSHs(SvTIED_obj((SV*)io, mg));
1462 call_method("READLINE", gimme);
1465 if (gimme == G_SCALAR) {
1467 SvSetSV_nosteal(TARG, result);
1476 if (IoFLAGS(io) & IOf_ARGV) {
1477 if (IoFLAGS(io) & IOf_START) {
1479 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1480 IoFLAGS(io) &= ~IOf_START;
1481 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1482 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1483 SvSETMAGIC(GvSV(PL_last_in_gv));
1488 fp = nextargv(PL_last_in_gv);
1489 if (!fp) { /* Note: fp != IoIFP(io) */
1490 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1493 else if (type == OP_GLOB)
1494 fp = Perl_start_glob(aTHX_ POPs, io);
1496 else if (type == OP_GLOB)
1498 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1499 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1503 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1504 && (!io || !(IoFLAGS(io) & IOf_START))) {
1505 if (type == OP_GLOB)
1506 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1507 "glob failed (can't start child: %s)",
1510 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1512 if (gimme == G_SCALAR) {
1513 /* undef TARG, and push that undefined value */
1514 if (type != OP_RCATLINE) {
1515 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1523 if (gimme == G_SCALAR) {
1527 (void)SvUPGRADE(sv, SVt_PV);
1528 tmplen = SvLEN(sv); /* remember if already alloced */
1529 if (!tmplen && !SvREADONLY(sv))
1530 Sv_Grow(sv, 80); /* try short-buffering it */
1532 if (type == OP_RCATLINE && SvOK(sv)) {
1535 (void)SvPV_force(sv, n_a);
1541 sv = sv_2mortal(NEWSV(57, 80));
1545 /* This should not be marked tainted if the fp is marked clean */
1546 #define MAYBE_TAINT_LINE(io, sv) \
1547 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1552 /* delay EOF state for a snarfed empty file */
1553 #define SNARF_EOF(gimme,rs,io,sv) \
1554 (gimme != G_SCALAR || SvCUR(sv) \
1555 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1559 if (!sv_gets(sv, fp, offset)
1561 || SNARF_EOF(gimme, PL_rs, io, sv)
1562 || PerlIO_error(fp)))
1564 PerlIO_clearerr(fp);
1565 if (IoFLAGS(io) & IOf_ARGV) {
1566 fp = nextargv(PL_last_in_gv);
1569 (void)do_close(PL_last_in_gv, FALSE);
1571 else if (type == OP_GLOB) {
1572 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1573 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1574 "glob failed (child exited with status %d%s)",
1575 (int)(STATUS_CURRENT >> 8),
1576 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1579 if (gimme == G_SCALAR) {
1580 if (type != OP_RCATLINE) {
1581 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1587 MAYBE_TAINT_LINE(io, sv);
1590 MAYBE_TAINT_LINE(io, sv);
1592 IoFLAGS(io) |= IOf_NOLINE;
1596 if (type == OP_GLOB) {
1599 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1600 tmps = SvEND(sv) - 1;
1601 if (*tmps == *SvPVX(PL_rs)) {
1603 SvCUR_set(sv, SvCUR(sv) - 1);
1606 for (tmps = SvPVX(sv); *tmps; tmps++)
1607 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1608 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1610 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1611 (void)POPs; /* Unmatched wildcard? Chuck it... */
1614 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1615 const U8 *s = (U8*)SvPVX(sv) + offset;
1616 const STRLEN len = SvCUR(sv) - offset;
1619 if (ckWARN(WARN_UTF8) &&
1620 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1621 /* Emulate :encoding(utf8) warning in the same case. */
1622 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1623 "utf8 \"\\x%02X\" does not map to Unicode",
1624 f < (U8*)SvEND(sv) ? *f : 0);
1626 if (gimme == G_ARRAY) {
1627 if (SvLEN(sv) - SvCUR(sv) > 20) {
1628 SvPV_shrink_to_cur(sv);
1630 sv = sv_2mortal(NEWSV(58, 80));
1633 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1634 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1635 const STRLEN new_len
1636 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1637 SvPV_renew(sv, new_len);
1646 register PERL_CONTEXT *cx;
1647 I32 gimme = OP_GIMME(PL_op, -1);
1650 if (cxstack_ix >= 0)
1651 gimme = cxstack[cxstack_ix].blk_gimme;
1659 PUSHBLOCK(cx, CXt_BLOCK, SP);
1671 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1672 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1674 #ifdef PERL_COPY_ON_WRITE
1675 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1677 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1681 if (SvTYPE(hv) == SVt_PVHV) {
1682 if (PL_op->op_private & OPpLVAL_INTRO) {
1685 /* does the element we're localizing already exist? */
1687 /* can we determine whether it exists? */
1689 || mg_find((SV*)hv, PERL_MAGIC_env)
1690 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1691 /* Try to preserve the existenceness of a tied hash
1692 * element by using EXISTS and DELETE if possible.
1693 * Fallback to FETCH and STORE otherwise */
1694 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1695 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1696 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1698 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1701 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1702 svp = he ? &HeVAL(he) : 0;
1708 if (!svp || *svp == &PL_sv_undef) {
1713 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1715 lv = sv_newmortal();
1716 sv_upgrade(lv, SVt_PVLV);
1718 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1719 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1720 LvTARG(lv) = SvREFCNT_inc(hv);
1725 if (PL_op->op_private & OPpLVAL_INTRO) {
1726 if (HvNAME(hv) && isGV(*svp))
1727 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1731 char *key = SvPV(keysv, keylen);
1732 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1734 save_helem(hv, keysv, svp);
1737 else if (PL_op->op_private & OPpDEREF)
1738 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1740 sv = (svp ? *svp : &PL_sv_undef);
1741 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1742 * Pushing the magical RHS on to the stack is useless, since
1743 * that magic is soon destined to be misled by the local(),
1744 * and thus the later pp_sassign() will fail to mg_get() the
1745 * old value. This should also cure problems with delayed
1746 * mg_get()s. GSAR 98-07-03 */
1747 if (!lval && SvGMAGICAL(sv))
1748 sv = sv_mortalcopy(sv);
1756 register PERL_CONTEXT *cx;
1762 if (PL_op->op_flags & OPf_SPECIAL) {
1763 cx = &cxstack[cxstack_ix];
1764 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1769 gimme = OP_GIMME(PL_op, -1);
1771 if (cxstack_ix >= 0)
1772 gimme = cxstack[cxstack_ix].blk_gimme;
1778 if (gimme == G_VOID)
1780 else if (gimme == G_SCALAR) {
1783 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1786 *MARK = sv_mortalcopy(TOPs);
1789 *MARK = &PL_sv_undef;
1793 else if (gimme == G_ARRAY) {
1794 /* in case LEAVE wipes old return values */
1795 for (mark = newsp + 1; mark <= SP; mark++) {
1796 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1797 *mark = sv_mortalcopy(*mark);
1798 TAINT_NOT; /* Each item is independent */
1802 PL_curpm = newpm; /* Don't pop $1 et al till now */
1812 register PERL_CONTEXT *cx;
1818 cx = &cxstack[cxstack_ix];
1819 if (CxTYPE(cx) != CXt_LOOP)
1820 DIE(aTHX_ "panic: pp_iter");
1822 itersvp = CxITERVAR(cx);
1823 av = cx->blk_loop.iterary;
1824 if (SvTYPE(av) != SVt_PVAV) {
1825 /* iterate ($min .. $max) */
1826 if (cx->blk_loop.iterlval) {
1827 /* string increment */
1828 register SV* cur = cx->blk_loop.iterlval;
1830 const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1831 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1832 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1833 /* safe to reuse old SV */
1834 sv_setsv(*itersvp, cur);
1838 /* we need a fresh SV every time so that loop body sees a
1839 * completely new SV for closures/references to work as
1842 *itersvp = newSVsv(cur);
1843 SvREFCNT_dec(oldsv);
1845 if (strEQ(SvPVX(cur), max))
1846 sv_setiv(cur, 0); /* terminate next time */
1853 /* integer increment */
1854 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1857 /* don't risk potential race */
1858 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1859 /* safe to reuse old SV */
1860 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1864 /* we need a fresh SV every time so that loop body sees a
1865 * completely new SV for closures/references to work as they
1868 *itersvp = newSViv(cx->blk_loop.iterix++);
1869 SvREFCNT_dec(oldsv);
1875 if (PL_op->op_private & OPpITER_REVERSED) {
1876 /* In reverse, use itermax as the min :-) */
1877 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1880 if (SvMAGICAL(av) || AvREIFY(av)) {
1881 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1888 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1892 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1896 if (SvMAGICAL(av) || AvREIFY(av)) {
1897 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1904 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1908 if (sv && SvREFCNT(sv) == 0) {
1910 Perl_croak(aTHX_ "Use of freed value in iteration");
1917 if (av != PL_curstack && sv == &PL_sv_undef) {
1918 SV *lv = cx->blk_loop.iterlval;
1919 if (lv && SvREFCNT(lv) > 1) {
1924 SvREFCNT_dec(LvTARG(lv));
1926 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1927 sv_upgrade(lv, SVt_PVLV);
1929 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1931 LvTARG(lv) = SvREFCNT_inc(av);
1932 LvTARGOFF(lv) = cx->blk_loop.iterix;
1933 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1938 *itersvp = SvREFCNT_inc(sv);
1939 SvREFCNT_dec(oldsv);
1947 register PMOP *pm = cPMOP;
1963 register REGEXP *rx = PM_GETRE(pm);
1965 int force_on_match = 0;
1966 I32 oldsave = PL_savestack_ix;
1968 bool doutf8 = FALSE;
1969 #ifdef PERL_COPY_ON_WRITE
1974 /* known replacement string? */
1975 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1976 if (PL_op->op_flags & OPf_STACKED)
1978 else if (PL_op->op_private & OPpTARGET_MY)
1985 #ifdef PERL_COPY_ON_WRITE
1986 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1987 because they make integers such as 256 "false". */
1988 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1991 sv_force_normal_flags(TARG,0);
1994 #ifdef PERL_COPY_ON_WRITE
1998 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1999 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2000 DIE(aTHX_ PL_no_modify);
2003 s = SvPV(TARG, len);
2004 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2006 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2007 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2012 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2016 DIE(aTHX_ "panic: pp_subst");
2019 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2020 maxiters = 2 * slen + 10; /* We can match twice at each
2021 position, once with zero-length,
2022 second time with non-zero. */
2024 if (!rx->prelen && PL_curpm) {
2028 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2029 ? REXEC_COPY_STR : 0;
2031 r_flags |= REXEC_SCREAM;
2034 if (rx->reganch & RE_USE_INTUIT) {
2036 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2040 /* How to do it in subst? */
2041 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2043 && ((rx->reganch & ROPT_NOSCAN)
2044 || !((rx->reganch & RE_INTUIT_TAIL)
2045 && (r_flags & REXEC_SCREAM))))
2050 /* only replace once? */
2051 once = !(rpm->op_pmflags & PMf_GLOBAL);
2053 /* known replacement string? */
2055 /* replacement needing upgrading? */
2056 if (DO_UTF8(TARG) && !doutf8) {
2057 nsv = sv_newmortal();
2060 sv_recode_to_utf8(nsv, PL_encoding);
2062 sv_utf8_upgrade(nsv);
2063 c = SvPV(nsv, clen);
2067 c = SvPV(dstr, clen);
2068 doutf8 = DO_UTF8(dstr);
2076 /* can do inplace substitution? */
2078 #ifdef PERL_COPY_ON_WRITE
2081 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2082 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2083 && (!doutf8 || SvUTF8(TARG))) {
2084 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2085 r_flags | REXEC_CHECKED))
2089 LEAVE_SCOPE(oldsave);
2092 #ifdef PERL_COPY_ON_WRITE
2093 if (SvIsCOW(TARG)) {
2094 assert (!force_on_match);
2098 if (force_on_match) {
2100 s = SvPV_force(TARG, len);
2105 SvSCREAM_off(TARG); /* disable possible screamer */
2107 rxtainted |= RX_MATCH_TAINTED(rx);
2108 m = orig + rx->startp[0];
2109 d = orig + rx->endp[0];
2111 if (m - s > strend - d) { /* faster to shorten from end */
2113 Copy(c, m, clen, char);
2118 Move(d, m, i, char);
2122 SvCUR_set(TARG, m - s);
2125 else if ((i = m - s)) { /* faster from front */
2133 Copy(c, m, clen, char);
2138 Copy(c, d, clen, char);
2143 TAINT_IF(rxtainted & 1);
2149 if (iters++ > maxiters)
2150 DIE(aTHX_ "Substitution loop");
2151 rxtainted |= RX_MATCH_TAINTED(rx);
2152 m = rx->startp[0] + orig;
2156 Move(s, d, i, char);
2160 Copy(c, d, clen, char);
2163 s = rx->endp[0] + orig;
2164 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2166 /* don't match same null twice */
2167 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2170 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2171 Move(s, d, i+1, char); /* include the NUL */
2173 TAINT_IF(rxtainted & 1);
2175 PUSHs(sv_2mortal(newSViv((I32)iters)));
2177 (void)SvPOK_only_UTF8(TARG);
2178 TAINT_IF(rxtainted);
2179 if (SvSMAGICAL(TARG)) {
2187 LEAVE_SCOPE(oldsave);
2191 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2192 r_flags | REXEC_CHECKED))
2194 if (force_on_match) {
2196 s = SvPV_force(TARG, len);
2199 #ifdef PERL_COPY_ON_WRITE
2202 rxtainted |= RX_MATCH_TAINTED(rx);
2203 dstr = newSVpvn(m, s-m);
2208 register PERL_CONTEXT *cx;
2212 RETURNOP(cPMOP->op_pmreplroot);
2214 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2216 if (iters++ > maxiters)
2217 DIE(aTHX_ "Substitution loop");
2218 rxtainted |= RX_MATCH_TAINTED(rx);
2219 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2224 strend = s + (strend - m);
2226 m = rx->startp[0] + orig;
2227 if (doutf8 && !SvUTF8(dstr))
2228 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2230 sv_catpvn(dstr, s, m-s);
2231 s = rx->endp[0] + orig;
2233 sv_catpvn(dstr, c, clen);
2236 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2237 TARG, NULL, r_flags));
2238 if (doutf8 && !DO_UTF8(TARG))
2239 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2241 sv_catpvn(dstr, s, strend - s);
2243 #ifdef PERL_COPY_ON_WRITE
2244 /* The match may make the string COW. If so, brilliant, because that's
2245 just saved us one malloc, copy and free - the regexp has donated
2246 the old buffer, and we malloc an entirely new one, rather than the
2247 regexp malloc()ing a buffer and copying our original, only for
2248 us to throw it away here during the substitution. */
2249 if (SvIsCOW(TARG)) {
2250 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2256 SvPV_set(TARG, SvPVX(dstr));
2257 SvCUR_set(TARG, SvCUR(dstr));
2258 SvLEN_set(TARG, SvLEN(dstr));
2259 doutf8 |= DO_UTF8(dstr);
2260 SvPV_set(dstr, (char*)0);
2263 TAINT_IF(rxtainted & 1);
2265 PUSHs(sv_2mortal(newSViv((I32)iters)));
2267 (void)SvPOK_only(TARG);
2270 TAINT_IF(rxtainted);
2273 LEAVE_SCOPE(oldsave);
2282 LEAVE_SCOPE(oldsave);
2291 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2292 ++*PL_markstack_ptr;
2293 LEAVE; /* exit inner scope */
2296 if (PL_stack_base + *PL_markstack_ptr > SP) {
2298 I32 gimme = GIMME_V;
2300 LEAVE; /* exit outer scope */
2301 (void)POPMARK; /* pop src */
2302 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2303 (void)POPMARK; /* pop dst */
2304 SP = PL_stack_base + POPMARK; /* pop original mark */
2305 if (gimme == G_SCALAR) {
2306 if (PL_op->op_private & OPpGREP_LEX) {
2307 SV* sv = sv_newmortal();
2308 sv_setiv(sv, items);
2316 else if (gimme == G_ARRAY)
2323 ENTER; /* enter inner scope */
2326 src = PL_stack_base[*PL_markstack_ptr];
2328 if (PL_op->op_private & OPpGREP_LEX)
2329 PAD_SVl(PL_op->op_targ) = src;
2333 RETURNOP(cLOGOP->op_other);
2344 register PERL_CONTEXT *cx;
2348 cxstack_ix++; /* temporarily protect top context */
2351 if (gimme == G_SCALAR) {
2354 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2356 *MARK = SvREFCNT_inc(TOPs);
2361 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2363 *MARK = sv_mortalcopy(sv);
2368 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2372 *MARK = &PL_sv_undef;
2376 else if (gimme == G_ARRAY) {
2377 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2378 if (!SvTEMP(*MARK)) {
2379 *MARK = sv_mortalcopy(*MARK);
2380 TAINT_NOT; /* Each item is independent */
2388 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2389 PL_curpm = newpm; /* ... and pop $1 et al */
2392 return cx->blk_sub.retop;
2395 /* This duplicates the above code because the above code must not
2396 * get any slower by more conditions */
2404 register PERL_CONTEXT *cx;
2408 cxstack_ix++; /* temporarily protect top context */
2412 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2413 /* We are an argument to a function or grep().
2414 * This kind of lvalueness was legal before lvalue
2415 * subroutines too, so be backward compatible:
2416 * cannot report errors. */
2418 /* Scalar context *is* possible, on the LHS of -> only,
2419 * as in f()->meth(). But this is not an lvalue. */
2420 if (gimme == G_SCALAR)
2422 if (gimme == G_ARRAY) {
2423 if (!CvLVALUE(cx->blk_sub.cv))
2424 goto temporise_array;
2425 EXTEND_MORTAL(SP - newsp);
2426 for (mark = newsp + 1; mark <= SP; mark++) {
2429 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2430 *mark = sv_mortalcopy(*mark);
2432 /* Can be a localized value subject to deletion. */
2433 PL_tmps_stack[++PL_tmps_ix] = *mark;
2434 (void)SvREFCNT_inc(*mark);
2439 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2440 /* Here we go for robustness, not for speed, so we change all
2441 * the refcounts so the caller gets a live guy. Cannot set
2442 * TEMP, so sv_2mortal is out of question. */
2443 if (!CvLVALUE(cx->blk_sub.cv)) {
2449 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2451 if (gimme == G_SCALAR) {
2455 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2461 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2462 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2463 : "a readonly value" : "a temporary");
2465 else { /* Can be a localized value
2466 * subject to deletion. */
2467 PL_tmps_stack[++PL_tmps_ix] = *mark;
2468 (void)SvREFCNT_inc(*mark);
2471 else { /* Should not happen? */
2477 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2478 (MARK > SP ? "Empty array" : "Array"));
2482 else if (gimme == G_ARRAY) {
2483 EXTEND_MORTAL(SP - newsp);
2484 for (mark = newsp + 1; mark <= SP; mark++) {
2485 if (*mark != &PL_sv_undef
2486 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2487 /* Might be flattened array after $#array = */
2494 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2495 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2498 /* Can be a localized value subject to deletion. */
2499 PL_tmps_stack[++PL_tmps_ix] = *mark;
2500 (void)SvREFCNT_inc(*mark);
2506 if (gimme == G_SCALAR) {
2510 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2512 *MARK = SvREFCNT_inc(TOPs);
2517 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2519 *MARK = sv_mortalcopy(sv);
2524 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2528 *MARK = &PL_sv_undef;
2532 else if (gimme == G_ARRAY) {
2534 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2535 if (!SvTEMP(*MARK)) {
2536 *MARK = sv_mortalcopy(*MARK);
2537 TAINT_NOT; /* Each item is independent */
2546 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2547 PL_curpm = newpm; /* ... and pop $1 et al */
2550 return cx->blk_sub.retop;
2555 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2557 SV *dbsv = GvSV(PL_DBsub);
2560 if (!PERLDB_SUB_NN) {
2563 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2564 || strEQ(GvNAME(gv), "END")
2565 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2566 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2567 && (gv = (GV*)*svp) ))) {
2568 /* Use GV from the stack as a fallback. */
2569 /* GV is potentially non-unique, or contain different CV. */
2570 SV *tmp = newRV((SV*)cv);
2571 sv_setsv(dbsv, tmp);
2575 gv_efullname3(dbsv, gv, Nullch);
2579 const int type = SvTYPE(dbsv);
2580 if (type < SVt_PVIV && type != SVt_IV)
2581 sv_upgrade(dbsv, SVt_PVIV);
2582 (void)SvIOK_on(dbsv);
2583 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2587 PL_curcopdb = PL_curcop;
2588 cv = GvCV(PL_DBsub);
2598 register PERL_CONTEXT *cx;
2600 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2603 DIE(aTHX_ "Not a CODE reference");
2604 switch (SvTYPE(sv)) {
2605 /* This is overwhelming the most common case: */
2607 if (!(cv = GvCVu((GV*)sv)))
2608 cv = sv_2cv(sv, &stash, &gv, FALSE);
2618 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2620 SP = PL_stack_base + POPMARK;
2623 if (SvGMAGICAL(sv)) {
2627 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2631 sym = SvPV(sv, n_a);
2634 DIE(aTHX_ PL_no_usym, "a subroutine");
2635 if (PL_op->op_private & HINT_STRICT_REFS)
2636 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2637 cv = get_cv(sym, TRUE);
2642 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2643 tryAMAGICunDEREF(to_cv);
2646 if (SvTYPE(cv) == SVt_PVCV)
2651 DIE(aTHX_ "Not a CODE reference");
2652 /* This is the second most common case: */
2662 if (!CvROOT(cv) && !CvXSUB(cv)) {
2667 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2668 if (CvASSERTION(cv) && PL_DBassertion)
2669 sv_setiv(PL_DBassertion, 1);
2671 cv = get_db_sub(&sv, cv);
2672 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2673 DIE(aTHX_ "No DB::sub routine defined");
2676 if (!(CvXSUB(cv))) {
2677 /* This path taken at least 75% of the time */
2679 register I32 items = SP - MARK;
2680 AV* padlist = CvPADLIST(cv);
2681 PUSHBLOCK(cx, CXt_SUB, MARK);
2683 cx->blk_sub.retop = PL_op->op_next;
2685 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2686 * that eval'' ops within this sub know the correct lexical space.
2687 * Owing the speed considerations, we choose instead to search for
2688 * the cv using find_runcv() when calling doeval().
2690 if (CvDEPTH(cv) >= 2) {
2691 PERL_STACK_OVERFLOW_CHECK();
2692 pad_push(padlist, CvDEPTH(cv));
2694 PAD_SET_CUR(padlist, CvDEPTH(cv));
2701 DEBUG_S(PerlIO_printf(Perl_debug_log,
2702 "%p entersub preparing @_\n", thr));
2704 av = (AV*)PAD_SVl(0);
2706 /* @_ is normally not REAL--this should only ever
2707 * happen when DB::sub() calls things that modify @_ */
2712 cx->blk_sub.savearray = GvAV(PL_defgv);
2713 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2714 CX_CURPAD_SAVE(cx->blk_sub);
2715 cx->blk_sub.argarray = av;
2718 if (items > AvMAX(av) + 1) {
2720 if (AvARRAY(av) != ary) {
2721 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2722 SvPV_set(av, (char*)ary);
2724 if (items > AvMAX(av) + 1) {
2725 AvMAX(av) = items - 1;
2726 Renew(ary,items,SV*);
2728 SvPV_set(av, (char*)ary);
2731 Copy(MARK,AvARRAY(av),items,SV*);
2732 AvFILLp(av) = items - 1;
2740 /* warning must come *after* we fully set up the context
2741 * stuff so that __WARN__ handlers can safely dounwind()
2744 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2745 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2746 sub_crush_depth(cv);
2748 DEBUG_S(PerlIO_printf(Perl_debug_log,
2749 "%p entersub returning %p\n", thr, CvSTART(cv)));
2751 RETURNOP(CvSTART(cv));
2754 #ifdef PERL_XSUB_OLDSTYLE
2755 if (CvOLDSTYLE(cv)) {
2756 I32 (*fp3)(int,int,int);
2758 register I32 items = SP - MARK;
2759 /* We dont worry to copy from @_. */
2764 PL_stack_sp = mark + 1;
2765 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2766 items = (*fp3)(CvXSUBANY(cv).any_i32,
2767 MARK - PL_stack_base + 1,
2769 PL_stack_sp = PL_stack_base + items;
2772 #endif /* PERL_XSUB_OLDSTYLE */
2774 I32 markix = TOPMARK;
2779 /* Need to copy @_ to stack. Alternative may be to
2780 * switch stack to @_, and copy return values
2781 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2784 av = GvAV(PL_defgv);
2785 items = AvFILLp(av) + 1; /* @_ is not tieable */
2788 /* Mark is at the end of the stack. */
2790 Copy(AvARRAY(av), SP + 1, items, SV*);
2795 /* We assume first XSUB in &DB::sub is the called one. */
2797 SAVEVPTR(PL_curcop);
2798 PL_curcop = PL_curcopdb;
2801 /* Do we need to open block here? XXXX */
2802 (void)(*CvXSUB(cv))(aTHX_ cv);
2804 /* Enforce some sanity in scalar context. */
2805 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2806 if (markix > PL_stack_sp - PL_stack_base)
2807 *(PL_stack_base + markix) = &PL_sv_undef;
2809 *(PL_stack_base + markix) = *PL_stack_sp;
2810 PL_stack_sp = PL_stack_base + markix;
2817 assert (0); /* Cannot get here. */
2818 /* This is deliberately moved here as spaghetti code to keep it out of the
2825 /* anonymous or undef'd function leaves us no recourse */
2826 if (CvANON(cv) || !(gv = CvGV(cv)))
2827 DIE(aTHX_ "Undefined subroutine called");
2829 /* autoloaded stub? */
2830 if (cv != GvCV(gv)) {
2833 /* should call AUTOLOAD now? */
2836 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2843 sub_name = sv_newmortal();
2844 gv_efullname3(sub_name, gv, Nullch);
2845 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2849 DIE(aTHX_ "Not a CODE reference");
2855 Perl_sub_crush_depth(pTHX_ CV *cv)
2858 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2860 SV* tmpstr = sv_newmortal();
2861 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2862 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2872 IV elem = SvIV(elemsv);
2874 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2875 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2878 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2879 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2881 elem -= PL_curcop->cop_arybase;
2882 if (SvTYPE(av) != SVt_PVAV)
2884 svp = av_fetch(av, elem, lval && !defer);
2886 #ifdef PERL_MALLOC_WRAP
2887 static const char oom_array_extend[] =
2888 "Out of memory during array extend"; /* Duplicated in av.c */
2889 if (SvUOK(elemsv)) {
2890 const UV uv = SvUV(elemsv);
2891 elem = uv > IV_MAX ? IV_MAX : uv;
2893 else if (SvNOK(elemsv))
2894 elem = (IV)SvNV(elemsv);
2896 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2898 if (!svp || *svp == &PL_sv_undef) {
2901 DIE(aTHX_ PL_no_aelem, elem);
2902 lv = sv_newmortal();
2903 sv_upgrade(lv, SVt_PVLV);
2905 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2906 LvTARG(lv) = SvREFCNT_inc(av);
2907 LvTARGOFF(lv) = elem;
2912 if (PL_op->op_private & OPpLVAL_INTRO)
2913 save_aelem(av, elem, svp);
2914 else if (PL_op->op_private & OPpDEREF)
2915 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2917 sv = (svp ? *svp : &PL_sv_undef);
2918 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2919 sv = sv_mortalcopy(sv);
2925 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2931 Perl_croak(aTHX_ PL_no_modify);
2932 if (SvTYPE(sv) < SVt_RV)
2933 sv_upgrade(sv, SVt_RV);
2934 else if (SvTYPE(sv) >= SVt_PV) {
2941 SvRV_set(sv, NEWSV(355,0));
2944 SvRV_set(sv, (SV*)newAV());
2947 SvRV_set(sv, (SV*)newHV());
2962 if (SvTYPE(rsv) == SVt_PVCV) {
2968 SETs(method_common(sv, Null(U32*)));
2976 U32 hash = SvUVX(sv);
2978 XPUSHs(method_common(sv, &hash));
2983 S_method_common(pTHX_ SV* meth, U32* hashp)
2990 const char* packname = 0;
2991 SV *packsv = Nullsv;
2993 const char *name = SvPV(meth, namelen);
2995 sv = *(PL_stack_base + TOPMARK + 1);
2998 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3007 /* this isn't a reference */
3010 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3012 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3014 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3021 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3022 !(ob=(SV*)GvIO(iogv)))
3024 /* this isn't the name of a filehandle either */
3026 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3027 ? !isIDFIRST_utf8((U8*)packname)
3028 : !isIDFIRST(*packname)
3031 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3032 SvOK(sv) ? "without a package or object reference"
3033 : "on an undefined value");
3035 /* assume it's a package name */
3036 stash = gv_stashpvn(packname, packlen, FALSE);
3040 SV* ref = newSViv(PTR2IV(stash));
3041 hv_store(PL_stashcache, packname, packlen, ref, 0);
3045 /* it _is_ a filehandle name -- replace with a reference */
3046 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3049 /* if we got here, ob should be a reference or a glob */
3050 if (!ob || !(SvOBJECT(ob)
3051 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3054 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3058 stash = SvSTASH(ob);
3061 /* NOTE: stash may be null, hope hv_fetch_ent and
3062 gv_fetchmethod can cope (it seems they can) */
3064 /* shortcut for simple names */
3066 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3068 gv = (GV*)HeVAL(he);
3069 if (isGV(gv) && GvCV(gv) &&
3070 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3071 return (SV*)GvCV(gv);
3075 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3078 /* This code tries to figure out just what went wrong with
3079 gv_fetchmethod. It therefore needs to duplicate a lot of
3080 the internals of that function. We can't move it inside
3081 Perl_gv_fetchmethod_autoload(), however, since that would
3082 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3085 const char* leaf = name;
3086 const char* sep = Nullch;
3089 for (p = name; *p; p++) {
3091 sep = p, leaf = p + 1;
3092 else if (*p == ':' && *(p + 1) == ':')
3093 sep = p, leaf = p + 2;
3095 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3096 /* the method name is unqualified or starts with SUPER:: */
3097 packname = sep ? CopSTASHPV(PL_curcop) :
3098 stash ? HvNAME(stash) : packname;
3101 "Can't use anonymous symbol table for method lookup");
3103 packlen = strlen(packname);
3106 /* the method name is qualified */
3108 packlen = sep - name;
3111 /* we're relying on gv_fetchmethod not autovivifying the stash */
3112 if (gv_stashpvn(packname, packlen, FALSE)) {
3114 "Can't locate object method \"%s\" via package \"%.*s\"",
3115 leaf, (int)packlen, packname);
3119 "Can't locate object method \"%s\" via package \"%.*s\""
3120 " (perhaps you forgot to load \"%.*s\"?)",
3121 leaf, (int)packlen, packname, (int)packlen, packname);
3124 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3129 * c-indentation-style: bsd
3131 * indent-tabs-mode: t
3134 * vim: shiftwidth=4: