3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
14 * Awake! Awake! Fear, Fire, Foes! Awake!
19 #define PERL_IN_PP_HOT_C
24 #ifdef USE_5005THREADS
25 static void unset_cvowner(pTHX_ void *cvarg);
26 #endif /* USE_5005THREADS */
37 PL_curcop = (COP*)PL_op;
38 TAINT_NOT; /* Each statement is presumed innocent */
39 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
48 if (PL_op->op_private & OPpLVAL_INTRO)
49 PUSHs(save_scalar(cGVOP_gv));
51 PUSHs(GvSV(cGVOP_gv));
62 PL_curcop = (COP*)PL_op;
68 PUSHMARK(PL_stack_sp);
78 sv_setpvn(TARG,s,len);
90 XPUSHs((SV*)cGVOP_gv);
101 RETURNOP(cLOGOP->op_other);
109 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
111 temp = left; left = right; right = temp;
113 if (PL_tainting && PL_tainted && !SvTAINTED(left))
115 SvSetMagicSV(right, left);
124 RETURNOP(cLOGOP->op_other);
126 RETURNOP(cLOGOP->op_next);
132 TAINT_NOT; /* Each statement is presumed innocent */
133 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
135 oldsave = PL_scopestack[PL_scopestack_ix - 1];
136 LEAVE_SCOPE(oldsave);
142 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
149 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
150 bool rbyte = !SvUTF8(right);
152 if (TARG == right && right != left) {
153 right = sv_2mortal(newSVpvn(rpv, rlen));
154 rpv = SvPV(right, rlen); /* no point setting UTF8 here */
158 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
159 lbyte = !SvUTF8(left);
160 sv_setpvn(TARG, lpv, llen);
166 else { /* TARG == left */
167 if (SvGMAGICAL(left))
168 mg_get(left); /* or mg_get(left) may happen here */
171 lpv = SvPV_nomg(left, llen);
172 lbyte = !SvUTF8(left);
175 #if defined(PERL_Y2KWARN)
176 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
177 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
178 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
180 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
181 "about to append an integer to '19'");
186 if (lbyte != rbyte) {
188 sv_utf8_upgrade_nomg(TARG);
190 sv_utf8_upgrade_nomg(right);
191 rpv = SvPV(right, rlen);
194 sv_catpvn_nomg(TARG, rpv, rlen);
205 if (PL_op->op_flags & OPf_MOD) {
206 if (PL_op->op_private & OPpLVAL_INTRO)
207 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
208 else if (PL_op->op_private & OPpDEREF) {
210 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
219 tryAMAGICunTARGET(iter, 0);
220 PL_last_in_gv = (GV*)(*PL_stack_sp--);
221 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
222 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
223 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
226 XPUSHs((SV*)PL_last_in_gv);
229 PL_last_in_gv = (GV*)(*PL_stack_sp--);
232 return do_readline();
237 dSP; tryAMAGICbinSET(eq,0);
238 #ifndef NV_PRESERVES_UV
239 if (SvROK(TOPs) && SvROK(TOPm1s)) {
240 SETs(boolSV(SvRV(TOPs) == SvRV(TOPm1s)));
244 #ifdef PERL_PRESERVE_IVUV
247 /* Unless the left argument is integer in range we are going
248 to have to use NV maths. Hence only attempt to coerce the
249 right argument if we know the left is integer. */
252 bool auvok = SvUOK(TOPm1s);
253 bool buvok = SvUOK(TOPs);
255 if (!auvok && !buvok) { /* ## IV == IV ## */
256 IV aiv = SvIVX(TOPm1s);
257 IV biv = SvIVX(TOPs);
260 SETs(boolSV(aiv == biv));
263 if (auvok && buvok) { /* ## UV == UV ## */
264 UV auv = SvUVX(TOPm1s);
265 UV buv = SvUVX(TOPs);
268 SETs(boolSV(auv == buv));
271 { /* ## Mixed IV,UV ## */
275 /* == is commutative so swap if needed (save code) */
277 /* swap. top of stack (b) is the iv */
281 /* As (a) is a UV, it's >0, so it cannot be == */
290 /* As (b) is a UV, it's >0, so it cannot be == */
294 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
296 /* we know iv is >= 0 */
297 SETs(boolSV((UV)iv == uv));
305 SETs(boolSV(TOPn == value));
313 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
314 DIE(aTHX_ PL_no_modify);
315 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
316 SvIVX(TOPs) != IV_MAX)
319 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
321 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
334 RETURNOP(cLOGOP->op_other);
340 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
341 useleft = USE_LEFT(TOPm1s);
342 #ifdef PERL_PRESERVE_IVUV
343 /* We must see if we can perform the addition with integers if possible,
344 as the integer code detects overflow while the NV code doesn't.
345 If either argument hasn't had a numeric conversion yet attempt to get
346 the IV. It's important to do this now, rather than just assuming that
347 it's not IOK as a PV of "9223372036854775806" may not take well to NV
348 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
349 integer in case the second argument is IV=9223372036854775806
350 We can (now) rely on sv_2iv to do the right thing, only setting the
351 public IOK flag if the value in the NV (or PV) slot is truly integer.
353 A side effect is that this also aggressively prefers integer maths over
354 fp maths for integer values.
356 How to detect overflow?
358 C 99 section 6.2.6.1 says
360 The range of nonnegative values of a signed integer type is a subrange
361 of the corresponding unsigned integer type, and the representation of
362 the same value in each type is the same. A computation involving
363 unsigned operands can never overflow, because a result that cannot be
364 represented by the resulting unsigned integer type is reduced modulo
365 the number that is one greater than the largest value that can be
366 represented by the resulting type.
370 which I read as "unsigned ints wrap."
372 signed integer overflow seems to be classed as "exception condition"
374 If an exceptional condition occurs during the evaluation of an
375 expression (that is, if the result is not mathematically defined or not
376 in the range of representable values for its type), the behavior is
379 (6.5, the 5th paragraph)
381 I had assumed that on 2s complement machines signed arithmetic would
382 wrap, hence coded pp_add and pp_subtract on the assumption that
383 everything perl builds on would be happy. After much wailing and
384 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
385 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
386 unsigned code below is actually shorter than the old code. :-)
391 /* Unless the left argument is integer in range we are going to have to
392 use NV maths. Hence only attempt to coerce the right argument if
393 we know the left is integer. */
401 /* left operand is undef, treat as zero. + 0 is identity,
402 Could SETi or SETu right now, but space optimise by not adding
403 lots of code to speed up what is probably a rarish case. */
405 /* Left operand is defined, so is it IV? */
408 if ((auvok = SvUOK(TOPm1s)))
411 register IV aiv = SvIVX(TOPm1s);
414 auvok = 1; /* Now acting as a sign flag. */
415 } else { /* 2s complement assumption for IV_MIN */
423 bool result_good = 0;
426 bool buvok = SvUOK(TOPs);
431 register IV biv = SvIVX(TOPs);
438 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
439 else "IV" now, independant of how it came in.
440 if a, b represents positive, A, B negative, a maps to -A etc
445 all UV maths. negate result if A negative.
446 add if signs same, subtract if signs differ. */
452 /* Must get smaller */
458 /* result really should be -(auv-buv). as its negation
459 of true value, need to swap our result flag */
476 if (result <= (UV)IV_MIN)
479 /* result valid, but out of range for IV. */
484 } /* Overflow, drop through to NVs. */
491 /* left operand is undef, treat as zero. + 0.0 is identity. */
495 SETn( value + TOPn );
503 AV *av = GvAV(cGVOP_gv);
504 U32 lval = PL_op->op_flags & OPf_MOD;
505 SV** svp = av_fetch(av, PL_op->op_private, lval);
506 SV *sv = (svp ? *svp : &PL_sv_undef);
508 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
509 sv = sv_mortalcopy(sv);
518 do_join(TARG, *MARK, MARK, SP);
529 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
530 * will be enough to hold an OP*.
532 SV* sv = sv_newmortal();
533 sv_upgrade(sv, SVt_PVLV);
535 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
543 /* Oversized hot code. */
547 dSP; dMARK; dORIGMARK;
553 if (PL_op->op_flags & OPf_STACKED)
558 if (gv && (io = GvIO(gv))
559 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
562 if (MARK == ORIGMARK) {
563 /* If using default handle then we need to make space to
564 * pass object as 1st arg, so move other args up ...
568 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
572 *MARK = SvTIED_obj((SV*)io, mg);
575 call_method("PRINT", G_SCALAR);
583 if (!(io = GvIO(gv))) {
584 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
585 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
587 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
588 report_evil_fh(gv, io, PL_op->op_type);
589 SETERRNO(EBADF,RMS$_IFI);
592 else if (!(fp = IoOFP(io))) {
593 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
595 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
596 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
597 report_evil_fh(gv, io, PL_op->op_type);
599 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
604 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
606 if (!do_print(*MARK, fp))
610 if (!do_print(PL_ofs_sv, fp)) { /* $, */
619 if (!do_print(*MARK, fp))
627 if (PL_ors_sv && SvOK(PL_ors_sv))
628 if (!do_print(PL_ors_sv, fp)) /* $\ */
631 if (IoFLAGS(io) & IOf_FLUSH)
632 if (PerlIO_flush(fp) == EOF)
653 tryAMAGICunDEREF(to_av);
656 if (SvTYPE(av) != SVt_PVAV)
657 DIE(aTHX_ "Not an ARRAY reference");
658 if (PL_op->op_flags & OPf_REF) {
663 if (GIMME == G_SCALAR)
664 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
670 if (SvTYPE(sv) == SVt_PVAV) {
672 if (PL_op->op_flags & OPf_REF) {
677 if (GIMME == G_SCALAR)
678 Perl_croak(aTHX_ "Can't return array to lvalue"
687 if (SvTYPE(sv) != SVt_PVGV) {
691 if (SvGMAGICAL(sv)) {
697 if (PL_op->op_flags & OPf_REF ||
698 PL_op->op_private & HINT_STRICT_REFS)
699 DIE(aTHX_ PL_no_usym, "an ARRAY");
700 if (ckWARN(WARN_UNINITIALIZED))
702 if (GIMME == G_ARRAY) {
709 if ((PL_op->op_flags & OPf_SPECIAL) &&
710 !(PL_op->op_flags & OPf_MOD))
712 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
714 && (!is_gv_magical(sym,len,0)
715 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
721 if (PL_op->op_private & HINT_STRICT_REFS)
722 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
723 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
730 if (PL_op->op_private & OPpLVAL_INTRO)
732 if (PL_op->op_flags & OPf_REF) {
737 if (GIMME == G_SCALAR)
738 Perl_croak(aTHX_ "Can't return array to lvalue"
746 if (GIMME == G_ARRAY) {
747 I32 maxarg = AvFILL(av) + 1;
748 (void)POPs; /* XXXX May be optimized away? */
750 if (SvRMAGICAL(av)) {
752 for (i=0; i < maxarg; i++) {
753 SV **svp = av_fetch(av, i, FALSE);
754 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
758 Copy(AvARRAY(av), SP+1, maxarg, SV*);
764 I32 maxarg = AvFILL(av) + 1;
777 tryAMAGICunDEREF(to_hv);
780 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
781 DIE(aTHX_ "Not a HASH reference");
782 if (PL_op->op_flags & OPf_REF) {
787 if (GIMME == G_SCALAR)
788 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
794 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
796 if (PL_op->op_flags & OPf_REF) {
801 if (GIMME == G_SCALAR)
802 Perl_croak(aTHX_ "Can't return hash to lvalue"
811 if (SvTYPE(sv) != SVt_PVGV) {
815 if (SvGMAGICAL(sv)) {
821 if (PL_op->op_flags & OPf_REF ||
822 PL_op->op_private & HINT_STRICT_REFS)
823 DIE(aTHX_ PL_no_usym, "a HASH");
824 if (ckWARN(WARN_UNINITIALIZED))
826 if (GIMME == G_ARRAY) {
833 if ((PL_op->op_flags & OPf_SPECIAL) &&
834 !(PL_op->op_flags & OPf_MOD))
836 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
838 && (!is_gv_magical(sym,len,0)
839 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
845 if (PL_op->op_private & HINT_STRICT_REFS)
846 DIE(aTHX_ PL_no_symref, sym, "a HASH");
847 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
854 if (PL_op->op_private & OPpLVAL_INTRO)
856 if (PL_op->op_flags & OPf_REF) {
861 if (GIMME == G_SCALAR)
862 Perl_croak(aTHX_ "Can't return hash to lvalue"
870 if (GIMME == G_ARRAY) { /* array wanted */
871 *PL_stack_sp = (SV*)hv;
876 if (SvTYPE(hv) == SVt_PVAV)
877 hv = avhv_keys((AV*)hv);
879 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
880 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
890 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
896 leftop = ((BINOP*)PL_op)->op_last;
898 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
899 leftop = ((LISTOP*)leftop)->op_first;
901 /* Skip PUSHMARK and each element already assigned to. */
902 for (i = lelem - firstlelem; i > 0; i--) {
903 leftop = leftop->op_sibling;
906 if (leftop->op_type != OP_RV2HV)
911 av_fill(ary, 0); /* clear all but the fields hash */
912 if (lastrelem >= relem) {
913 while (relem < lastrelem) { /* gobble up all the rest */
917 /* Avoid a memory leak when avhv_store_ent dies. */
918 tmpstr = sv_newmortal();
919 sv_setsv(tmpstr,relem[1]); /* value */
921 if (avhv_store_ent(ary,relem[0],tmpstr,0))
922 (void)SvREFCNT_inc(tmpstr);
923 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
929 if (relem == lastrelem)
935 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
939 if (ckWARN(WARN_MISC)) {
940 if (relem == firstrelem &&
942 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
943 SvTYPE(SvRV(*relem)) == SVt_PVHV))
945 Perl_warner(aTHX_ WARN_MISC,
946 "Reference found where even-sized list expected");
949 Perl_warner(aTHX_ WARN_MISC,
950 "Odd number of elements in hash assignment");
952 if (SvTYPE(hash) == SVt_PVAV) {
954 tmpstr = sv_newmortal();
955 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
956 (void)SvREFCNT_inc(tmpstr);
957 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
962 tmpstr = NEWSV(29,0);
963 didstore = hv_store_ent(hash,*relem,tmpstr,0);
964 if (SvMAGICAL(hash)) {
965 if (SvSMAGICAL(tmpstr))
978 SV **lastlelem = PL_stack_sp;
979 SV **lastrelem = PL_stack_base + POPMARK;
980 SV **firstrelem = PL_stack_base + POPMARK + 1;
981 SV **firstlelem = lastrelem + 1;
994 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
996 /* If there's a common identifier on both sides we have to take
997 * special care that assigning the identifier on the left doesn't
998 * clobber a value on the right that's used later in the list.
1000 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1001 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1002 for (relem = firstrelem; relem <= lastrelem; relem++) {
1004 if ((sv = *relem)) {
1005 TAINT_NOT; /* Each item is independent */
1006 *relem = sv_mortalcopy(sv);
1016 while (lelem <= lastlelem) {
1017 TAINT_NOT; /* Each item stands on its own, taintwise. */
1019 switch (SvTYPE(sv)) {
1022 magic = SvMAGICAL(ary) != 0;
1023 if (PL_op->op_private & OPpASSIGN_HASH) {
1024 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1030 do_oddball((HV*)ary, relem, firstrelem);
1032 relem = lastrelem + 1;
1037 av_extend(ary, lastrelem - relem);
1039 while (relem <= lastrelem) { /* gobble up all the rest */
1043 sv_setsv(sv,*relem);
1045 didstore = av_store(ary,i++,sv);
1055 case SVt_PVHV: { /* normal hash */
1059 magic = SvMAGICAL(hash) != 0;
1062 while (relem < lastrelem) { /* gobble up all the rest */
1067 sv = &PL_sv_no, relem++;
1068 tmpstr = NEWSV(29,0);
1070 sv_setsv(tmpstr,*relem); /* value */
1071 *(relem++) = tmpstr;
1072 didstore = hv_store_ent(hash,sv,tmpstr,0);
1074 if (SvSMAGICAL(tmpstr))
1081 if (relem == lastrelem) {
1082 do_oddball(hash, relem, firstrelem);
1088 if (SvIMMORTAL(sv)) {
1089 if (relem <= lastrelem)
1093 if (relem <= lastrelem) {
1094 sv_setsv(sv, *relem);
1098 sv_setsv(sv, &PL_sv_undef);
1103 if (PL_delaymagic & ~DM_DELAY) {
1104 if (PL_delaymagic & DM_UID) {
1105 #ifdef HAS_SETRESUID
1106 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1108 # ifdef HAS_SETREUID
1109 (void)setreuid(PL_uid,PL_euid);
1112 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1113 (void)setruid(PL_uid);
1114 PL_delaymagic &= ~DM_RUID;
1116 # endif /* HAS_SETRUID */
1118 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1119 (void)seteuid(PL_uid);
1120 PL_delaymagic &= ~DM_EUID;
1122 # endif /* HAS_SETEUID */
1123 if (PL_delaymagic & DM_UID) {
1124 if (PL_uid != PL_euid)
1125 DIE(aTHX_ "No setreuid available");
1126 (void)PerlProc_setuid(PL_uid);
1128 # endif /* HAS_SETREUID */
1129 #endif /* HAS_SETRESUID */
1130 PL_uid = PerlProc_getuid();
1131 PL_euid = PerlProc_geteuid();
1133 if (PL_delaymagic & DM_GID) {
1134 #ifdef HAS_SETRESGID
1135 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1137 # ifdef HAS_SETREGID
1138 (void)setregid(PL_gid,PL_egid);
1141 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1142 (void)setrgid(PL_gid);
1143 PL_delaymagic &= ~DM_RGID;
1145 # endif /* HAS_SETRGID */
1147 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1148 (void)setegid(PL_gid);
1149 PL_delaymagic &= ~DM_EGID;
1151 # endif /* HAS_SETEGID */
1152 if (PL_delaymagic & DM_GID) {
1153 if (PL_gid != PL_egid)
1154 DIE(aTHX_ "No setregid available");
1155 (void)PerlProc_setgid(PL_gid);
1157 # endif /* HAS_SETREGID */
1158 #endif /* HAS_SETRESGID */
1159 PL_gid = PerlProc_getgid();
1160 PL_egid = PerlProc_getegid();
1162 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1167 if (gimme == G_VOID)
1168 SP = firstrelem - 1;
1169 else if (gimme == G_SCALAR) {
1172 SETi(lastrelem - firstrelem + 1);
1178 SP = firstrelem + (lastlelem - firstlelem);
1179 lelem = firstlelem + (relem - firstrelem);
1181 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1189 register PMOP *pm = cPMOP;
1190 SV *rv = sv_newmortal();
1191 SV *sv = newSVrv(rv, "Regexp");
1192 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1199 register PMOP *pm = cPMOP;
1204 I32 r_flags = REXEC_CHECKED;
1205 char *truebase; /* Start of string */
1206 register REGEXP *rx = PM_GETRE(pm);
1211 I32 oldsave = PL_savestack_ix;
1212 I32 update_minmatch = 1;
1213 I32 had_zerolen = 0;
1215 if (PL_op->op_flags & OPf_STACKED)
1222 PUTBACK; /* EVAL blocks need stack_sp. */
1223 s = SvPV(TARG, len);
1226 DIE(aTHX_ "panic: pp_match");
1227 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1228 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1231 PL_reg_match_utf8 = DO_UTF8(TARG);
1233 if (pm->op_pmdynflags & PMdf_USED) {
1235 if (gimme == G_ARRAY)
1240 if (!rx->prelen && PL_curpm) {
1244 if (rx->minlen > len) goto failure;
1248 /* XXXX What part of this is needed with true \G-support? */
1249 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1251 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1252 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1253 if (mg && mg->mg_len >= 0) {
1254 if (!(rx->reganch & ROPT_GPOS_SEEN))
1255 rx->endp[0] = rx->startp[0] = mg->mg_len;
1256 else if (rx->reganch & ROPT_ANCH_GPOS) {
1257 r_flags |= REXEC_IGNOREPOS;
1258 rx->endp[0] = rx->startp[0] = mg->mg_len;
1260 minmatch = (mg->mg_flags & MGf_MINMATCH);
1261 update_minmatch = 0;
1265 if ((!global && rx->nparens)
1266 || SvTEMP(TARG) || PL_sawampersand)
1267 r_flags |= REXEC_COPY_STR;
1269 r_flags |= REXEC_SCREAM;
1271 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1272 SAVEINT(PL_multiline);
1273 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1277 if (global && rx->startp[0] != -1) {
1278 t = s = rx->endp[0] + truebase;
1279 if ((s + rx->minlen) > strend)
1281 if (update_minmatch++)
1282 minmatch = had_zerolen;
1284 if (rx->reganch & RE_USE_INTUIT &&
1285 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1286 PL_bostr = truebase;
1287 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1291 if ( (rx->reganch & ROPT_CHECK_ALL)
1293 && ((rx->reganch & ROPT_NOSCAN)
1294 || !((rx->reganch & RE_INTUIT_TAIL)
1295 && (r_flags & REXEC_SCREAM)))
1296 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1299 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1302 if (pm->op_pmflags & PMf_ONCE)
1303 pm->op_pmdynflags |= PMdf_USED;
1312 RX_MATCH_TAINTED_on(rx);
1313 TAINT_IF(RX_MATCH_TAINTED(rx));
1314 if (gimme == G_ARRAY) {
1315 I32 nparens, i, len;
1317 nparens = rx->nparens;
1318 if (global && !nparens)
1322 SPAGAIN; /* EVAL blocks could move the stack. */
1323 EXTEND(SP, nparens + i);
1324 EXTEND_MORTAL(nparens + i);
1325 for (i = !i; i <= nparens; i++) {
1326 PUSHs(sv_newmortal());
1328 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1329 len = rx->endp[i] - rx->startp[i];
1330 s = rx->startp[i] + truebase;
1331 sv_setpvn(*SP, s, len);
1332 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1337 if (pm->op_pmflags & PMf_CONTINUE) {
1339 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1340 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1342 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1343 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1345 if (rx->startp[0] != -1) {
1346 mg->mg_len = rx->endp[0];
1347 if (rx->startp[0] == rx->endp[0])
1348 mg->mg_flags |= MGf_MINMATCH;
1350 mg->mg_flags &= ~MGf_MINMATCH;
1353 had_zerolen = (rx->startp[0] != -1
1354 && rx->startp[0] == rx->endp[0]);
1355 PUTBACK; /* EVAL blocks may use stack */
1356 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1361 LEAVE_SCOPE(oldsave);
1367 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1368 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1370 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1371 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1373 if (rx->startp[0] != -1) {
1374 mg->mg_len = rx->endp[0];
1375 if (rx->startp[0] == rx->endp[0])
1376 mg->mg_flags |= MGf_MINMATCH;
1378 mg->mg_flags &= ~MGf_MINMATCH;
1381 LEAVE_SCOPE(oldsave);
1385 yup: /* Confirmed by INTUIT */
1387 RX_MATCH_TAINTED_on(rx);
1388 TAINT_IF(RX_MATCH_TAINTED(rx));
1390 if (pm->op_pmflags & PMf_ONCE)
1391 pm->op_pmdynflags |= PMdf_USED;
1392 if (RX_MATCH_COPIED(rx))
1393 Safefree(rx->subbeg);
1394 RX_MATCH_COPIED_off(rx);
1395 rx->subbeg = Nullch;
1397 rx->subbeg = truebase;
1398 rx->startp[0] = s - truebase;
1399 if (PL_reg_match_utf8) {
1400 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1401 rx->endp[0] = t - truebase;
1404 rx->endp[0] = s - truebase + rx->minlen;
1406 rx->sublen = strend - truebase;
1409 if (PL_sawampersand) {
1412 rx->subbeg = savepvn(t, strend - t);
1413 rx->sublen = strend - t;
1414 RX_MATCH_COPIED_on(rx);
1415 off = rx->startp[0] = s - t;
1416 rx->endp[0] = off + rx->minlen;
1418 else { /* startp/endp are used by @- @+. */
1419 rx->startp[0] = s - truebase;
1420 rx->endp[0] = s - truebase + rx->minlen;
1422 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1423 LEAVE_SCOPE(oldsave);
1428 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1429 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1430 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1435 LEAVE_SCOPE(oldsave);
1436 if (gimme == G_ARRAY)
1442 Perl_do_readline(pTHX)
1444 dSP; dTARGETSTACKED;
1449 register IO *io = GvIO(PL_last_in_gv);
1450 register I32 type = PL_op->op_type;
1451 I32 gimme = GIMME_V;
1454 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1456 XPUSHs(SvTIED_obj((SV*)io, mg));
1459 call_method("READLINE", gimme);
1462 if (gimme == G_SCALAR)
1463 SvSetMagicSV_nosteal(TARG, TOPs);
1470 if (IoFLAGS(io) & IOf_ARGV) {
1471 if (IoFLAGS(io) & IOf_START) {
1473 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1474 IoFLAGS(io) &= ~IOf_START;
1475 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1476 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1477 SvSETMAGIC(GvSV(PL_last_in_gv));
1482 fp = nextargv(PL_last_in_gv);
1483 if (!fp) { /* Note: fp != IoIFP(io) */
1484 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1487 else if (type == OP_GLOB)
1488 fp = Perl_start_glob(aTHX_ POPs, io);
1490 else if (type == OP_GLOB)
1492 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1493 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1497 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1498 && (!io || !(IoFLAGS(io) & IOf_START))) {
1499 if (type == OP_GLOB)
1500 Perl_warner(aTHX_ WARN_GLOB,
1501 "glob failed (can't start child: %s)",
1504 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1506 if (gimme == G_SCALAR) {
1507 (void)SvOK_off(TARG);
1513 if (gimme == G_SCALAR) {
1517 (void)SvUPGRADE(sv, SVt_PV);
1518 tmplen = SvLEN(sv); /* remember if already alloced */
1520 Sv_Grow(sv, 80); /* try short-buffering it */
1521 if (type == OP_RCATLINE)
1527 sv = sv_2mortal(NEWSV(57, 80));
1531 /* This should not be marked tainted if the fp is marked clean */
1532 #define MAYBE_TAINT_LINE(io, sv) \
1533 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1538 /* delay EOF state for a snarfed empty file */
1539 #define SNARF_EOF(gimme,rs,io,sv) \
1540 (gimme != G_SCALAR || SvCUR(sv) \
1541 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1545 if (!sv_gets(sv, fp, offset)
1546 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1548 PerlIO_clearerr(fp);
1549 if (IoFLAGS(io) & IOf_ARGV) {
1550 fp = nextargv(PL_last_in_gv);
1553 (void)do_close(PL_last_in_gv, FALSE);
1555 else if (type == OP_GLOB) {
1556 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1557 Perl_warner(aTHX_ WARN_GLOB,
1558 "glob failed (child exited with status %d%s)",
1559 (int)(STATUS_CURRENT >> 8),
1560 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1563 if (gimme == G_SCALAR) {
1564 (void)SvOK_off(TARG);
1568 MAYBE_TAINT_LINE(io, sv);
1571 MAYBE_TAINT_LINE(io, sv);
1573 IoFLAGS(io) |= IOf_NOLINE;
1577 if (type == OP_GLOB) {
1580 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1581 tmps = SvEND(sv) - 1;
1582 if (*tmps == *SvPVX(PL_rs)) {
1587 for (tmps = SvPVX(sv); *tmps; tmps++)
1588 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1589 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1591 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1592 (void)POPs; /* Unmatched wildcard? Chuck it... */
1596 if (gimme == G_ARRAY) {
1597 if (SvLEN(sv) - SvCUR(sv) > 20) {
1598 SvLEN_set(sv, SvCUR(sv)+1);
1599 Renew(SvPVX(sv), SvLEN(sv), char);
1601 sv = sv_2mortal(NEWSV(58, 80));
1604 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1605 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1609 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1610 Renew(SvPVX(sv), SvLEN(sv), char);
1619 register PERL_CONTEXT *cx;
1620 I32 gimme = OP_GIMME(PL_op, -1);
1623 if (cxstack_ix >= 0)
1624 gimme = cxstack[cxstack_ix].blk_gimme;
1632 PUSHBLOCK(cx, CXt_BLOCK, SP);
1644 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1645 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1647 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1650 if (SvTYPE(hv) == SVt_PVHV) {
1651 if (PL_op->op_private & OPpLVAL_INTRO)
1652 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1653 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1654 svp = he ? &HeVAL(he) : 0;
1656 else if (SvTYPE(hv) == SVt_PVAV) {
1657 if (PL_op->op_private & OPpLVAL_INTRO)
1658 DIE(aTHX_ "Can't localize pseudo-hash element");
1659 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1665 if (!svp || *svp == &PL_sv_undef) {
1670 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1672 lv = sv_newmortal();
1673 sv_upgrade(lv, SVt_PVLV);
1675 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1676 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1677 LvTARG(lv) = SvREFCNT_inc(hv);
1682 if (PL_op->op_private & OPpLVAL_INTRO) {
1683 if (HvNAME(hv) && isGV(*svp))
1684 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1688 char *key = SvPV(keysv, keylen);
1689 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1691 save_helem(hv, keysv, svp);
1694 else if (PL_op->op_private & OPpDEREF)
1695 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1697 sv = (svp ? *svp : &PL_sv_undef);
1698 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1699 * Pushing the magical RHS on to the stack is useless, since
1700 * that magic is soon destined to be misled by the local(),
1701 * and thus the later pp_sassign() will fail to mg_get() the
1702 * old value. This should also cure problems with delayed
1703 * mg_get()s. GSAR 98-07-03 */
1704 if (!lval && SvGMAGICAL(sv))
1705 sv = sv_mortalcopy(sv);
1713 register PERL_CONTEXT *cx;
1719 if (PL_op->op_flags & OPf_SPECIAL) {
1720 cx = &cxstack[cxstack_ix];
1721 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1726 gimme = OP_GIMME(PL_op, -1);
1728 if (cxstack_ix >= 0)
1729 gimme = cxstack[cxstack_ix].blk_gimme;
1735 if (gimme == G_VOID)
1737 else if (gimme == G_SCALAR) {
1740 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1743 *MARK = sv_mortalcopy(TOPs);
1746 *MARK = &PL_sv_undef;
1750 else if (gimme == G_ARRAY) {
1751 /* in case LEAVE wipes old return values */
1752 for (mark = newsp + 1; mark <= SP; mark++) {
1753 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1754 *mark = sv_mortalcopy(*mark);
1755 TAINT_NOT; /* Each item is independent */
1759 PL_curpm = newpm; /* Don't pop $1 et al till now */
1769 register PERL_CONTEXT *cx;
1775 cx = &cxstack[cxstack_ix];
1776 if (CxTYPE(cx) != CXt_LOOP)
1777 DIE(aTHX_ "panic: pp_iter");
1779 itersvp = CxITERVAR(cx);
1780 av = cx->blk_loop.iterary;
1781 if (SvTYPE(av) != SVt_PVAV) {
1782 /* iterate ($min .. $max) */
1783 if (cx->blk_loop.iterlval) {
1784 /* string increment */
1785 register SV* cur = cx->blk_loop.iterlval;
1787 char *max = SvPV((SV*)av, maxlen);
1788 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1789 #ifndef USE_5005THREADS /* don't risk potential race */
1790 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1791 /* safe to reuse old SV */
1792 sv_setsv(*itersvp, cur);
1797 /* we need a fresh SV every time so that loop body sees a
1798 * completely new SV for closures/references to work as
1800 SvREFCNT_dec(*itersvp);
1801 *itersvp = newSVsv(cur);
1803 if (strEQ(SvPVX(cur), max))
1804 sv_setiv(cur, 0); /* terminate next time */
1811 /* integer increment */
1812 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1815 #ifndef USE_5005THREADS /* don't risk potential race */
1816 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1817 /* safe to reuse old SV */
1818 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1823 /* we need a fresh SV every time so that loop body sees a
1824 * completely new SV for closures/references to work as they
1826 SvREFCNT_dec(*itersvp);
1827 *itersvp = newSViv(cx->blk_loop.iterix++);
1833 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1836 SvREFCNT_dec(*itersvp);
1838 if (SvMAGICAL(av) || AvREIFY(av)) {
1839 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1846 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1852 if (av != PL_curstack && sv == &PL_sv_undef) {
1853 SV *lv = cx->blk_loop.iterlval;
1854 if (lv && SvREFCNT(lv) > 1) {
1859 SvREFCNT_dec(LvTARG(lv));
1861 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1862 sv_upgrade(lv, SVt_PVLV);
1864 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1866 LvTARG(lv) = SvREFCNT_inc(av);
1867 LvTARGOFF(lv) = cx->blk_loop.iterix;
1868 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1872 *itersvp = SvREFCNT_inc(sv);
1879 register PMOP *pm = cPMOP;
1895 register REGEXP *rx = PM_GETRE(pm);
1897 int force_on_match = 0;
1898 I32 oldsave = PL_savestack_ix;
1901 /* known replacement string? */
1902 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1903 if (PL_op->op_flags & OPf_STACKED)
1910 if (SvFAKE(TARG) && SvREADONLY(TARG))
1911 sv_force_normal(TARG);
1912 if (SvREADONLY(TARG)
1913 || (SvTYPE(TARG) > SVt_PVLV
1914 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1915 DIE(aTHX_ PL_no_modify);
1918 s = SvPV(TARG, len);
1919 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1921 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1922 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1927 PL_reg_match_utf8 = DO_UTF8(TARG);
1931 DIE(aTHX_ "panic: pp_subst");
1934 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1935 maxiters = 2 * slen + 10; /* We can match twice at each
1936 position, once with zero-length,
1937 second time with non-zero. */
1939 if (!rx->prelen && PL_curpm) {
1943 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1944 ? REXEC_COPY_STR : 0;
1946 r_flags |= REXEC_SCREAM;
1947 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1948 SAVEINT(PL_multiline);
1949 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1952 if (rx->reganch & RE_USE_INTUIT) {
1954 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1958 /* How to do it in subst? */
1959 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1961 && ((rx->reganch & ROPT_NOSCAN)
1962 || !((rx->reganch & RE_INTUIT_TAIL)
1963 && (r_flags & REXEC_SCREAM))))
1968 /* only replace once? */
1969 once = !(rpm->op_pmflags & PMf_GLOBAL);
1971 /* known replacement string? */
1972 c = dstr ? SvPV(dstr, clen) : Nullch;
1974 /* can do inplace substitution? */
1975 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1976 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1977 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1978 r_flags | REXEC_CHECKED))
1982 LEAVE_SCOPE(oldsave);
1985 if (force_on_match) {
1987 s = SvPV_force(TARG, len);
1992 SvSCREAM_off(TARG); /* disable possible screamer */
1994 rxtainted |= RX_MATCH_TAINTED(rx);
1995 m = orig + rx->startp[0];
1996 d = orig + rx->endp[0];
1998 if (m - s > strend - d) { /* faster to shorten from end */
2000 Copy(c, m, clen, char);
2005 Move(d, m, i, char);
2009 SvCUR_set(TARG, m - s);
2012 else if ((i = m - s)) { /* faster from front */
2020 Copy(c, m, clen, char);
2025 Copy(c, d, clen, char);
2030 TAINT_IF(rxtainted & 1);
2036 if (iters++ > maxiters)
2037 DIE(aTHX_ "Substitution loop");
2038 rxtainted |= RX_MATCH_TAINTED(rx);
2039 m = rx->startp[0] + orig;
2043 Move(s, d, i, char);
2047 Copy(c, d, clen, char);
2050 s = rx->endp[0] + orig;
2051 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2053 /* don't match same null twice */
2054 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2057 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2058 Move(s, d, i+1, char); /* include the NUL */
2060 TAINT_IF(rxtainted & 1);
2062 PUSHs(sv_2mortal(newSViv((I32)iters)));
2064 (void)SvPOK_only_UTF8(TARG);
2065 TAINT_IF(rxtainted);
2066 if (SvSMAGICAL(TARG)) {
2072 LEAVE_SCOPE(oldsave);
2076 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2077 r_flags | REXEC_CHECKED))
2081 if (force_on_match) {
2083 s = SvPV_force(TARG, len);
2086 rxtainted |= RX_MATCH_TAINTED(rx);
2087 dstr = NEWSV(25, len);
2088 sv_setpvn(dstr, m, s-m);
2093 register PERL_CONTEXT *cx;
2096 RETURNOP(cPMOP->op_pmreplroot);
2098 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2100 if (iters++ > maxiters)
2101 DIE(aTHX_ "Substitution loop");
2102 rxtainted |= RX_MATCH_TAINTED(rx);
2103 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2108 strend = s + (strend - m);
2110 m = rx->startp[0] + orig;
2111 sv_catpvn(dstr, s, m-s);
2112 s = rx->endp[0] + orig;
2114 sv_catpvn(dstr, c, clen);
2117 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2118 TARG, NULL, r_flags));
2119 sv_catpvn(dstr, s, strend - s);
2121 (void)SvOOK_off(TARG);
2122 Safefree(SvPVX(TARG));
2123 SvPVX(TARG) = SvPVX(dstr);
2124 SvCUR_set(TARG, SvCUR(dstr));
2125 SvLEN_set(TARG, SvLEN(dstr));
2126 isutf8 = DO_UTF8(dstr);
2130 TAINT_IF(rxtainted & 1);
2132 PUSHs(sv_2mortal(newSViv((I32)iters)));
2134 (void)SvPOK_only(TARG);
2137 TAINT_IF(rxtainted);
2140 LEAVE_SCOPE(oldsave);
2149 LEAVE_SCOPE(oldsave);
2158 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2159 ++*PL_markstack_ptr;
2160 LEAVE; /* exit inner scope */
2163 if (PL_stack_base + *PL_markstack_ptr > SP) {
2165 I32 gimme = GIMME_V;
2167 LEAVE; /* exit outer scope */
2168 (void)POPMARK; /* pop src */
2169 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2170 (void)POPMARK; /* pop dst */
2171 SP = PL_stack_base + POPMARK; /* pop original mark */
2172 if (gimme == G_SCALAR) {
2176 else if (gimme == G_ARRAY)
2183 ENTER; /* enter inner scope */
2186 src = PL_stack_base[*PL_markstack_ptr];
2190 RETURNOP(cLOGOP->op_other);
2201 register PERL_CONTEXT *cx;
2207 if (gimme == G_SCALAR) {
2210 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2212 *MARK = SvREFCNT_inc(TOPs);
2217 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2219 *MARK = sv_mortalcopy(sv);
2224 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2228 *MARK = &PL_sv_undef;
2232 else if (gimme == G_ARRAY) {
2233 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2234 if (!SvTEMP(*MARK)) {
2235 *MARK = sv_mortalcopy(*MARK);
2236 TAINT_NOT; /* Each item is independent */
2242 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2243 PL_curpm = newpm; /* ... and pop $1 et al */
2247 return pop_return();
2250 /* This duplicates the above code because the above code must not
2251 * get any slower by more conditions */
2259 register PERL_CONTEXT *cx;
2266 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2267 /* We are an argument to a function or grep().
2268 * This kind of lvalueness was legal before lvalue
2269 * subroutines too, so be backward compatible:
2270 * cannot report errors. */
2272 /* Scalar context *is* possible, on the LHS of -> only,
2273 * as in f()->meth(). But this is not an lvalue. */
2274 if (gimme == G_SCALAR)
2276 if (gimme == G_ARRAY) {
2277 if (!CvLVALUE(cx->blk_sub.cv))
2278 goto temporise_array;
2279 EXTEND_MORTAL(SP - newsp);
2280 for (mark = newsp + 1; mark <= SP; mark++) {
2283 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2284 *mark = sv_mortalcopy(*mark);
2286 /* Can be a localized value subject to deletion. */
2287 PL_tmps_stack[++PL_tmps_ix] = *mark;
2288 (void)SvREFCNT_inc(*mark);
2293 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2294 /* Here we go for robustness, not for speed, so we change all
2295 * the refcounts so the caller gets a live guy. Cannot set
2296 * TEMP, so sv_2mortal is out of question. */
2297 if (!CvLVALUE(cx->blk_sub.cv)) {
2302 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2304 if (gimme == G_SCALAR) {
2308 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2313 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2314 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2316 else { /* Can be a localized value
2317 * subject to deletion. */
2318 PL_tmps_stack[++PL_tmps_ix] = *mark;
2319 (void)SvREFCNT_inc(*mark);
2322 else { /* Should not happen? */
2327 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2328 (MARK > SP ? "Empty array" : "Array"));
2332 else if (gimme == G_ARRAY) {
2333 EXTEND_MORTAL(SP - newsp);
2334 for (mark = newsp + 1; mark <= SP; mark++) {
2335 if (*mark != &PL_sv_undef
2336 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2337 /* Might be flattened array after $#array = */
2343 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2344 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2347 /* Can be a localized value subject to deletion. */
2348 PL_tmps_stack[++PL_tmps_ix] = *mark;
2349 (void)SvREFCNT_inc(*mark);
2355 if (gimme == G_SCALAR) {
2359 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2361 *MARK = SvREFCNT_inc(TOPs);
2366 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2368 *MARK = sv_mortalcopy(sv);
2373 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2377 *MARK = &PL_sv_undef;
2381 else if (gimme == G_ARRAY) {
2383 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2384 if (!SvTEMP(*MARK)) {
2385 *MARK = sv_mortalcopy(*MARK);
2386 TAINT_NOT; /* Each item is independent */
2393 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2394 PL_curpm = newpm; /* ... and pop $1 et al */
2398 return pop_return();
2403 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2405 SV *dbsv = GvSV(PL_DBsub);
2407 if (!PERLDB_SUB_NN) {
2411 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2412 || strEQ(GvNAME(gv), "END")
2413 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2414 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2415 && (gv = (GV*)*svp) ))) {
2416 /* Use GV from the stack as a fallback. */
2417 /* GV is potentially non-unique, or contain different CV. */
2418 SV *tmp = newRV((SV*)cv);
2419 sv_setsv(dbsv, tmp);
2423 gv_efullname3(dbsv, gv, Nullch);
2427 (void)SvUPGRADE(dbsv, SVt_PVIV);
2428 (void)SvIOK_on(dbsv);
2429 SAVEIV(SvIVX(dbsv));
2430 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2434 PL_curcopdb = PL_curcop;
2435 cv = GvCV(PL_DBsub);
2445 register PERL_CONTEXT *cx;
2447 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2450 DIE(aTHX_ "Not a CODE reference");
2451 switch (SvTYPE(sv)) {
2457 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2459 SP = PL_stack_base + POPMARK;
2462 if (SvGMAGICAL(sv)) {
2466 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2469 sym = SvPV(sv, n_a);
2471 DIE(aTHX_ PL_no_usym, "a subroutine");
2472 if (PL_op->op_private & HINT_STRICT_REFS)
2473 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2474 cv = get_cv(sym, TRUE);
2479 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2480 tryAMAGICunDEREF(to_cv);
2483 if (SvTYPE(cv) == SVt_PVCV)
2488 DIE(aTHX_ "Not a CODE reference");
2493 if (!(cv = GvCVu((GV*)sv)))
2494 cv = sv_2cv(sv, &stash, &gv, FALSE);
2507 if (!CvROOT(cv) && !CvXSUB(cv)) {
2511 /* anonymous or undef'd function leaves us no recourse */
2512 if (CvANON(cv) || !(gv = CvGV(cv)))
2513 DIE(aTHX_ "Undefined subroutine called");
2515 /* autoloaded stub? */
2516 if (cv != GvCV(gv)) {
2519 /* should call AUTOLOAD now? */
2522 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2529 sub_name = sv_newmortal();
2530 gv_efullname3(sub_name, gv, Nullch);
2531 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2535 DIE(aTHX_ "Not a CODE reference");
2540 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2541 cv = get_db_sub(&sv, cv);
2543 DIE(aTHX_ "No DBsub routine");
2546 #ifdef USE_5005THREADS
2548 * First we need to check if the sub or method requires locking.
2549 * If so, we gain a lock on the CV, the first argument or the
2550 * stash (for static methods), as appropriate. This has to be
2551 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2552 * reschedule by returning a new op.
2554 MUTEX_LOCK(CvMUTEXP(cv));
2555 if (CvFLAGS(cv) & CVf_LOCKED) {
2557 if (CvFLAGS(cv) & CVf_METHOD) {
2558 if (SP > PL_stack_base + TOPMARK)
2559 sv = *(PL_stack_base + TOPMARK + 1);
2561 AV *av = (AV*)PL_curpad[0];
2562 if (hasargs || !av || AvFILLp(av) < 0
2563 || !(sv = AvARRAY(av)[0]))
2565 MUTEX_UNLOCK(CvMUTEXP(cv));
2566 DIE(aTHX_ "no argument for locked method call");
2573 char *stashname = SvPV(sv, len);
2574 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2580 MUTEX_UNLOCK(CvMUTEXP(cv));
2581 mg = condpair_magic(sv);
2582 MUTEX_LOCK(MgMUTEXP(mg));
2583 if (MgOWNER(mg) == thr)
2584 MUTEX_UNLOCK(MgMUTEXP(mg));
2587 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2589 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2591 MUTEX_UNLOCK(MgMUTEXP(mg));
2592 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2594 MUTEX_LOCK(CvMUTEXP(cv));
2597 * Now we have permission to enter the sub, we must distinguish
2598 * four cases. (0) It's an XSUB (in which case we don't care
2599 * about ownership); (1) it's ours already (and we're recursing);
2600 * (2) it's free (but we may already be using a cached clone);
2601 * (3) another thread owns it. Case (1) is easy: we just use it.
2602 * Case (2) means we look for a clone--if we have one, use it
2603 * otherwise grab ownership of cv. Case (3) means we look for a
2604 * clone (for non-XSUBs) and have to create one if we don't
2606 * Why look for a clone in case (2) when we could just grab
2607 * ownership of cv straight away? Well, we could be recursing,
2608 * i.e. we originally tried to enter cv while another thread
2609 * owned it (hence we used a clone) but it has been freed up
2610 * and we're now recursing into it. It may or may not be "better"
2611 * to use the clone but at least CvDEPTH can be trusted.
2613 if (CvOWNER(cv) == thr || CvXSUB(cv))
2614 MUTEX_UNLOCK(CvMUTEXP(cv));
2616 /* Case (2) or (3) */
2620 * XXX Might it be better to release CvMUTEXP(cv) while we
2621 * do the hv_fetch? We might find someone has pinched it
2622 * when we look again, in which case we would be in case
2623 * (3) instead of (2) so we'd have to clone. Would the fact
2624 * that we released the mutex more quickly make up for this?
2626 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2628 /* We already have a clone to use */
2629 MUTEX_UNLOCK(CvMUTEXP(cv));
2631 DEBUG_S(PerlIO_printf(Perl_debug_log,
2632 "entersub: %p already has clone %p:%s\n",
2633 thr, cv, SvPEEK((SV*)cv)));
2636 if (CvDEPTH(cv) == 0)
2637 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2640 /* (2) => grab ownership of cv. (3) => make clone */
2644 MUTEX_UNLOCK(CvMUTEXP(cv));
2645 DEBUG_S(PerlIO_printf(Perl_debug_log,
2646 "entersub: %p grabbing %p:%s in stash %s\n",
2647 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2648 HvNAME(CvSTASH(cv)) : "(none)"));
2651 /* Make a new clone. */
2653 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2654 MUTEX_UNLOCK(CvMUTEXP(cv));
2655 DEBUG_S((PerlIO_printf(Perl_debug_log,
2656 "entersub: %p cloning %p:%s\n",
2657 thr, cv, SvPEEK((SV*)cv))));
2659 * We're creating a new clone so there's no race
2660 * between the original MUTEX_UNLOCK and the
2661 * SvREFCNT_inc since no one will be trying to undef
2662 * it out from underneath us. At least, I don't think
2665 clonecv = cv_clone(cv);
2666 SvREFCNT_dec(cv); /* finished with this */
2667 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2668 CvOWNER(clonecv) = thr;
2672 DEBUG_S(if (CvDEPTH(cv) != 0)
2673 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2675 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2678 #endif /* USE_5005THREADS */
2681 #ifdef PERL_XSUB_OLDSTYLE
2682 if (CvOLDSTYLE(cv)) {
2683 I32 (*fp3)(int,int,int);
2685 register I32 items = SP - MARK;
2686 /* We dont worry to copy from @_. */
2691 PL_stack_sp = mark + 1;
2692 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2693 items = (*fp3)(CvXSUBANY(cv).any_i32,
2694 MARK - PL_stack_base + 1,
2696 PL_stack_sp = PL_stack_base + items;
2699 #endif /* PERL_XSUB_OLDSTYLE */
2701 I32 markix = TOPMARK;
2706 /* Need to copy @_ to stack. Alternative may be to
2707 * switch stack to @_, and copy return values
2708 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2711 #ifdef USE_5005THREADS
2712 av = (AV*)PL_curpad[0];
2714 av = GvAV(PL_defgv);
2715 #endif /* USE_5005THREADS */
2716 items = AvFILLp(av) + 1; /* @_ is not tieable */
2719 /* Mark is at the end of the stack. */
2721 Copy(AvARRAY(av), SP + 1, items, SV*);
2726 /* We assume first XSUB in &DB::sub is the called one. */
2728 SAVEVPTR(PL_curcop);
2729 PL_curcop = PL_curcopdb;
2732 /* Do we need to open block here? XXXX */
2733 (void)(*CvXSUB(cv))(aTHX_ cv);
2735 /* Enforce some sanity in scalar context. */
2736 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2737 if (markix > PL_stack_sp - PL_stack_base)
2738 *(PL_stack_base + markix) = &PL_sv_undef;
2740 *(PL_stack_base + markix) = *PL_stack_sp;
2741 PL_stack_sp = PL_stack_base + markix;
2749 register I32 items = SP - MARK;
2750 AV* padlist = CvPADLIST(cv);
2751 SV** svp = AvARRAY(padlist);
2752 push_return(PL_op->op_next);
2753 PUSHBLOCK(cx, CXt_SUB, MARK);
2756 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2757 * that eval'' ops within this sub know the correct lexical space.
2758 * Owing the speed considerations, we choose to search for the cv
2759 * in doeval() instead.
2761 if (CvDEPTH(cv) < 2)
2762 (void)SvREFCNT_inc(cv);
2763 else { /* save temporaries on recursion? */
2764 PERL_STACK_OVERFLOW_CHECK();
2765 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2767 AV *newpad = newAV();
2768 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2769 I32 ix = AvFILLp((AV*)svp[1]);
2770 I32 names_fill = AvFILLp((AV*)svp[0]);
2771 svp = AvARRAY(svp[0]);
2772 for ( ;ix > 0; ix--) {
2773 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2774 char *name = SvPVX(svp[ix]);
2775 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2776 || *name == '&') /* anonymous code? */
2778 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2780 else { /* our own lexical */
2782 av_store(newpad, ix, sv = (SV*)newAV());
2783 else if (*name == '%')
2784 av_store(newpad, ix, sv = (SV*)newHV());
2786 av_store(newpad, ix, sv = NEWSV(0,0));
2790 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2791 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2794 av_store(newpad, ix, sv = NEWSV(0,0));
2798 av = newAV(); /* will be @_ */
2800 av_store(newpad, 0, (SV*)av);
2801 AvFLAGS(av) = AVf_REIFY;
2802 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2803 AvFILLp(padlist) = CvDEPTH(cv);
2804 svp = AvARRAY(padlist);
2807 #ifdef USE_5005THREADS
2809 AV* av = (AV*)PL_curpad[0];
2811 items = AvFILLp(av) + 1;
2813 /* Mark is at the end of the stack. */
2815 Copy(AvARRAY(av), SP + 1, items, SV*);
2820 #endif /* USE_5005THREADS */
2821 SAVEVPTR(PL_curpad);
2822 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2823 #ifndef USE_5005THREADS
2825 #endif /* USE_5005THREADS */
2831 DEBUG_S(PerlIO_printf(Perl_debug_log,
2832 "%p entersub preparing @_\n", thr));
2834 av = (AV*)PL_curpad[0];
2836 /* @_ is normally not REAL--this should only ever
2837 * happen when DB::sub() calls things that modify @_ */
2842 #ifndef USE_5005THREADS
2843 cx->blk_sub.savearray = GvAV(PL_defgv);
2844 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2845 #endif /* USE_5005THREADS */
2846 cx->blk_sub.oldcurpad = PL_curpad;
2847 cx->blk_sub.argarray = av;
2850 if (items > AvMAX(av) + 1) {
2852 if (AvARRAY(av) != ary) {
2853 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2854 SvPVX(av) = (char*)ary;
2856 if (items > AvMAX(av) + 1) {
2857 AvMAX(av) = items - 1;
2858 Renew(ary,items,SV*);
2860 SvPVX(av) = (char*)ary;
2863 Copy(MARK,AvARRAY(av),items,SV*);
2864 AvFILLp(av) = items - 1;
2872 /* warning must come *after* we fully set up the context
2873 * stuff so that __WARN__ handlers can safely dounwind()
2876 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2877 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2878 sub_crush_depth(cv);
2880 DEBUG_S(PerlIO_printf(Perl_debug_log,
2881 "%p entersub returning %p\n", thr, CvSTART(cv)));
2883 RETURNOP(CvSTART(cv));
2888 Perl_sub_crush_depth(pTHX_ CV *cv)
2891 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2893 SV* tmpstr = sv_newmortal();
2894 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2895 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2905 IV elem = SvIV(elemsv);
2907 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2908 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2911 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2912 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2914 elem -= PL_curcop->cop_arybase;
2915 if (SvTYPE(av) != SVt_PVAV)
2917 svp = av_fetch(av, elem, lval && !defer);
2919 if (!svp || *svp == &PL_sv_undef) {
2922 DIE(aTHX_ PL_no_aelem, elem);
2923 lv = sv_newmortal();
2924 sv_upgrade(lv, SVt_PVLV);
2926 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2927 LvTARG(lv) = SvREFCNT_inc(av);
2928 LvTARGOFF(lv) = elem;
2933 if (PL_op->op_private & OPpLVAL_INTRO)
2934 save_aelem(av, elem, svp);
2935 else if (PL_op->op_private & OPpDEREF)
2936 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2938 sv = (svp ? *svp : &PL_sv_undef);
2939 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2940 sv = sv_mortalcopy(sv);
2946 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2952 Perl_croak(aTHX_ PL_no_modify);
2953 if (SvTYPE(sv) < SVt_RV)
2954 sv_upgrade(sv, SVt_RV);
2955 else if (SvTYPE(sv) >= SVt_PV) {
2956 (void)SvOOK_off(sv);
2957 Safefree(SvPVX(sv));
2958 SvLEN(sv) = SvCUR(sv) = 0;
2962 SvRV(sv) = NEWSV(355,0);
2965 SvRV(sv) = (SV*)newAV();
2968 SvRV(sv) = (SV*)newHV();
2983 if (SvTYPE(rsv) == SVt_PVCV) {
2989 SETs(method_common(sv, Null(U32*)));
2996 SV* sv = cSVOP->op_sv;
2997 U32 hash = SvUVX(sv);
2999 XPUSHs(method_common(sv, &hash));
3004 S_method_common(pTHX_ SV* meth, U32* hashp)
3015 name = SvPV(meth, namelen);
3016 sv = *(PL_stack_base + TOPMARK + 1);
3019 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3028 /* this isn't a reference */
3031 !(packname = SvPV(sv, packlen)) ||
3032 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3033 !(ob=(SV*)GvIO(iogv)))
3035 /* this isn't the name of a filehandle either */
3037 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3038 ? !isIDFIRST_utf8((U8*)packname)
3039 : !isIDFIRST(*packname)
3042 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3043 SvOK(sv) ? "without a package or object reference"
3044 : "on an undefined value");
3046 /* assume it's a package name */
3047 stash = gv_stashpvn(packname, packlen, FALSE);
3050 /* it _is_ a filehandle name -- replace with a reference */
3051 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3054 /* if we got here, ob should be a reference or a glob */
3055 if (!ob || !(SvOBJECT(ob)
3056 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3059 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3063 stash = SvSTASH(ob);
3066 /* NOTE: stash may be null, hope hv_fetch_ent and
3067 gv_fetchmethod can cope (it seems they can) */
3069 /* shortcut for simple names */
3071 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3073 gv = (GV*)HeVAL(he);
3074 if (isGV(gv) && GvCV(gv) &&
3075 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3076 return (SV*)GvCV(gv);
3080 gv = gv_fetchmethod(stash, name);
3083 /* This code tries to figure out just what went wrong with
3084 gv_fetchmethod. It therefore needs to duplicate a lot of
3085 the internals of that function. We can't move it inside
3086 Perl_gv_fetchmethod_autoload(), however, since that would
3087 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3094 for (p = name; *p; p++) {
3096 sep = p, leaf = p + 1;
3097 else if (*p == ':' && *(p + 1) == ':')
3098 sep = p, leaf = p + 2;
3100 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3101 /* the method name is unqualified or starts with SUPER:: */
3102 packname = sep ? CopSTASHPV(PL_curcop) :
3103 stash ? HvNAME(stash) : packname;
3104 packlen = strlen(packname);
3107 /* the method name is qualified */
3109 packlen = sep - name;
3112 /* we're relying on gv_fetchmethod not autovivifying the stash */
3113 if (gv_stashpvn(packname, packlen, FALSE)) {
3115 "Can't locate object method \"%s\" via package \"%.*s\"",
3116 leaf, (int)packlen, packname);
3120 "Can't locate object method \"%s\" via package \"%.*s\""
3121 " (perhaps you forgot to load \"%.*s\"?)",
3122 leaf, (int)packlen, packname, (int)packlen, packname);
3125 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3128 #ifdef USE_5005THREADS
3130 unset_cvowner(pTHX_ void *cvarg)
3132 register CV* cv = (CV *) cvarg;
3134 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3135 thr, cv, SvPEEK((SV*)cv))));
3136 MUTEX_LOCK(CvMUTEXP(cv));
3137 DEBUG_S(if (CvDEPTH(cv) != 0)
3138 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3140 assert(thr == CvOWNER(cv));
3142 MUTEX_UNLOCK(CvMUTEXP(cv));
3145 #endif /* USE_5005THREADS */