3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
19 /* This file contains 'hot' pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * By 'hot', we mean common ops whose execution speed is critical.
26 * By gathering them together into a single file, we encourage
27 * CPU cache hits on hot code. Also it could be taken as a warning not to
28 * change any code in this file unless you're sure it won't affect
33 #define PERL_IN_PP_HOT_C
47 PL_curcop = (COP*)PL_op;
48 TAINT_NOT; /* Each statement is presumed innocent */
49 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
58 if (PL_op->op_private & OPpLVAL_INTRO)
59 PUSHs(save_scalar(cGVOP_gv));
61 PUSHs(GvSV(cGVOP_gv));
72 PL_curcop = (COP*)PL_op;
78 PUSHMARK(PL_stack_sp);
93 XPUSHs((SV*)cGVOP_gv);
104 RETURNOP(cLOGOP->op_other);
112 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
114 temp = left; left = right; right = temp;
116 if (PL_tainting && PL_tainted && !SvTAINTED(left))
118 SvSetMagicSV(right, left);
127 RETURNOP(cLOGOP->op_other);
129 RETURNOP(cLOGOP->op_next);
135 TAINT_NOT; /* Each statement is presumed innocent */
136 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
138 oldsave = PL_scopestack[PL_scopestack_ix - 1];
139 LEAVE_SCOPE(oldsave);
145 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
150 const char *rpv = SvPV(right, rlen); /* mg_get(right) happens here */
151 const bool rbyte = !DO_UTF8(right);
152 bool rcopied = FALSE;
154 if (TARG == right && right != left) {
155 right = sv_2mortal(newSVpvn(rpv, rlen));
156 rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
162 const char* const lpv = SvPV(left, llen); /* mg_get(left) may happen here */
163 lbyte = !DO_UTF8(left);
164 sv_setpvn(TARG, lpv, llen);
170 else { /* TARG == left */
172 if (SvGMAGICAL(left))
173 mg_get(left); /* or mg_get(left) may happen here */
175 sv_setpvn(left, "", 0);
176 (void)SvPV_nomg(left, llen); /* Needed to set UTF8 flag */
177 lbyte = !DO_UTF8(left);
182 if (lbyte != rbyte) {
184 sv_utf8_upgrade_nomg(TARG);
187 right = sv_2mortal(newSVpvn(rpv, rlen));
188 sv_utf8_upgrade_nomg(right);
189 rpv = SvPV(right, rlen);
192 sv_catpvn_nomg(TARG, rpv, rlen);
203 if (PL_op->op_flags & OPf_MOD) {
204 if (PL_op->op_private & OPpLVAL_INTRO)
205 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
206 if (PL_op->op_private & OPpDEREF) {
208 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
217 tryAMAGICunTARGET(iter, 0);
218 PL_last_in_gv = (GV*)(*PL_stack_sp--);
219 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
220 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
221 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
224 XPUSHs((SV*)PL_last_in_gv);
227 PL_last_in_gv = (GV*)(*PL_stack_sp--);
230 return do_readline();
235 dSP; tryAMAGICbinSET(eq,0);
236 #ifndef NV_PRESERVES_UV
237 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
239 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
243 #ifdef PERL_PRESERVE_IVUV
246 /* Unless the left argument is integer in range we are going
247 to have to use NV maths. Hence only attempt to coerce the
248 right argument if we know the left is integer. */
251 bool auvok = SvUOK(TOPm1s);
252 bool buvok = SvUOK(TOPs);
254 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
255 /* Casting IV to UV before comparison isn't going to matter
256 on 2s complement. On 1s complement or sign&magnitude
257 (if we have any of them) it could to make negative zero
258 differ from normal zero. As I understand it. (Need to
259 check - is negative zero implementation defined behaviour
261 UV buv = SvUVX(POPs);
262 UV auv = SvUVX(TOPs);
264 SETs(boolSV(auv == buv));
267 { /* ## Mixed IV,UV ## */
271 /* == is commutative so doesn't matter which is left or right */
273 /* top of stack (b) is the iv */
282 /* As uv is a UV, it's >0, so it cannot be == */
286 /* we know iv is >= 0 */
287 SETs(boolSV((UV)iv == SvUVX(uvp)));
295 SETs(boolSV(TOPn == value));
303 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
304 DIE(aTHX_ PL_no_modify);
305 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
306 && SvIVX(TOPs) != IV_MAX)
308 SvIV_set(TOPs, SvIVX(TOPs) + 1);
309 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
311 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
324 RETURNOP(cLOGOP->op_other);
330 /* Most of this is lifted straight from pp_defined */
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) {
1712 DIE(aTHX_ PL_no_helem_sv, keysv);
1714 lv = sv_newmortal();
1715 sv_upgrade(lv, SVt_PVLV);
1717 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1718 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1719 LvTARG(lv) = SvREFCNT_inc(hv);
1724 if (PL_op->op_private & OPpLVAL_INTRO) {
1725 if (HvNAME(hv) && isGV(*svp))
1726 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1730 char *key = SvPV(keysv, keylen);
1731 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1733 save_helem(hv, keysv, svp);
1736 else if (PL_op->op_private & OPpDEREF)
1737 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1739 sv = (svp ? *svp : &PL_sv_undef);
1740 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1741 * Pushing the magical RHS on to the stack is useless, since
1742 * that magic is soon destined to be misled by the local(),
1743 * and thus the later pp_sassign() will fail to mg_get() the
1744 * old value. This should also cure problems with delayed
1745 * mg_get()s. GSAR 98-07-03 */
1746 if (!lval && SvGMAGICAL(sv))
1747 sv = sv_mortalcopy(sv);
1755 register PERL_CONTEXT *cx;
1761 if (PL_op->op_flags & OPf_SPECIAL) {
1762 cx = &cxstack[cxstack_ix];
1763 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1768 gimme = OP_GIMME(PL_op, -1);
1770 if (cxstack_ix >= 0)
1771 gimme = cxstack[cxstack_ix].blk_gimme;
1777 if (gimme == G_VOID)
1779 else if (gimme == G_SCALAR) {
1782 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1785 *MARK = sv_mortalcopy(TOPs);
1788 *MARK = &PL_sv_undef;
1792 else if (gimme == G_ARRAY) {
1793 /* in case LEAVE wipes old return values */
1794 for (mark = newsp + 1; mark <= SP; mark++) {
1795 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1796 *mark = sv_mortalcopy(*mark);
1797 TAINT_NOT; /* Each item is independent */
1801 PL_curpm = newpm; /* Don't pop $1 et al till now */
1811 register PERL_CONTEXT *cx;
1817 cx = &cxstack[cxstack_ix];
1818 if (CxTYPE(cx) != CXt_LOOP)
1819 DIE(aTHX_ "panic: pp_iter");
1821 itersvp = CxITERVAR(cx);
1822 av = cx->blk_loop.iterary;
1823 if (SvTYPE(av) != SVt_PVAV) {
1824 /* iterate ($min .. $max) */
1825 if (cx->blk_loop.iterlval) {
1826 /* string increment */
1827 register SV* cur = cx->blk_loop.iterlval;
1829 const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1830 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1831 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1832 /* safe to reuse old SV */
1833 sv_setsv(*itersvp, cur);
1837 /* we need a fresh SV every time so that loop body sees a
1838 * completely new SV for closures/references to work as
1841 *itersvp = newSVsv(cur);
1842 SvREFCNT_dec(oldsv);
1844 if (strEQ(SvPVX(cur), max))
1845 sv_setiv(cur, 0); /* terminate next time */
1852 /* integer increment */
1853 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1856 /* don't risk potential race */
1857 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1858 /* safe to reuse old SV */
1859 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1863 /* we need a fresh SV every time so that loop body sees a
1864 * completely new SV for closures/references to work as they
1867 *itersvp = newSViv(cx->blk_loop.iterix++);
1868 SvREFCNT_dec(oldsv);
1874 if (PL_op->op_private & OPpITER_REVERSED) {
1875 /* In reverse, use itermax as the min :-) */
1876 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1879 if (SvMAGICAL(av) || AvREIFY(av)) {
1880 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1887 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1891 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1895 if (SvMAGICAL(av) || AvREIFY(av)) {
1896 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1903 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1907 if (sv && SvREFCNT(sv) == 0) {
1909 Perl_croak(aTHX_ "Use of freed value in iteration");
1916 if (av != PL_curstack && sv == &PL_sv_undef) {
1917 SV *lv = cx->blk_loop.iterlval;
1918 if (lv && SvREFCNT(lv) > 1) {
1923 SvREFCNT_dec(LvTARG(lv));
1925 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1926 sv_upgrade(lv, SVt_PVLV);
1928 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1930 LvTARG(lv) = SvREFCNT_inc(av);
1931 LvTARGOFF(lv) = cx->blk_loop.iterix;
1932 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1937 *itersvp = SvREFCNT_inc(sv);
1938 SvREFCNT_dec(oldsv);
1946 register PMOP *pm = cPMOP;
1962 register REGEXP *rx = PM_GETRE(pm);
1964 int force_on_match = 0;
1965 I32 oldsave = PL_savestack_ix;
1967 bool doutf8 = FALSE;
1968 #ifdef PERL_COPY_ON_WRITE
1973 /* known replacement string? */
1974 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1975 if (PL_op->op_flags & OPf_STACKED)
1977 else if (PL_op->op_private & OPpTARGET_MY)
1984 #ifdef PERL_COPY_ON_WRITE
1985 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1986 because they make integers such as 256 "false". */
1987 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1990 sv_force_normal_flags(TARG,0);
1993 #ifdef PERL_COPY_ON_WRITE
1997 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1998 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1999 DIE(aTHX_ PL_no_modify);
2002 s = SvPV(TARG, len);
2003 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2005 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2006 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2011 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2015 DIE(aTHX_ "panic: pp_subst");
2018 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2019 maxiters = 2 * slen + 10; /* We can match twice at each
2020 position, once with zero-length,
2021 second time with non-zero. */
2023 if (!rx->prelen && PL_curpm) {
2027 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2028 ? REXEC_COPY_STR : 0;
2030 r_flags |= REXEC_SCREAM;
2033 if (rx->reganch & RE_USE_INTUIT) {
2035 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2039 /* How to do it in subst? */
2040 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2042 && ((rx->reganch & ROPT_NOSCAN)
2043 || !((rx->reganch & RE_INTUIT_TAIL)
2044 && (r_flags & REXEC_SCREAM))))
2049 /* only replace once? */
2050 once = !(rpm->op_pmflags & PMf_GLOBAL);
2052 /* known replacement string? */
2054 /* replacement needing upgrading? */
2055 if (DO_UTF8(TARG) && !doutf8) {
2056 nsv = sv_newmortal();
2059 sv_recode_to_utf8(nsv, PL_encoding);
2061 sv_utf8_upgrade(nsv);
2062 c = SvPV(nsv, clen);
2066 c = SvPV(dstr, clen);
2067 doutf8 = DO_UTF8(dstr);
2075 /* can do inplace substitution? */
2077 #ifdef PERL_COPY_ON_WRITE
2080 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2081 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2082 && (!doutf8 || SvUTF8(TARG))) {
2083 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2084 r_flags | REXEC_CHECKED))
2088 LEAVE_SCOPE(oldsave);
2091 #ifdef PERL_COPY_ON_WRITE
2092 if (SvIsCOW(TARG)) {
2093 assert (!force_on_match);
2097 if (force_on_match) {
2099 s = SvPV_force(TARG, len);
2104 SvSCREAM_off(TARG); /* disable possible screamer */
2106 rxtainted |= RX_MATCH_TAINTED(rx);
2107 m = orig + rx->startp[0];
2108 d = orig + rx->endp[0];
2110 if (m - s > strend - d) { /* faster to shorten from end */
2112 Copy(c, m, clen, char);
2117 Move(d, m, i, char);
2121 SvCUR_set(TARG, m - s);
2124 else if ((i = m - s)) { /* faster from front */
2132 Copy(c, m, clen, char);
2137 Copy(c, d, clen, char);
2142 TAINT_IF(rxtainted & 1);
2148 if (iters++ > maxiters)
2149 DIE(aTHX_ "Substitution loop");
2150 rxtainted |= RX_MATCH_TAINTED(rx);
2151 m = rx->startp[0] + orig;
2155 Move(s, d, i, char);
2159 Copy(c, d, clen, char);
2162 s = rx->endp[0] + orig;
2163 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2165 /* don't match same null twice */
2166 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2169 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2170 Move(s, d, i+1, char); /* include the NUL */
2172 TAINT_IF(rxtainted & 1);
2174 PUSHs(sv_2mortal(newSViv((I32)iters)));
2176 (void)SvPOK_only_UTF8(TARG);
2177 TAINT_IF(rxtainted);
2178 if (SvSMAGICAL(TARG)) {
2186 LEAVE_SCOPE(oldsave);
2190 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2191 r_flags | REXEC_CHECKED))
2193 if (force_on_match) {
2195 s = SvPV_force(TARG, len);
2198 #ifdef PERL_COPY_ON_WRITE
2201 rxtainted |= RX_MATCH_TAINTED(rx);
2202 dstr = newSVpvn(m, s-m);
2207 register PERL_CONTEXT *cx;
2211 RETURNOP(cPMOP->op_pmreplroot);
2213 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2215 if (iters++ > maxiters)
2216 DIE(aTHX_ "Substitution loop");
2217 rxtainted |= RX_MATCH_TAINTED(rx);
2218 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2223 strend = s + (strend - m);
2225 m = rx->startp[0] + orig;
2226 if (doutf8 && !SvUTF8(dstr))
2227 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2229 sv_catpvn(dstr, s, m-s);
2230 s = rx->endp[0] + orig;
2232 sv_catpvn(dstr, c, clen);
2235 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2236 TARG, NULL, r_flags));
2237 if (doutf8 && !DO_UTF8(TARG))
2238 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2240 sv_catpvn(dstr, s, strend - s);
2242 #ifdef PERL_COPY_ON_WRITE
2243 /* The match may make the string COW. If so, brilliant, because that's
2244 just saved us one malloc, copy and free - the regexp has donated
2245 the old buffer, and we malloc an entirely new one, rather than the
2246 regexp malloc()ing a buffer and copying our original, only for
2247 us to throw it away here during the substitution. */
2248 if (SvIsCOW(TARG)) {
2249 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2255 SvPV_set(TARG, SvPVX(dstr));
2256 SvCUR_set(TARG, SvCUR(dstr));
2257 SvLEN_set(TARG, SvLEN(dstr));
2258 doutf8 |= DO_UTF8(dstr);
2259 SvPV_set(dstr, (char*)0);
2262 TAINT_IF(rxtainted & 1);
2264 PUSHs(sv_2mortal(newSViv((I32)iters)));
2266 (void)SvPOK_only(TARG);
2269 TAINT_IF(rxtainted);
2272 LEAVE_SCOPE(oldsave);
2281 LEAVE_SCOPE(oldsave);
2290 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2291 ++*PL_markstack_ptr;
2292 LEAVE; /* exit inner scope */
2295 if (PL_stack_base + *PL_markstack_ptr > SP) {
2297 I32 gimme = GIMME_V;
2299 LEAVE; /* exit outer scope */
2300 (void)POPMARK; /* pop src */
2301 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2302 (void)POPMARK; /* pop dst */
2303 SP = PL_stack_base + POPMARK; /* pop original mark */
2304 if (gimme == G_SCALAR) {
2305 if (PL_op->op_private & OPpGREP_LEX) {
2306 SV* sv = sv_newmortal();
2307 sv_setiv(sv, items);
2315 else if (gimme == G_ARRAY)
2322 ENTER; /* enter inner scope */
2325 src = PL_stack_base[*PL_markstack_ptr];
2327 if (PL_op->op_private & OPpGREP_LEX)
2328 PAD_SVl(PL_op->op_targ) = src;
2332 RETURNOP(cLOGOP->op_other);
2343 register PERL_CONTEXT *cx;
2347 cxstack_ix++; /* temporarily protect top context */
2350 if (gimme == G_SCALAR) {
2353 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2355 *MARK = SvREFCNT_inc(TOPs);
2360 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2362 *MARK = sv_mortalcopy(sv);
2367 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2371 *MARK = &PL_sv_undef;
2375 else if (gimme == G_ARRAY) {
2376 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2377 if (!SvTEMP(*MARK)) {
2378 *MARK = sv_mortalcopy(*MARK);
2379 TAINT_NOT; /* Each item is independent */
2387 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2388 PL_curpm = newpm; /* ... and pop $1 et al */
2391 return cx->blk_sub.retop;
2394 /* This duplicates the above code because the above code must not
2395 * get any slower by more conditions */
2403 register PERL_CONTEXT *cx;
2407 cxstack_ix++; /* temporarily protect top context */
2411 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2412 /* We are an argument to a function or grep().
2413 * This kind of lvalueness was legal before lvalue
2414 * subroutines too, so be backward compatible:
2415 * cannot report errors. */
2417 /* Scalar context *is* possible, on the LHS of -> only,
2418 * as in f()->meth(). But this is not an lvalue. */
2419 if (gimme == G_SCALAR)
2421 if (gimme == G_ARRAY) {
2422 if (!CvLVALUE(cx->blk_sub.cv))
2423 goto temporise_array;
2424 EXTEND_MORTAL(SP - newsp);
2425 for (mark = newsp + 1; mark <= SP; mark++) {
2428 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2429 *mark = sv_mortalcopy(*mark);
2431 /* Can be a localized value subject to deletion. */
2432 PL_tmps_stack[++PL_tmps_ix] = *mark;
2433 (void)SvREFCNT_inc(*mark);
2438 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2439 /* Here we go for robustness, not for speed, so we change all
2440 * the refcounts so the caller gets a live guy. Cannot set
2441 * TEMP, so sv_2mortal is out of question. */
2442 if (!CvLVALUE(cx->blk_sub.cv)) {
2448 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2450 if (gimme == G_SCALAR) {
2454 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2460 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2461 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2462 : "a readonly value" : "a temporary");
2464 else { /* Can be a localized value
2465 * subject to deletion. */
2466 PL_tmps_stack[++PL_tmps_ix] = *mark;
2467 (void)SvREFCNT_inc(*mark);
2470 else { /* Should not happen? */
2476 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2477 (MARK > SP ? "Empty array" : "Array"));
2481 else if (gimme == G_ARRAY) {
2482 EXTEND_MORTAL(SP - newsp);
2483 for (mark = newsp + 1; mark <= SP; mark++) {
2484 if (*mark != &PL_sv_undef
2485 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2486 /* Might be flattened array after $#array = */
2493 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2494 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2497 /* Can be a localized value subject to deletion. */
2498 PL_tmps_stack[++PL_tmps_ix] = *mark;
2499 (void)SvREFCNT_inc(*mark);
2505 if (gimme == G_SCALAR) {
2509 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2511 *MARK = SvREFCNT_inc(TOPs);
2516 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2518 *MARK = sv_mortalcopy(sv);
2523 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2527 *MARK = &PL_sv_undef;
2531 else if (gimme == G_ARRAY) {
2533 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2534 if (!SvTEMP(*MARK)) {
2535 *MARK = sv_mortalcopy(*MARK);
2536 TAINT_NOT; /* Each item is independent */
2545 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2546 PL_curpm = newpm; /* ... and pop $1 et al */
2549 return cx->blk_sub.retop;
2554 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2556 SV *dbsv = GvSV(PL_DBsub);
2559 if (!PERLDB_SUB_NN) {
2562 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2563 || strEQ(GvNAME(gv), "END")
2564 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2565 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2566 && (gv = (GV*)*svp) ))) {
2567 /* Use GV from the stack as a fallback. */
2568 /* GV is potentially non-unique, or contain different CV. */
2569 SV *tmp = newRV((SV*)cv);
2570 sv_setsv(dbsv, tmp);
2574 gv_efullname3(dbsv, gv, Nullch);
2578 const int type = SvTYPE(dbsv);
2579 if (type < SVt_PVIV && type != SVt_IV)
2580 sv_upgrade(dbsv, SVt_PVIV);
2581 (void)SvIOK_on(dbsv);
2582 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2586 PL_curcopdb = PL_curcop;
2587 cv = GvCV(PL_DBsub);
2597 register PERL_CONTEXT *cx;
2599 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2602 DIE(aTHX_ "Not a CODE reference");
2603 switch (SvTYPE(sv)) {
2604 /* This is overwhelming the most common case: */
2606 if (!(cv = GvCVu((GV*)sv)))
2607 cv = sv_2cv(sv, &stash, &gv, FALSE);
2617 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2619 SP = PL_stack_base + POPMARK;
2622 if (SvGMAGICAL(sv)) {
2626 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2630 sym = SvPV(sv, n_a);
2633 DIE(aTHX_ PL_no_usym, "a subroutine");
2634 if (PL_op->op_private & HINT_STRICT_REFS)
2635 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2636 cv = get_cv(sym, TRUE);
2641 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2642 tryAMAGICunDEREF(to_cv);
2645 if (SvTYPE(cv) == SVt_PVCV)
2650 DIE(aTHX_ "Not a CODE reference");
2651 /* This is the second most common case: */
2661 if (!CvROOT(cv) && !CvXSUB(cv)) {
2666 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2667 if (CvASSERTION(cv) && PL_DBassertion)
2668 sv_setiv(PL_DBassertion, 1);
2670 cv = get_db_sub(&sv, cv);
2671 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2672 DIE(aTHX_ "No DB::sub routine defined");
2675 if (!(CvXSUB(cv))) {
2676 /* This path taken at least 75% of the time */
2678 register I32 items = SP - MARK;
2679 AV* padlist = CvPADLIST(cv);
2680 PUSHBLOCK(cx, CXt_SUB, MARK);
2682 cx->blk_sub.retop = PL_op->op_next;
2684 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2685 * that eval'' ops within this sub know the correct lexical space.
2686 * Owing the speed considerations, we choose instead to search for
2687 * the cv using find_runcv() when calling doeval().
2689 if (CvDEPTH(cv) >= 2) {
2690 PERL_STACK_OVERFLOW_CHECK();
2691 pad_push(padlist, CvDEPTH(cv));
2693 PAD_SET_CUR(padlist, CvDEPTH(cv));
2700 DEBUG_S(PerlIO_printf(Perl_debug_log,
2701 "%p entersub preparing @_\n", thr));
2703 av = (AV*)PAD_SVl(0);
2705 /* @_ is normally not REAL--this should only ever
2706 * happen when DB::sub() calls things that modify @_ */
2711 cx->blk_sub.savearray = GvAV(PL_defgv);
2712 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2713 CX_CURPAD_SAVE(cx->blk_sub);
2714 cx->blk_sub.argarray = av;
2717 if (items > AvMAX(av) + 1) {
2719 if (AvARRAY(av) != ary) {
2720 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2721 SvPV_set(av, (char*)ary);
2723 if (items > AvMAX(av) + 1) {
2724 AvMAX(av) = items - 1;
2725 Renew(ary,items,SV*);
2727 SvPV_set(av, (char*)ary);
2730 Copy(MARK,AvARRAY(av),items,SV*);
2731 AvFILLp(av) = items - 1;
2739 /* warning must come *after* we fully set up the context
2740 * stuff so that __WARN__ handlers can safely dounwind()
2743 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2744 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2745 sub_crush_depth(cv);
2747 DEBUG_S(PerlIO_printf(Perl_debug_log,
2748 "%p entersub returning %p\n", thr, CvSTART(cv)));
2750 RETURNOP(CvSTART(cv));
2753 #ifdef PERL_XSUB_OLDSTYLE
2754 if (CvOLDSTYLE(cv)) {
2755 I32 (*fp3)(int,int,int);
2757 register I32 items = SP - MARK;
2758 /* We dont worry to copy from @_. */
2763 PL_stack_sp = mark + 1;
2764 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2765 items = (*fp3)(CvXSUBANY(cv).any_i32,
2766 MARK - PL_stack_base + 1,
2768 PL_stack_sp = PL_stack_base + items;
2771 #endif /* PERL_XSUB_OLDSTYLE */
2773 I32 markix = TOPMARK;
2778 /* Need to copy @_ to stack. Alternative may be to
2779 * switch stack to @_, and copy return values
2780 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2783 av = GvAV(PL_defgv);
2784 items = AvFILLp(av) + 1; /* @_ is not tieable */
2787 /* Mark is at the end of the stack. */
2789 Copy(AvARRAY(av), SP + 1, items, SV*);
2794 /* We assume first XSUB in &DB::sub is the called one. */
2796 SAVEVPTR(PL_curcop);
2797 PL_curcop = PL_curcopdb;
2800 /* Do we need to open block here? XXXX */
2801 (void)(*CvXSUB(cv))(aTHX_ cv);
2803 /* Enforce some sanity in scalar context. */
2804 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2805 if (markix > PL_stack_sp - PL_stack_base)
2806 *(PL_stack_base + markix) = &PL_sv_undef;
2808 *(PL_stack_base + markix) = *PL_stack_sp;
2809 PL_stack_sp = PL_stack_base + markix;
2816 assert (0); /* Cannot get here. */
2817 /* This is deliberately moved here as spaghetti code to keep it out of the
2824 /* anonymous or undef'd function leaves us no recourse */
2825 if (CvANON(cv) || !(gv = CvGV(cv)))
2826 DIE(aTHX_ "Undefined subroutine called");
2828 /* autoloaded stub? */
2829 if (cv != GvCV(gv)) {
2832 /* should call AUTOLOAD now? */
2835 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2842 sub_name = sv_newmortal();
2843 gv_efullname3(sub_name, gv, Nullch);
2844 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2848 DIE(aTHX_ "Not a CODE reference");
2854 Perl_sub_crush_depth(pTHX_ CV *cv)
2857 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2859 SV* tmpstr = sv_newmortal();
2860 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2861 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2871 IV elem = SvIV(elemsv);
2873 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2874 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2877 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2878 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2880 elem -= PL_curcop->cop_arybase;
2881 if (SvTYPE(av) != SVt_PVAV)
2883 svp = av_fetch(av, elem, lval && !defer);
2885 #ifdef PERL_MALLOC_WRAP
2886 static const char oom_array_extend[] =
2887 "Out of memory during array extend"; /* Duplicated in av.c */
2888 if (SvUOK(elemsv)) {
2889 const UV uv = SvUV(elemsv);
2890 elem = uv > IV_MAX ? IV_MAX : uv;
2892 else if (SvNOK(elemsv))
2893 elem = (IV)SvNV(elemsv);
2895 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2897 if (!svp || *svp == &PL_sv_undef) {
2900 DIE(aTHX_ PL_no_aelem, elem);
2901 lv = sv_newmortal();
2902 sv_upgrade(lv, SVt_PVLV);
2904 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2905 LvTARG(lv) = SvREFCNT_inc(av);
2906 LvTARGOFF(lv) = elem;
2911 if (PL_op->op_private & OPpLVAL_INTRO)
2912 save_aelem(av, elem, svp);
2913 else if (PL_op->op_private & OPpDEREF)
2914 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2916 sv = (svp ? *svp : &PL_sv_undef);
2917 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2918 sv = sv_mortalcopy(sv);
2924 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2930 Perl_croak(aTHX_ PL_no_modify);
2931 if (SvTYPE(sv) < SVt_RV)
2932 sv_upgrade(sv, SVt_RV);
2933 else if (SvTYPE(sv) >= SVt_PV) {
2940 SvRV_set(sv, NEWSV(355,0));
2943 SvRV_set(sv, (SV*)newAV());
2946 SvRV_set(sv, (SV*)newHV());
2961 if (SvTYPE(rsv) == SVt_PVCV) {
2967 SETs(method_common(sv, Null(U32*)));
2975 U32 hash = SvUVX(sv);
2977 XPUSHs(method_common(sv, &hash));
2982 S_method_common(pTHX_ SV* meth, U32* hashp)
2989 const char* packname = 0;
2990 SV *packsv = Nullsv;
2992 const char *name = SvPV(meth, namelen);
2994 sv = *(PL_stack_base + TOPMARK + 1);
2997 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3006 /* this isn't a reference */
3009 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3011 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3013 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3020 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3021 !(ob=(SV*)GvIO(iogv)))
3023 /* this isn't the name of a filehandle either */
3025 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3026 ? !isIDFIRST_utf8((U8*)packname)
3027 : !isIDFIRST(*packname)
3030 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3031 SvOK(sv) ? "without a package or object reference"
3032 : "on an undefined value");
3034 /* assume it's a package name */
3035 stash = gv_stashpvn(packname, packlen, FALSE);
3039 SV* ref = newSViv(PTR2IV(stash));
3040 hv_store(PL_stashcache, packname, packlen, ref, 0);
3044 /* it _is_ a filehandle name -- replace with a reference */
3045 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3048 /* if we got here, ob should be a reference or a glob */
3049 if (!ob || !(SvOBJECT(ob)
3050 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3053 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3057 stash = SvSTASH(ob);
3060 /* NOTE: stash may be null, hope hv_fetch_ent and
3061 gv_fetchmethod can cope (it seems they can) */
3063 /* shortcut for simple names */
3065 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3067 gv = (GV*)HeVAL(he);
3068 if (isGV(gv) && GvCV(gv) &&
3069 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3070 return (SV*)GvCV(gv);
3074 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3077 /* This code tries to figure out just what went wrong with
3078 gv_fetchmethod. It therefore needs to duplicate a lot of
3079 the internals of that function. We can't move it inside
3080 Perl_gv_fetchmethod_autoload(), however, since that would
3081 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3084 const char* leaf = name;
3085 const char* sep = Nullch;
3088 for (p = name; *p; p++) {
3090 sep = p, leaf = p + 1;
3091 else if (*p == ':' && *(p + 1) == ':')
3092 sep = p, leaf = p + 2;
3094 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3095 /* the method name is unqualified or starts with SUPER:: */
3096 packname = sep ? CopSTASHPV(PL_curcop) :
3097 stash ? HvNAME(stash) : packname;
3100 "Can't use anonymous symbol table for method lookup");
3102 packlen = strlen(packname);
3105 /* the method name is qualified */
3107 packlen = sep - name;
3110 /* we're relying on gv_fetchmethod not autovivifying the stash */
3111 if (gv_stashpvn(packname, packlen, FALSE)) {
3113 "Can't locate object method \"%s\" via package \"%.*s\"",
3114 leaf, (int)packlen, packname);
3118 "Can't locate object method \"%s\" via package \"%.*s\""
3119 " (perhaps you forgot to load \"%.*s\"?)",
3120 leaf, (int)packlen, packname, (int)packlen, packname);
3123 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3128 * c-indentation-style: bsd
3130 * indent-tabs-mode: t
3133 * vim: ts=8 sts=4 sw=4 noet: