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);
152 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
153 bool rbyte = !DO_UTF8(right), rcopied = FALSE;
155 if (TARG == right && right != left) {
156 right = sv_2mortal(newSVpvn(rpv, rlen));
157 rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
162 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 */
171 if (SvGMAGICAL(left))
172 mg_get(left); /* or mg_get(left) may happen here */
175 lpv = SvPV_nomg(left, llen);
176 lbyte = !DO_UTF8(left);
181 if (lbyte != rbyte) {
183 sv_utf8_upgrade_nomg(TARG);
186 right = sv_2mortal(newSVpvn(rpv, rlen));
187 sv_utf8_upgrade_nomg(right);
188 rpv = SvPV(right, rlen);
191 sv_catpvn_nomg(TARG, rpv, rlen);
202 if (PL_op->op_flags & OPf_MOD) {
203 if (PL_op->op_private & OPpLVAL_INTRO)
204 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
205 if (PL_op->op_private & OPpDEREF) {
207 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
216 tryAMAGICunTARGET(iter, 0);
217 PL_last_in_gv = (GV*)(*PL_stack_sp--);
218 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
219 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
220 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
223 XPUSHs((SV*)PL_last_in_gv);
226 PL_last_in_gv = (GV*)(*PL_stack_sp--);
229 return do_readline();
234 dSP; tryAMAGICbinSET(eq,0);
235 #ifndef NV_PRESERVES_UV
236 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
238 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
242 #ifdef PERL_PRESERVE_IVUV
245 /* Unless the left argument is integer in range we are going
246 to have to use NV maths. Hence only attempt to coerce the
247 right argument if we know the left is integer. */
250 bool auvok = SvUOK(TOPm1s);
251 bool buvok = SvUOK(TOPs);
253 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
254 /* Casting IV to UV before comparison isn't going to matter
255 on 2s complement. On 1s complement or sign&magnitude
256 (if we have any of them) it could to make negative zero
257 differ from normal zero. As I understand it. (Need to
258 check - is negative zero implementation defined behaviour
260 UV buv = SvUVX(POPs);
261 UV auv = SvUVX(TOPs);
263 SETs(boolSV(auv == buv));
266 { /* ## Mixed IV,UV ## */
270 /* == is commutative so doesn't matter which is left or right */
272 /* top of stack (b) is the iv */
281 /* As uv is a UV, it's >0, so it cannot be == */
285 /* we know iv is >= 0 */
286 SETs(boolSV((UV)iv == SvUVX(uvp)));
294 SETs(boolSV(TOPn == value));
302 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
303 DIE(aTHX_ PL_no_modify);
304 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
305 && SvIVX(TOPs) != IV_MAX)
307 SvIV_set(TOPs, SvIVX(TOPs) + 1);
308 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
310 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
323 RETURNOP(cLOGOP->op_other);
329 /* Most of this is lifted straight from pp_defined */
334 if (!sv || !SvANY(sv)) {
336 RETURNOP(cLOGOP->op_other);
339 switch (SvTYPE(sv)) {
341 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
345 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
349 if (CvROOT(sv) || CvXSUB(sv))
360 RETURNOP(cLOGOP->op_other);
365 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
366 useleft = USE_LEFT(TOPm1s);
367 #ifdef PERL_PRESERVE_IVUV
368 /* We must see if we can perform the addition with integers if possible,
369 as the integer code detects overflow while the NV code doesn't.
370 If either argument hasn't had a numeric conversion yet attempt to get
371 the IV. It's important to do this now, rather than just assuming that
372 it's not IOK as a PV of "9223372036854775806" may not take well to NV
373 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
374 integer in case the second argument is IV=9223372036854775806
375 We can (now) rely on sv_2iv to do the right thing, only setting the
376 public IOK flag if the value in the NV (or PV) slot is truly integer.
378 A side effect is that this also aggressively prefers integer maths over
379 fp maths for integer values.
381 How to detect overflow?
383 C 99 section 6.2.6.1 says
385 The range of nonnegative values of a signed integer type is a subrange
386 of the corresponding unsigned integer type, and the representation of
387 the same value in each type is the same. A computation involving
388 unsigned operands can never overflow, because a result that cannot be
389 represented by the resulting unsigned integer type is reduced modulo
390 the number that is one greater than the largest value that can be
391 represented by the resulting type.
395 which I read as "unsigned ints wrap."
397 signed integer overflow seems to be classed as "exception condition"
399 If an exceptional condition occurs during the evaluation of an
400 expression (that is, if the result is not mathematically defined or not
401 in the range of representable values for its type), the behavior is
404 (6.5, the 5th paragraph)
406 I had assumed that on 2s complement machines signed arithmetic would
407 wrap, hence coded pp_add and pp_subtract on the assumption that
408 everything perl builds on would be happy. After much wailing and
409 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
410 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
411 unsigned code below is actually shorter than the old code. :-)
416 /* Unless the left argument is integer in range we are going to have to
417 use NV maths. Hence only attempt to coerce the right argument if
418 we know the left is integer. */
426 /* left operand is undef, treat as zero. + 0 is identity,
427 Could SETi or SETu right now, but space optimise by not adding
428 lots of code to speed up what is probably a rarish case. */
430 /* Left operand is defined, so is it IV? */
433 if ((auvok = SvUOK(TOPm1s)))
436 register IV aiv = SvIVX(TOPm1s);
439 auvok = 1; /* Now acting as a sign flag. */
440 } else { /* 2s complement assumption for IV_MIN */
448 bool result_good = 0;
451 bool buvok = SvUOK(TOPs);
456 register IV biv = SvIVX(TOPs);
463 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
464 else "IV" now, independent of how it came in.
465 if a, b represents positive, A, B negative, a maps to -A etc
470 all UV maths. negate result if A negative.
471 add if signs same, subtract if signs differ. */
477 /* Must get smaller */
483 /* result really should be -(auv-buv). as its negation
484 of true value, need to swap our result flag */
501 if (result <= (UV)IV_MIN)
504 /* result valid, but out of range for IV. */
509 } /* Overflow, drop through to NVs. */
516 /* left operand is undef, treat as zero. + 0.0 is identity. */
520 SETn( value + TOPn );
528 AV *av = PL_op->op_flags & OPf_SPECIAL ?
529 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
530 U32 lval = PL_op->op_flags & OPf_MOD;
531 SV** svp = av_fetch(av, PL_op->op_private, lval);
532 SV *sv = (svp ? *svp : &PL_sv_undef);
534 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
535 sv = sv_mortalcopy(sv);
544 do_join(TARG, *MARK, MARK, SP);
555 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
556 * will be enough to hold an OP*.
558 SV* sv = sv_newmortal();
559 sv_upgrade(sv, SVt_PVLV);
561 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
569 /* Oversized hot code. */
573 dSP; dMARK; dORIGMARK;
579 if (PL_op->op_flags & OPf_STACKED)
584 if (gv && (io = GvIO(gv))
585 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
588 if (MARK == ORIGMARK) {
589 /* If using default handle then we need to make space to
590 * pass object as 1st arg, so move other args up ...
594 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
598 *MARK = SvTIED_obj((SV*)io, mg);
601 call_method("PRINT", G_SCALAR);
609 if (!(io = GvIO(gv))) {
610 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
611 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
613 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
614 report_evil_fh(gv, io, PL_op->op_type);
615 SETERRNO(EBADF,RMS_IFI);
618 else if (!(fp = IoOFP(io))) {
619 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
621 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
622 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
623 report_evil_fh(gv, io, PL_op->op_type);
625 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
630 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
632 if (!do_print(*MARK, fp))
636 if (!do_print(PL_ofs_sv, fp)) { /* $, */
645 if (!do_print(*MARK, fp))
653 if (PL_ors_sv && SvOK(PL_ors_sv))
654 if (!do_print(PL_ors_sv, fp)) /* $\ */
657 if (IoFLAGS(io) & IOf_FLUSH)
658 if (PerlIO_flush(fp) == EOF)
679 tryAMAGICunDEREF(to_av);
682 if (SvTYPE(av) != SVt_PVAV)
683 DIE(aTHX_ "Not an ARRAY reference");
684 if (PL_op->op_flags & OPf_REF) {
689 if (GIMME == G_SCALAR)
690 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
694 else if (PL_op->op_flags & OPf_MOD
695 && PL_op->op_private & OPpLVAL_INTRO)
696 Perl_croak(aTHX_ PL_no_localize_ref);
699 if (SvTYPE(sv) == SVt_PVAV) {
701 if (PL_op->op_flags & OPf_REF) {
706 if (GIMME == G_SCALAR)
707 Perl_croak(aTHX_ "Can't return array to lvalue"
716 if (SvTYPE(sv) != SVt_PVGV) {
717 if (SvGMAGICAL(sv)) {
723 if (PL_op->op_flags & OPf_REF ||
724 PL_op->op_private & HINT_STRICT_REFS)
725 DIE(aTHX_ PL_no_usym, "an ARRAY");
726 if (ckWARN(WARN_UNINITIALIZED))
728 if (GIMME == G_ARRAY) {
734 if ((PL_op->op_flags & OPf_SPECIAL) &&
735 !(PL_op->op_flags & OPf_MOD))
737 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
739 && (!is_gv_magical_sv(sv,0)
740 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
746 if (PL_op->op_private & HINT_STRICT_REFS)
747 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
748 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
755 if (PL_op->op_private & OPpLVAL_INTRO)
757 if (PL_op->op_flags & OPf_REF) {
762 if (GIMME == G_SCALAR)
763 Perl_croak(aTHX_ "Can't return array to lvalue"
771 if (GIMME == G_ARRAY) {
772 I32 maxarg = AvFILL(av) + 1;
773 (void)POPs; /* XXXX May be optimized away? */
775 if (SvRMAGICAL(av)) {
777 for (i=0; i < (U32)maxarg; i++) {
778 SV **svp = av_fetch(av, i, FALSE);
779 /* See note in pp_helem, and bug id #27839 */
781 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
786 Copy(AvARRAY(av), SP+1, maxarg, SV*);
790 else if (GIMME_V == G_SCALAR) {
792 I32 maxarg = AvFILL(av) + 1;
806 tryAMAGICunDEREF(to_hv);
809 if (SvTYPE(hv) != SVt_PVHV)
810 DIE(aTHX_ "Not a HASH reference");
811 if (PL_op->op_flags & OPf_REF) {
816 if (gimme != G_ARRAY)
817 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
821 else if (PL_op->op_flags & OPf_MOD
822 && PL_op->op_private & OPpLVAL_INTRO)
823 Perl_croak(aTHX_ PL_no_localize_ref);
826 if (SvTYPE(sv) == SVt_PVHV) {
828 if (PL_op->op_flags & OPf_REF) {
833 if (gimme != G_ARRAY)
834 Perl_croak(aTHX_ "Can't return hash to lvalue"
843 if (SvTYPE(sv) != SVt_PVGV) {
844 if (SvGMAGICAL(sv)) {
850 if (PL_op->op_flags & OPf_REF ||
851 PL_op->op_private & HINT_STRICT_REFS)
852 DIE(aTHX_ PL_no_usym, "a HASH");
853 if (ckWARN(WARN_UNINITIALIZED))
855 if (gimme == G_ARRAY) {
861 if ((PL_op->op_flags & OPf_SPECIAL) &&
862 !(PL_op->op_flags & OPf_MOD))
864 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
866 && (!is_gv_magical_sv(sv,0)
867 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
873 if (PL_op->op_private & HINT_STRICT_REFS)
874 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
875 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
882 if (PL_op->op_private & OPpLVAL_INTRO)
884 if (PL_op->op_flags & OPf_REF) {
889 if (gimme != G_ARRAY)
890 Perl_croak(aTHX_ "Can't return hash to lvalue"
898 if (gimme == G_ARRAY) { /* array wanted */
899 *PL_stack_sp = (SV*)hv;
902 else if (gimme == G_SCALAR) {
904 TARG = Perl_hv_scalar(aTHX_ hv);
911 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
917 if (ckWARN(WARN_MISC)) {
918 if (relem == firstrelem &&
920 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
921 SvTYPE(SvRV(*relem)) == SVt_PVHV))
923 Perl_warner(aTHX_ packWARN(WARN_MISC),
924 "Reference found where even-sized list expected");
927 Perl_warner(aTHX_ packWARN(WARN_MISC),
928 "Odd number of elements in hash assignment");
931 tmpstr = NEWSV(29,0);
932 didstore = hv_store_ent(hash,*relem,tmpstr,0);
933 if (SvMAGICAL(hash)) {
934 if (SvSMAGICAL(tmpstr))
946 SV **lastlelem = PL_stack_sp;
947 SV **lastrelem = PL_stack_base + POPMARK;
948 SV **firstrelem = PL_stack_base + POPMARK + 1;
949 SV **firstlelem = lastrelem + 1;
962 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
965 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
968 /* If there's a common identifier on both sides we have to take
969 * special care that assigning the identifier on the left doesn't
970 * clobber a value on the right that's used later in the list.
972 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
973 EXTEND_MORTAL(lastrelem - firstrelem + 1);
974 for (relem = firstrelem; relem <= lastrelem; relem++) {
977 TAINT_NOT; /* Each item is independent */
978 *relem = sv_mortalcopy(sv);
988 while (lelem <= lastlelem) {
989 TAINT_NOT; /* Each item stands on its own, taintwise. */
991 switch (SvTYPE(sv)) {
994 magic = SvMAGICAL(ary) != 0;
996 av_extend(ary, lastrelem - relem);
998 while (relem <= lastrelem) { /* gobble up all the rest */
1001 sv = newSVsv(*relem);
1003 didstore = av_store(ary,i++,sv);
1013 case SVt_PVHV: { /* normal hash */
1017 magic = SvMAGICAL(hash) != 0;
1019 firsthashrelem = relem;
1021 while (relem < lastrelem) { /* gobble up all the rest */
1026 sv = &PL_sv_no, relem++;
1027 tmpstr = NEWSV(29,0);
1029 sv_setsv(tmpstr,*relem); /* value */
1030 *(relem++) = tmpstr;
1031 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1032 /* key overwrites an existing entry */
1034 didstore = hv_store_ent(hash,sv,tmpstr,0);
1036 if (SvSMAGICAL(tmpstr))
1043 if (relem == lastrelem) {
1044 do_oddball(hash, relem, firstrelem);
1050 if (SvIMMORTAL(sv)) {
1051 if (relem <= lastrelem)
1055 if (relem <= lastrelem) {
1056 sv_setsv(sv, *relem);
1060 sv_setsv(sv, &PL_sv_undef);
1065 if (PL_delaymagic & ~DM_DELAY) {
1066 if (PL_delaymagic & DM_UID) {
1067 #ifdef HAS_SETRESUID
1068 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1069 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1072 # ifdef HAS_SETREUID
1073 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1074 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1077 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1078 (void)setruid(PL_uid);
1079 PL_delaymagic &= ~DM_RUID;
1081 # endif /* HAS_SETRUID */
1083 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1084 (void)seteuid(PL_euid);
1085 PL_delaymagic &= ~DM_EUID;
1087 # endif /* HAS_SETEUID */
1088 if (PL_delaymagic & DM_UID) {
1089 if (PL_uid != PL_euid)
1090 DIE(aTHX_ "No setreuid available");
1091 (void)PerlProc_setuid(PL_uid);
1093 # endif /* HAS_SETREUID */
1094 #endif /* HAS_SETRESUID */
1095 PL_uid = PerlProc_getuid();
1096 PL_euid = PerlProc_geteuid();
1098 if (PL_delaymagic & DM_GID) {
1099 #ifdef HAS_SETRESGID
1100 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1101 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1104 # ifdef HAS_SETREGID
1105 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1106 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1109 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1110 (void)setrgid(PL_gid);
1111 PL_delaymagic &= ~DM_RGID;
1113 # endif /* HAS_SETRGID */
1115 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1116 (void)setegid(PL_egid);
1117 PL_delaymagic &= ~DM_EGID;
1119 # endif /* HAS_SETEGID */
1120 if (PL_delaymagic & DM_GID) {
1121 if (PL_gid != PL_egid)
1122 DIE(aTHX_ "No setregid available");
1123 (void)PerlProc_setgid(PL_gid);
1125 # endif /* HAS_SETREGID */
1126 #endif /* HAS_SETRESGID */
1127 PL_gid = PerlProc_getgid();
1128 PL_egid = PerlProc_getegid();
1130 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1134 if (gimme == G_VOID)
1135 SP = firstrelem - 1;
1136 else if (gimme == G_SCALAR) {
1139 SETi(lastrelem - firstrelem + 1 - duplicates);
1146 /* Removes from the stack the entries which ended up as
1147 * duplicated keys in the hash (fix for [perl #24380]) */
1148 Move(firsthashrelem + duplicates,
1149 firsthashrelem, duplicates, SV**);
1150 lastrelem -= duplicates;
1155 SP = firstrelem + (lastlelem - firstlelem);
1156 lelem = firstlelem + (relem - firstrelem);
1158 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1166 register PMOP *pm = cPMOP;
1167 SV *rv = sv_newmortal();
1168 SV *sv = newSVrv(rv, "Regexp");
1169 if (pm->op_pmdynflags & PMdf_TAINTED)
1171 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1178 register PMOP *pm = cPMOP;
1184 I32 r_flags = REXEC_CHECKED;
1185 char *truebase; /* Start of string */
1186 register REGEXP *rx = PM_GETRE(pm);
1191 I32 oldsave = PL_savestack_ix;
1192 I32 update_minmatch = 1;
1193 I32 had_zerolen = 0;
1195 if (PL_op->op_flags & OPf_STACKED)
1197 else if (PL_op->op_private & OPpTARGET_MY)
1204 PUTBACK; /* EVAL blocks need stack_sp. */
1205 s = SvPV(TARG, len);
1208 DIE(aTHX_ "panic: pp_match");
1209 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1210 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1213 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1215 /* PMdf_USED is set after a ?? matches once */
1216 if (pm->op_pmdynflags & PMdf_USED) {
1218 if (gimme == G_ARRAY)
1223 /* empty pattern special-cased to use last successful pattern if possible */
1224 if (!rx->prelen && PL_curpm) {
1229 if (rx->minlen > (I32)len)
1234 /* XXXX What part of this is needed with true \G-support? */
1235 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1237 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1238 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1239 if (mg && mg->mg_len >= 0) {
1240 if (!(rx->reganch & ROPT_GPOS_SEEN))
1241 rx->endp[0] = rx->startp[0] = mg->mg_len;
1242 else if (rx->reganch & ROPT_ANCH_GPOS) {
1243 r_flags |= REXEC_IGNOREPOS;
1244 rx->endp[0] = rx->startp[0] = mg->mg_len;
1246 minmatch = (mg->mg_flags & MGf_MINMATCH);
1247 update_minmatch = 0;
1251 if ((!global && rx->nparens)
1252 || SvTEMP(TARG) || PL_sawampersand)
1253 r_flags |= REXEC_COPY_STR;
1255 r_flags |= REXEC_SCREAM;
1258 if (global && rx->startp[0] != -1) {
1259 t = s = rx->endp[0] + truebase;
1260 if ((s + rx->minlen) > strend)
1262 if (update_minmatch++)
1263 minmatch = had_zerolen;
1265 if (rx->reganch & RE_USE_INTUIT &&
1266 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1267 PL_bostr = truebase;
1268 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1272 if ( (rx->reganch & ROPT_CHECK_ALL)
1274 && ((rx->reganch & ROPT_NOSCAN)
1275 || !((rx->reganch & RE_INTUIT_TAIL)
1276 && (r_flags & REXEC_SCREAM)))
1277 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1280 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1283 if (dynpm->op_pmflags & PMf_ONCE)
1284 dynpm->op_pmdynflags |= PMdf_USED;
1293 RX_MATCH_TAINTED_on(rx);
1294 TAINT_IF(RX_MATCH_TAINTED(rx));
1295 if (gimme == G_ARRAY) {
1296 I32 nparens, i, len;
1298 nparens = rx->nparens;
1299 if (global && !nparens)
1303 SPAGAIN; /* EVAL blocks could move the stack. */
1304 EXTEND(SP, nparens + i);
1305 EXTEND_MORTAL(nparens + i);
1306 for (i = !i; i <= nparens; i++) {
1307 PUSHs(sv_newmortal());
1309 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1310 len = rx->endp[i] - rx->startp[i];
1311 s = rx->startp[i] + truebase;
1312 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1313 len < 0 || len > strend - s)
1314 DIE(aTHX_ "panic: pp_match start/end pointers");
1315 sv_setpvn(*SP, s, len);
1316 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1321 if (dynpm->op_pmflags & PMf_CONTINUE) {
1323 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1324 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1326 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1327 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1329 if (rx->startp[0] != -1) {
1330 mg->mg_len = rx->endp[0];
1331 if (rx->startp[0] == rx->endp[0])
1332 mg->mg_flags |= MGf_MINMATCH;
1334 mg->mg_flags &= ~MGf_MINMATCH;
1337 had_zerolen = (rx->startp[0] != -1
1338 && rx->startp[0] == rx->endp[0]);
1339 PUTBACK; /* EVAL blocks may use stack */
1340 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1345 LEAVE_SCOPE(oldsave);
1351 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1352 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1354 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1355 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1357 if (rx->startp[0] != -1) {
1358 mg->mg_len = rx->endp[0];
1359 if (rx->startp[0] == rx->endp[0])
1360 mg->mg_flags |= MGf_MINMATCH;
1362 mg->mg_flags &= ~MGf_MINMATCH;
1365 LEAVE_SCOPE(oldsave);
1369 yup: /* Confirmed by INTUIT */
1371 RX_MATCH_TAINTED_on(rx);
1372 TAINT_IF(RX_MATCH_TAINTED(rx));
1374 if (dynpm->op_pmflags & PMf_ONCE)
1375 dynpm->op_pmdynflags |= PMdf_USED;
1376 if (RX_MATCH_COPIED(rx))
1377 Safefree(rx->subbeg);
1378 RX_MATCH_COPIED_off(rx);
1379 rx->subbeg = Nullch;
1381 rx->subbeg = truebase;
1382 rx->startp[0] = s - truebase;
1383 if (RX_MATCH_UTF8(rx)) {
1384 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1385 rx->endp[0] = t - truebase;
1388 rx->endp[0] = s - truebase + rx->minlen;
1390 rx->sublen = strend - truebase;
1393 if (PL_sawampersand) {
1395 #ifdef PERL_COPY_ON_WRITE
1396 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1398 PerlIO_printf(Perl_debug_log,
1399 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1400 (int) SvTYPE(TARG), truebase, t,
1403 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1404 rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1405 assert (SvPOKp(rx->saved_copy));
1410 rx->subbeg = savepvn(t, strend - t);
1411 #ifdef PERL_COPY_ON_WRITE
1412 rx->saved_copy = Nullsv;
1415 rx->sublen = strend - t;
1416 RX_MATCH_COPIED_on(rx);
1417 off = rx->startp[0] = s - t;
1418 rx->endp[0] = off + rx->minlen;
1420 else { /* startp/endp are used by @- @+. */
1421 rx->startp[0] = s - truebase;
1422 rx->endp[0] = s - truebase + rx->minlen;
1424 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1425 LEAVE_SCOPE(oldsave);
1430 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1431 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1432 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1437 LEAVE_SCOPE(oldsave);
1438 if (gimme == G_ARRAY)
1444 Perl_do_readline(pTHX)
1446 dSP; dTARGETSTACKED;
1451 register IO *io = GvIO(PL_last_in_gv);
1452 register I32 type = PL_op->op_type;
1453 I32 gimme = GIMME_V;
1456 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1458 XPUSHs(SvTIED_obj((SV*)io, mg));
1461 call_method("READLINE", gimme);
1464 if (gimme == G_SCALAR) {
1466 SvSetSV_nosteal(TARG, result);
1475 if (IoFLAGS(io) & IOf_ARGV) {
1476 if (IoFLAGS(io) & IOf_START) {
1478 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1479 IoFLAGS(io) &= ~IOf_START;
1480 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1481 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1482 SvSETMAGIC(GvSV(PL_last_in_gv));
1487 fp = nextargv(PL_last_in_gv);
1488 if (!fp) { /* Note: fp != IoIFP(io) */
1489 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1492 else if (type == OP_GLOB)
1493 fp = Perl_start_glob(aTHX_ POPs, io);
1495 else if (type == OP_GLOB)
1497 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1498 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1502 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1503 && (!io || !(IoFLAGS(io) & IOf_START))) {
1504 if (type == OP_GLOB)
1505 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1506 "glob failed (can't start child: %s)",
1509 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1511 if (gimme == G_SCALAR) {
1512 /* undef TARG, and push that undefined value */
1513 if (type != OP_RCATLINE) {
1514 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1522 if (gimme == G_SCALAR) {
1526 (void)SvUPGRADE(sv, SVt_PV);
1527 tmplen = SvLEN(sv); /* remember if already alloced */
1528 if (!tmplen && !SvREADONLY(sv))
1529 Sv_Grow(sv, 80); /* try short-buffering it */
1531 if (type == OP_RCATLINE && SvOK(sv)) {
1534 (void)SvPV_force(sv, n_a);
1540 sv = sv_2mortal(NEWSV(57, 80));
1544 /* This should not be marked tainted if the fp is marked clean */
1545 #define MAYBE_TAINT_LINE(io, sv) \
1546 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1551 /* delay EOF state for a snarfed empty file */
1552 #define SNARF_EOF(gimme,rs,io,sv) \
1553 (gimme != G_SCALAR || SvCUR(sv) \
1554 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1558 if (!sv_gets(sv, fp, offset)
1560 || SNARF_EOF(gimme, PL_rs, io, sv)
1561 || PerlIO_error(fp)))
1563 PerlIO_clearerr(fp);
1564 if (IoFLAGS(io) & IOf_ARGV) {
1565 fp = nextargv(PL_last_in_gv);
1568 (void)do_close(PL_last_in_gv, FALSE);
1570 else if (type == OP_GLOB) {
1571 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1572 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1573 "glob failed (child exited with status %d%s)",
1574 (int)(STATUS_CURRENT >> 8),
1575 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1578 if (gimme == G_SCALAR) {
1579 if (type != OP_RCATLINE) {
1580 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1586 MAYBE_TAINT_LINE(io, sv);
1589 MAYBE_TAINT_LINE(io, sv);
1591 IoFLAGS(io) |= IOf_NOLINE;
1595 if (type == OP_GLOB) {
1598 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1599 tmps = SvEND(sv) - 1;
1600 if (*tmps == *SvPVX(PL_rs)) {
1605 for (tmps = SvPVX(sv); *tmps; tmps++)
1606 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1607 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1609 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1610 (void)POPs; /* Unmatched wildcard? Chuck it... */
1613 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1614 const U8 *s = (U8*)SvPVX(sv) + offset;
1615 const STRLEN len = SvCUR(sv) - offset;
1618 if (ckWARN(WARN_UTF8) &&
1619 !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1620 /* Emulate :encoding(utf8) warning in the same case. */
1621 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1622 "utf8 \"\\x%02X\" does not map to Unicode",
1623 f < (U8*)SvEND(sv) ? *f : 0);
1625 if (gimme == G_ARRAY) {
1626 if (SvLEN(sv) - SvCUR(sv) > 20) {
1627 SvLEN_set(sv, SvCUR(sv)+1);
1628 SvPV_renew(sv, SvLEN(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 SvLEN_set(sv, new_len);
1638 SvPV_renew(sv, SvLEN(sv));
1647 register PERL_CONTEXT *cx;
1648 I32 gimme = OP_GIMME(PL_op, -1);
1651 if (cxstack_ix >= 0)
1652 gimme = cxstack[cxstack_ix].blk_gimme;
1660 PUSHBLOCK(cx, CXt_BLOCK, SP);
1672 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1673 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1675 #ifdef PERL_COPY_ON_WRITE
1676 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1678 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1682 if (SvTYPE(hv) == SVt_PVHV) {
1683 if (PL_op->op_private & OPpLVAL_INTRO) {
1686 /* does the element we're localizing already exist? */
1688 /* can we determine whether it exists? */
1690 || mg_find((SV*)hv, PERL_MAGIC_env)
1691 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1692 /* Try to preserve the existenceness of a tied hash
1693 * element by using EXISTS and DELETE if possible.
1694 * Fallback to FETCH and STORE otherwise */
1695 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1696 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1697 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1699 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1702 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1703 svp = he ? &HeVAL(he) : 0;
1709 if (!svp || *svp == &PL_sv_undef) {
1714 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1716 lv = sv_newmortal();
1717 sv_upgrade(lv, SVt_PVLV);
1719 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1720 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1721 LvTARG(lv) = SvREFCNT_inc(hv);
1726 if (PL_op->op_private & OPpLVAL_INTRO) {
1727 if (HvNAME(hv) && isGV(*svp))
1728 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1732 char *key = SvPV(keysv, keylen);
1733 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1735 save_helem(hv, keysv, svp);
1738 else if (PL_op->op_private & OPpDEREF)
1739 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1741 sv = (svp ? *svp : &PL_sv_undef);
1742 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1743 * Pushing the magical RHS on to the stack is useless, since
1744 * that magic is soon destined to be misled by the local(),
1745 * and thus the later pp_sassign() will fail to mg_get() the
1746 * old value. This should also cure problems with delayed
1747 * mg_get()s. GSAR 98-07-03 */
1748 if (!lval && SvGMAGICAL(sv))
1749 sv = sv_mortalcopy(sv);
1757 register PERL_CONTEXT *cx;
1763 if (PL_op->op_flags & OPf_SPECIAL) {
1764 cx = &cxstack[cxstack_ix];
1765 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1770 gimme = OP_GIMME(PL_op, -1);
1772 if (cxstack_ix >= 0)
1773 gimme = cxstack[cxstack_ix].blk_gimme;
1779 if (gimme == G_VOID)
1781 else if (gimme == G_SCALAR) {
1784 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1787 *MARK = sv_mortalcopy(TOPs);
1790 *MARK = &PL_sv_undef;
1794 else if (gimme == G_ARRAY) {
1795 /* in case LEAVE wipes old return values */
1796 for (mark = newsp + 1; mark <= SP; mark++) {
1797 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1798 *mark = sv_mortalcopy(*mark);
1799 TAINT_NOT; /* Each item is independent */
1803 PL_curpm = newpm; /* Don't pop $1 et al till now */
1813 register PERL_CONTEXT *cx;
1819 cx = &cxstack[cxstack_ix];
1820 if (CxTYPE(cx) != CXt_LOOP)
1821 DIE(aTHX_ "panic: pp_iter");
1823 itersvp = CxITERVAR(cx);
1824 av = cx->blk_loop.iterary;
1825 if (SvTYPE(av) != SVt_PVAV) {
1826 /* iterate ($min .. $max) */
1827 if (cx->blk_loop.iterlval) {
1828 /* string increment */
1829 register SV* cur = cx->blk_loop.iterlval;
1831 const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1832 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1833 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1834 /* safe to reuse old SV */
1835 sv_setsv(*itersvp, cur);
1839 /* we need a fresh SV every time so that loop body sees a
1840 * completely new SV for closures/references to work as
1843 *itersvp = newSVsv(cur);
1844 SvREFCNT_dec(oldsv);
1846 if (strEQ(SvPVX(cur), max))
1847 sv_setiv(cur, 0); /* terminate next time */
1854 /* integer increment */
1855 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1858 /* don't risk potential race */
1859 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1860 /* safe to reuse old SV */
1861 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1865 /* we need a fresh SV every time so that loop body sees a
1866 * completely new SV for closures/references to work as they
1869 *itersvp = newSViv(cx->blk_loop.iterix++);
1870 SvREFCNT_dec(oldsv);
1876 if (PL_op->op_private & OPpITER_REVERSED) {
1877 /* In reverse, use itermax as the min :-) */
1878 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1881 if (SvMAGICAL(av) || AvREIFY(av)) {
1882 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1889 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1893 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1897 if (SvMAGICAL(av) || AvREIFY(av)) {
1898 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1905 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1909 if (sv && SvREFCNT(sv) == 0) {
1911 Perl_croak(aTHX_ "Use of freed value in iteration");
1918 if (av != PL_curstack && sv == &PL_sv_undef) {
1919 SV *lv = cx->blk_loop.iterlval;
1920 if (lv && SvREFCNT(lv) > 1) {
1925 SvREFCNT_dec(LvTARG(lv));
1927 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1928 sv_upgrade(lv, SVt_PVLV);
1930 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1932 LvTARG(lv) = SvREFCNT_inc(av);
1933 LvTARGOFF(lv) = cx->blk_loop.iterix;
1934 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1939 *itersvp = SvREFCNT_inc(sv);
1940 SvREFCNT_dec(oldsv);
1948 register PMOP *pm = cPMOP;
1964 register REGEXP *rx = PM_GETRE(pm);
1966 int force_on_match = 0;
1967 I32 oldsave = PL_savestack_ix;
1969 bool doutf8 = FALSE;
1970 #ifdef PERL_COPY_ON_WRITE
1975 /* known replacement string? */
1976 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1977 if (PL_op->op_flags & OPf_STACKED)
1979 else if (PL_op->op_private & OPpTARGET_MY)
1986 #ifdef PERL_COPY_ON_WRITE
1987 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1988 because they make integers such as 256 "false". */
1989 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1992 sv_force_normal_flags(TARG,0);
1995 #ifdef PERL_COPY_ON_WRITE
1999 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2000 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2001 DIE(aTHX_ PL_no_modify);
2004 s = SvPV(TARG, len);
2005 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2007 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2008 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2013 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2017 DIE(aTHX_ "panic: pp_subst");
2020 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2021 maxiters = 2 * slen + 10; /* We can match twice at each
2022 position, once with zero-length,
2023 second time with non-zero. */
2025 if (!rx->prelen && PL_curpm) {
2029 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2030 ? REXEC_COPY_STR : 0;
2032 r_flags |= REXEC_SCREAM;
2035 if (rx->reganch & RE_USE_INTUIT) {
2037 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2041 /* How to do it in subst? */
2042 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2044 && ((rx->reganch & ROPT_NOSCAN)
2045 || !((rx->reganch & RE_INTUIT_TAIL)
2046 && (r_flags & REXEC_SCREAM))))
2051 /* only replace once? */
2052 once = !(rpm->op_pmflags & PMf_GLOBAL);
2054 /* known replacement string? */
2056 /* replacement needing upgrading? */
2057 if (DO_UTF8(TARG) && !doutf8) {
2058 nsv = sv_newmortal();
2061 sv_recode_to_utf8(nsv, PL_encoding);
2063 sv_utf8_upgrade(nsv);
2064 c = SvPV(nsv, clen);
2068 c = SvPV(dstr, clen);
2069 doutf8 = DO_UTF8(dstr);
2077 /* can do inplace substitution? */
2079 #ifdef PERL_COPY_ON_WRITE
2082 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2083 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2084 && (!doutf8 || SvUTF8(TARG))) {
2085 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2086 r_flags | REXEC_CHECKED))
2090 LEAVE_SCOPE(oldsave);
2093 #ifdef PERL_COPY_ON_WRITE
2094 if (SvIsCOW(TARG)) {
2095 assert (!force_on_match);
2099 if (force_on_match) {
2101 s = SvPV_force(TARG, len);
2106 SvSCREAM_off(TARG); /* disable possible screamer */
2108 rxtainted |= RX_MATCH_TAINTED(rx);
2109 m = orig + rx->startp[0];
2110 d = orig + rx->endp[0];
2112 if (m - s > strend - d) { /* faster to shorten from end */
2114 Copy(c, m, clen, char);
2119 Move(d, m, i, char);
2123 SvCUR_set(TARG, m - s);
2126 else if ((i = m - s)) { /* faster from front */
2134 Copy(c, m, clen, char);
2139 Copy(c, d, clen, char);
2144 TAINT_IF(rxtainted & 1);
2150 if (iters++ > maxiters)
2151 DIE(aTHX_ "Substitution loop");
2152 rxtainted |= RX_MATCH_TAINTED(rx);
2153 m = rx->startp[0] + orig;
2157 Move(s, d, i, char);
2161 Copy(c, d, clen, char);
2164 s = rx->endp[0] + orig;
2165 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2167 /* don't match same null twice */
2168 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2171 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2172 Move(s, d, i+1, char); /* include the NUL */
2174 TAINT_IF(rxtainted & 1);
2176 PUSHs(sv_2mortal(newSViv((I32)iters)));
2178 (void)SvPOK_only_UTF8(TARG);
2179 TAINT_IF(rxtainted);
2180 if (SvSMAGICAL(TARG)) {
2188 LEAVE_SCOPE(oldsave);
2192 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2193 r_flags | REXEC_CHECKED))
2195 if (force_on_match) {
2197 s = SvPV_force(TARG, len);
2200 #ifdef PERL_COPY_ON_WRITE
2203 rxtainted |= RX_MATCH_TAINTED(rx);
2204 dstr = newSVpvn(m, s-m);
2209 register PERL_CONTEXT *cx;
2213 RETURNOP(cPMOP->op_pmreplroot);
2215 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2217 if (iters++ > maxiters)
2218 DIE(aTHX_ "Substitution loop");
2219 rxtainted |= RX_MATCH_TAINTED(rx);
2220 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2225 strend = s + (strend - m);
2227 m = rx->startp[0] + orig;
2228 if (doutf8 && !SvUTF8(dstr))
2229 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2231 sv_catpvn(dstr, s, m-s);
2232 s = rx->endp[0] + orig;
2234 sv_catpvn(dstr, c, clen);
2237 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2238 TARG, NULL, r_flags));
2239 if (doutf8 && !DO_UTF8(TARG))
2240 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2242 sv_catpvn(dstr, s, strend - s);
2244 #ifdef PERL_COPY_ON_WRITE
2245 /* The match may make the string COW. If so, brilliant, because that's
2246 just saved us one malloc, copy and free - the regexp has donated
2247 the old buffer, and we malloc an entirely new one, rather than the
2248 regexp malloc()ing a buffer and copying our original, only for
2249 us to throw it away here during the substitution. */
2250 if (SvIsCOW(TARG)) {
2251 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2257 Safefree(SvPVX(TARG));
2259 SvPV_set(TARG, SvPVX(dstr));
2260 SvCUR_set(TARG, SvCUR(dstr));
2261 SvLEN_set(TARG, SvLEN(dstr));
2262 doutf8 |= DO_UTF8(dstr);
2263 SvPV_set(dstr, (char*)0);
2266 TAINT_IF(rxtainted & 1);
2268 PUSHs(sv_2mortal(newSViv((I32)iters)));
2270 (void)SvPOK_only(TARG);
2273 TAINT_IF(rxtainted);
2276 LEAVE_SCOPE(oldsave);
2285 LEAVE_SCOPE(oldsave);
2294 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2295 ++*PL_markstack_ptr;
2296 LEAVE; /* exit inner scope */
2299 if (PL_stack_base + *PL_markstack_ptr > SP) {
2301 I32 gimme = GIMME_V;
2303 LEAVE; /* exit outer scope */
2304 (void)POPMARK; /* pop src */
2305 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2306 (void)POPMARK; /* pop dst */
2307 SP = PL_stack_base + POPMARK; /* pop original mark */
2308 if (gimme == G_SCALAR) {
2309 if (PL_op->op_private & OPpGREP_LEX) {
2310 SV* sv = sv_newmortal();
2311 sv_setiv(sv, items);
2319 else if (gimme == G_ARRAY)
2326 ENTER; /* enter inner scope */
2329 src = PL_stack_base[*PL_markstack_ptr];
2331 if (PL_op->op_private & OPpGREP_LEX)
2332 PAD_SVl(PL_op->op_targ) = src;
2336 RETURNOP(cLOGOP->op_other);
2347 register PERL_CONTEXT *cx;
2351 cxstack_ix++; /* temporarily protect top context */
2354 if (gimme == G_SCALAR) {
2357 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2359 *MARK = SvREFCNT_inc(TOPs);
2364 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2366 *MARK = sv_mortalcopy(sv);
2371 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2375 *MARK = &PL_sv_undef;
2379 else if (gimme == G_ARRAY) {
2380 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2381 if (!SvTEMP(*MARK)) {
2382 *MARK = sv_mortalcopy(*MARK);
2383 TAINT_NOT; /* Each item is independent */
2391 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2392 PL_curpm = newpm; /* ... and pop $1 et al */
2395 return cx->blk_sub.retop;
2398 /* This duplicates the above code because the above code must not
2399 * get any slower by more conditions */
2407 register PERL_CONTEXT *cx;
2411 cxstack_ix++; /* temporarily protect top context */
2415 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2416 /* We are an argument to a function or grep().
2417 * This kind of lvalueness was legal before lvalue
2418 * subroutines too, so be backward compatible:
2419 * cannot report errors. */
2421 /* Scalar context *is* possible, on the LHS of -> only,
2422 * as in f()->meth(). But this is not an lvalue. */
2423 if (gimme == G_SCALAR)
2425 if (gimme == G_ARRAY) {
2426 if (!CvLVALUE(cx->blk_sub.cv))
2427 goto temporise_array;
2428 EXTEND_MORTAL(SP - newsp);
2429 for (mark = newsp + 1; mark <= SP; mark++) {
2432 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2433 *mark = sv_mortalcopy(*mark);
2435 /* Can be a localized value subject to deletion. */
2436 PL_tmps_stack[++PL_tmps_ix] = *mark;
2437 (void)SvREFCNT_inc(*mark);
2442 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2443 /* Here we go for robustness, not for speed, so we change all
2444 * the refcounts so the caller gets a live guy. Cannot set
2445 * TEMP, so sv_2mortal is out of question. */
2446 if (!CvLVALUE(cx->blk_sub.cv)) {
2452 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2454 if (gimme == G_SCALAR) {
2458 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2464 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2465 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2466 : "a readonly value" : "a temporary");
2468 else { /* Can be a localized value
2469 * subject to deletion. */
2470 PL_tmps_stack[++PL_tmps_ix] = *mark;
2471 (void)SvREFCNT_inc(*mark);
2474 else { /* Should not happen? */
2480 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2481 (MARK > SP ? "Empty array" : "Array"));
2485 else if (gimme == G_ARRAY) {
2486 EXTEND_MORTAL(SP - newsp);
2487 for (mark = newsp + 1; mark <= SP; mark++) {
2488 if (*mark != &PL_sv_undef
2489 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2490 /* Might be flattened array after $#array = */
2497 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2498 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2501 /* Can be a localized value subject to deletion. */
2502 PL_tmps_stack[++PL_tmps_ix] = *mark;
2503 (void)SvREFCNT_inc(*mark);
2509 if (gimme == G_SCALAR) {
2513 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2515 *MARK = SvREFCNT_inc(TOPs);
2520 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2522 *MARK = sv_mortalcopy(sv);
2527 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2531 *MARK = &PL_sv_undef;
2535 else if (gimme == G_ARRAY) {
2537 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2538 if (!SvTEMP(*MARK)) {
2539 *MARK = sv_mortalcopy(*MARK);
2540 TAINT_NOT; /* Each item is independent */
2549 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2550 PL_curpm = newpm; /* ... and pop $1 et al */
2553 return cx->blk_sub.retop;
2558 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2560 SV *dbsv = GvSV(PL_DBsub);
2563 if (!PERLDB_SUB_NN) {
2566 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2567 || strEQ(GvNAME(gv), "END")
2568 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2569 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2570 && (gv = (GV*)*svp) ))) {
2571 /* Use GV from the stack as a fallback. */
2572 /* GV is potentially non-unique, or contain different CV. */
2573 SV *tmp = newRV((SV*)cv);
2574 sv_setsv(dbsv, tmp);
2578 gv_efullname3(dbsv, gv, Nullch);
2582 int type = SvTYPE(dbsv);
2583 if (type < SVt_PVIV && type != SVt_IV)
2584 sv_upgrade(dbsv, SVt_PVIV);
2585 (void)SvIOK_on(dbsv);
2586 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2590 PL_curcopdb = PL_curcop;
2591 cv = GvCV(PL_DBsub);
2601 register PERL_CONTEXT *cx;
2603 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2606 DIE(aTHX_ "Not a CODE reference");
2607 switch (SvTYPE(sv)) {
2608 /* This is overwhelming the most common case: */
2610 if (!(cv = GvCVu((GV*)sv)))
2611 cv = sv_2cv(sv, &stash, &gv, FALSE);
2623 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2625 SP = PL_stack_base + POPMARK;
2628 if (SvGMAGICAL(sv)) {
2632 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2635 sym = SvPV(sv, n_a);
2637 DIE(aTHX_ PL_no_usym, "a subroutine");
2638 if (PL_op->op_private & HINT_STRICT_REFS)
2639 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2640 cv = get_cv(sym, TRUE);
2645 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2646 tryAMAGICunDEREF(to_cv);
2649 if (SvTYPE(cv) == SVt_PVCV)
2654 DIE(aTHX_ "Not a CODE reference");
2655 /* This is the second most common case: */
2665 if (!CvROOT(cv) && !CvXSUB(cv)) {
2670 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2671 if (CvASSERTION(cv) && PL_DBassertion)
2672 sv_setiv(PL_DBassertion, 1);
2674 cv = get_db_sub(&sv, cv);
2675 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2676 DIE(aTHX_ "No DB::sub routine defined");
2679 if (!(CvXSUB(cv))) {
2680 /* This path taken at least 75% of the time */
2682 register I32 items = SP - MARK;
2683 AV* padlist = CvPADLIST(cv);
2684 PUSHBLOCK(cx, CXt_SUB, MARK);
2686 cx->blk_sub.retop = PL_op->op_next;
2688 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2689 * that eval'' ops within this sub know the correct lexical space.
2690 * Owing the speed considerations, we choose instead to search for
2691 * the cv using find_runcv() when calling doeval().
2693 if (CvDEPTH(cv) >= 2) {
2694 PERL_STACK_OVERFLOW_CHECK();
2695 pad_push(padlist, CvDEPTH(cv));
2697 PAD_SET_CUR(padlist, CvDEPTH(cv));
2704 DEBUG_S(PerlIO_printf(Perl_debug_log,
2705 "%p entersub preparing @_\n", thr));
2707 av = (AV*)PAD_SVl(0);
2709 /* @_ is normally not REAL--this should only ever
2710 * happen when DB::sub() calls things that modify @_ */
2715 cx->blk_sub.savearray = GvAV(PL_defgv);
2716 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2717 CX_CURPAD_SAVE(cx->blk_sub);
2718 cx->blk_sub.argarray = av;
2721 if (items > AvMAX(av) + 1) {
2723 if (AvARRAY(av) != ary) {
2724 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2725 SvPV_set(av, (char*)ary);
2727 if (items > AvMAX(av) + 1) {
2728 AvMAX(av) = items - 1;
2729 Renew(ary,items,SV*);
2731 SvPV_set(av, (char*)ary);
2734 Copy(MARK,AvARRAY(av),items,SV*);
2735 AvFILLp(av) = items - 1;
2743 /* warning must come *after* we fully set up the context
2744 * stuff so that __WARN__ handlers can safely dounwind()
2747 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2748 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2749 sub_crush_depth(cv);
2751 DEBUG_S(PerlIO_printf(Perl_debug_log,
2752 "%p entersub returning %p\n", thr, CvSTART(cv)));
2754 RETURNOP(CvSTART(cv));
2757 #ifdef PERL_XSUB_OLDSTYLE
2758 if (CvOLDSTYLE(cv)) {
2759 I32 (*fp3)(int,int,int);
2761 register I32 items = SP - MARK;
2762 /* We dont worry to copy from @_. */
2767 PL_stack_sp = mark + 1;
2768 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2769 items = (*fp3)(CvXSUBANY(cv).any_i32,
2770 MARK - PL_stack_base + 1,
2772 PL_stack_sp = PL_stack_base + items;
2775 #endif /* PERL_XSUB_OLDSTYLE */
2777 I32 markix = TOPMARK;
2782 /* Need to copy @_ to stack. Alternative may be to
2783 * switch stack to @_, and copy return values
2784 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2787 av = GvAV(PL_defgv);
2788 items = AvFILLp(av) + 1; /* @_ is not tieable */
2791 /* Mark is at the end of the stack. */
2793 Copy(AvARRAY(av), SP + 1, items, SV*);
2798 /* We assume first XSUB in &DB::sub is the called one. */
2800 SAVEVPTR(PL_curcop);
2801 PL_curcop = PL_curcopdb;
2804 /* Do we need to open block here? XXXX */
2805 (void)(*CvXSUB(cv))(aTHX_ cv);
2807 /* Enforce some sanity in scalar context. */
2808 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2809 if (markix > PL_stack_sp - PL_stack_base)
2810 *(PL_stack_base + markix) = &PL_sv_undef;
2812 *(PL_stack_base + markix) = *PL_stack_sp;
2813 PL_stack_sp = PL_stack_base + markix;
2820 assert (0); /* Cannot get here. */
2821 /* This is deliberately moved here as spaghetti code to keep it out of the
2828 /* anonymous or undef'd function leaves us no recourse */
2829 if (CvANON(cv) || !(gv = CvGV(cv)))
2830 DIE(aTHX_ "Undefined subroutine called");
2832 /* autoloaded stub? */
2833 if (cv != GvCV(gv)) {
2836 /* should call AUTOLOAD now? */
2839 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2846 sub_name = sv_newmortal();
2847 gv_efullname3(sub_name, gv, Nullch);
2848 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2852 DIE(aTHX_ "Not a CODE reference");
2858 Perl_sub_crush_depth(pTHX_ CV *cv)
2861 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2863 SV* tmpstr = sv_newmortal();
2864 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2865 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2875 IV elem = SvIV(elemsv);
2877 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2878 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2881 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2882 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2884 elem -= PL_curcop->cop_arybase;
2885 if (SvTYPE(av) != SVt_PVAV)
2887 svp = av_fetch(av, elem, lval && !defer);
2889 #ifdef PERL_MALLOC_WRAP
2890 static const char oom_array_extend[] =
2891 "Out of memory during array extend"; /* Duplicated in av.c */
2892 if (SvUOK(elemsv)) {
2893 UV uv = SvUV(elemsv);
2894 elem = uv > IV_MAX ? IV_MAX : uv;
2896 else if (SvNOK(elemsv))
2897 elem = (IV)SvNV(elemsv);
2899 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2901 if (!svp || *svp == &PL_sv_undef) {
2904 DIE(aTHX_ PL_no_aelem, elem);
2905 lv = sv_newmortal();
2906 sv_upgrade(lv, SVt_PVLV);
2908 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2909 LvTARG(lv) = SvREFCNT_inc(av);
2910 LvTARGOFF(lv) = elem;
2915 if (PL_op->op_private & OPpLVAL_INTRO)
2916 save_aelem(av, elem, svp);
2917 else if (PL_op->op_private & OPpDEREF)
2918 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2920 sv = (svp ? *svp : &PL_sv_undef);
2921 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2922 sv = sv_mortalcopy(sv);
2928 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2934 Perl_croak(aTHX_ PL_no_modify);
2935 if (SvTYPE(sv) < SVt_RV)
2936 sv_upgrade(sv, SVt_RV);
2937 else if (SvTYPE(sv) >= SVt_PV) {
2939 Safefree(SvPVX(sv));
2940 SvLEN(sv) = SvCUR(sv) = 0;
2944 SvRV(sv) = NEWSV(355,0);
2947 SvRV(sv) = (SV*)newAV();
2950 SvRV(sv) = (SV*)newHV();
2965 if (SvTYPE(rsv) == SVt_PVCV) {
2971 SETs(method_common(sv, Null(U32*)));
2979 U32 hash = SvUVX(sv);
2981 XPUSHs(method_common(sv, &hash));
2986 S_method_common(pTHX_ SV* meth, U32* hashp)
2995 SV *packsv = Nullsv;
2998 name = SvPV(meth, namelen);
2999 sv = *(PL_stack_base + TOPMARK + 1);
3002 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3011 /* this isn't a reference */
3014 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3016 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3018 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3025 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3026 !(ob=(SV*)GvIO(iogv)))
3028 /* this isn't the name of a filehandle either */
3030 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3031 ? !isIDFIRST_utf8((U8*)packname)
3032 : !isIDFIRST(*packname)
3035 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3036 SvOK(sv) ? "without a package or object reference"
3037 : "on an undefined value");
3039 /* assume it's a package name */
3040 stash = gv_stashpvn(packname, packlen, FALSE);
3044 SV* ref = newSViv(PTR2IV(stash));
3045 hv_store(PL_stashcache, packname, packlen, ref, 0);
3049 /* it _is_ a filehandle name -- replace with a reference */
3050 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3053 /* if we got here, ob should be a reference or a glob */
3054 if (!ob || !(SvOBJECT(ob)
3055 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3058 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3062 stash = SvSTASH(ob);
3065 /* NOTE: stash may be null, hope hv_fetch_ent and
3066 gv_fetchmethod can cope (it seems they can) */
3068 /* shortcut for simple names */
3070 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3072 gv = (GV*)HeVAL(he);
3073 if (isGV(gv) && GvCV(gv) &&
3074 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3075 return (SV*)GvCV(gv);
3079 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3082 /* This code tries to figure out just what went wrong with
3083 gv_fetchmethod. It therefore needs to duplicate a lot of
3084 the internals of that function. We can't move it inside
3085 Perl_gv_fetchmethod_autoload(), however, since that would
3086 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3093 for (p = name; *p; p++) {
3095 sep = p, leaf = p + 1;
3096 else if (*p == ':' && *(p + 1) == ':')
3097 sep = p, leaf = p + 2;
3099 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3100 /* the method name is unqualified or starts with SUPER:: */
3101 packname = sep ? CopSTASHPV(PL_curcop) :
3102 stash ? HvNAME(stash) : packname;
3105 "Can't use anonymous symbol table for method lookup");
3107 packlen = strlen(packname);
3110 /* the method name is qualified */
3112 packlen = sep - name;
3115 /* we're relying on gv_fetchmethod not autovivifying the stash */
3116 if (gv_stashpvn(packname, packlen, FALSE)) {
3118 "Can't locate object method \"%s\" via package \"%.*s\"",
3119 leaf, (int)packlen, packname);
3123 "Can't locate object method \"%s\" via package \"%.*s\""
3124 " (perhaps you forgot to load \"%.*s\"?)",
3125 leaf, (int)packlen, packname, (int)packlen, packname);
3128 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3133 * c-indentation-style: bsd
3135 * indent-tabs-mode: t
3138 * vim: shiftwidth=4: