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 if (pm->op_pmdynflags & PMdf_TAINTED)
1194 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1201 register PMOP *pm = cPMOP;
1206 I32 r_flags = REXEC_CHECKED;
1207 char *truebase; /* Start of string */
1208 register REGEXP *rx = PM_GETRE(pm);
1213 I32 oldsave = PL_savestack_ix;
1214 I32 update_minmatch = 1;
1215 I32 had_zerolen = 0;
1217 if (PL_op->op_flags & OPf_STACKED)
1224 PUTBACK; /* EVAL blocks need stack_sp. */
1225 s = SvPV(TARG, len);
1228 DIE(aTHX_ "panic: pp_match");
1229 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1230 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1233 PL_reg_match_utf8 = DO_UTF8(TARG);
1235 if (pm->op_pmdynflags & PMdf_USED) {
1237 if (gimme == G_ARRAY)
1242 if (!rx->prelen && PL_curpm) {
1246 if (rx->minlen > len) goto failure;
1250 /* XXXX What part of this is needed with true \G-support? */
1251 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1253 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1254 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1255 if (mg && mg->mg_len >= 0) {
1256 if (!(rx->reganch & ROPT_GPOS_SEEN))
1257 rx->endp[0] = rx->startp[0] = mg->mg_len;
1258 else if (rx->reganch & ROPT_ANCH_GPOS) {
1259 r_flags |= REXEC_IGNOREPOS;
1260 rx->endp[0] = rx->startp[0] = mg->mg_len;
1262 minmatch = (mg->mg_flags & MGf_MINMATCH);
1263 update_minmatch = 0;
1267 if ((!global && rx->nparens)
1268 || SvTEMP(TARG) || PL_sawampersand)
1269 r_flags |= REXEC_COPY_STR;
1271 r_flags |= REXEC_SCREAM;
1273 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1274 SAVEINT(PL_multiline);
1275 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1279 if (global && rx->startp[0] != -1) {
1280 t = s = rx->endp[0] + truebase;
1281 if ((s + rx->minlen) > strend)
1283 if (update_minmatch++)
1284 minmatch = had_zerolen;
1286 if (rx->reganch & RE_USE_INTUIT &&
1287 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1288 PL_bostr = truebase;
1289 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1293 if ( (rx->reganch & ROPT_CHECK_ALL)
1295 && ((rx->reganch & ROPT_NOSCAN)
1296 || !((rx->reganch & RE_INTUIT_TAIL)
1297 && (r_flags & REXEC_SCREAM)))
1298 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1301 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1304 if (pm->op_pmflags & PMf_ONCE)
1305 pm->op_pmdynflags |= PMdf_USED;
1314 RX_MATCH_TAINTED_on(rx);
1315 TAINT_IF(RX_MATCH_TAINTED(rx));
1316 if (gimme == G_ARRAY) {
1317 I32 nparens, i, len;
1319 nparens = rx->nparens;
1320 if (global && !nparens)
1324 SPAGAIN; /* EVAL blocks could move the stack. */
1325 EXTEND(SP, nparens + i);
1326 EXTEND_MORTAL(nparens + i);
1327 for (i = !i; i <= nparens; i++) {
1328 PUSHs(sv_newmortal());
1330 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1331 len = rx->endp[i] - rx->startp[i];
1332 s = rx->startp[i] + truebase;
1333 sv_setpvn(*SP, s, len);
1334 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1339 if (pm->op_pmflags & PMf_CONTINUE) {
1341 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1342 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1344 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1345 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1347 if (rx->startp[0] != -1) {
1348 mg->mg_len = rx->endp[0];
1349 if (rx->startp[0] == rx->endp[0])
1350 mg->mg_flags |= MGf_MINMATCH;
1352 mg->mg_flags &= ~MGf_MINMATCH;
1355 had_zerolen = (rx->startp[0] != -1
1356 && rx->startp[0] == rx->endp[0]);
1357 PUTBACK; /* EVAL blocks may use stack */
1358 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1363 LEAVE_SCOPE(oldsave);
1369 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1370 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1372 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1373 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1375 if (rx->startp[0] != -1) {
1376 mg->mg_len = rx->endp[0];
1377 if (rx->startp[0] == rx->endp[0])
1378 mg->mg_flags |= MGf_MINMATCH;
1380 mg->mg_flags &= ~MGf_MINMATCH;
1383 LEAVE_SCOPE(oldsave);
1387 yup: /* Confirmed by INTUIT */
1389 RX_MATCH_TAINTED_on(rx);
1390 TAINT_IF(RX_MATCH_TAINTED(rx));
1392 if (pm->op_pmflags & PMf_ONCE)
1393 pm->op_pmdynflags |= PMdf_USED;
1394 if (RX_MATCH_COPIED(rx))
1395 Safefree(rx->subbeg);
1396 RX_MATCH_COPIED_off(rx);
1397 rx->subbeg = Nullch;
1399 rx->subbeg = truebase;
1400 rx->startp[0] = s - truebase;
1401 if (PL_reg_match_utf8) {
1402 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1403 rx->endp[0] = t - truebase;
1406 rx->endp[0] = s - truebase + rx->minlen;
1408 rx->sublen = strend - truebase;
1411 if (PL_sawampersand) {
1414 rx->subbeg = savepvn(t, strend - t);
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 = 0; /* used by @- and @+ */
1425 LEAVE_SCOPE(oldsave);
1430 if (global && !(pm->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)
1465 SvSetMagicSV_nosteal(TARG, TOPs);
1472 if (IoFLAGS(io) & IOf_ARGV) {
1473 if (IoFLAGS(io) & IOf_START) {
1475 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1476 IoFLAGS(io) &= ~IOf_START;
1477 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1478 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1479 SvSETMAGIC(GvSV(PL_last_in_gv));
1484 fp = nextargv(PL_last_in_gv);
1485 if (!fp) { /* Note: fp != IoIFP(io) */
1486 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1489 else if (type == OP_GLOB)
1490 fp = Perl_start_glob(aTHX_ POPs, io);
1492 else if (type == OP_GLOB)
1494 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1495 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1499 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1500 && (!io || !(IoFLAGS(io) & IOf_START))) {
1501 if (type == OP_GLOB)
1502 Perl_warner(aTHX_ WARN_GLOB,
1503 "glob failed (can't start child: %s)",
1506 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1508 if (gimme == G_SCALAR) {
1509 (void)SvOK_off(TARG);
1515 if (gimme == G_SCALAR) {
1519 (void)SvUPGRADE(sv, SVt_PV);
1520 tmplen = SvLEN(sv); /* remember if already alloced */
1522 Sv_Grow(sv, 80); /* try short-buffering it */
1523 if (type == OP_RCATLINE)
1529 sv = sv_2mortal(NEWSV(57, 80));
1533 /* This should not be marked tainted if the fp is marked clean */
1534 #define MAYBE_TAINT_LINE(io, sv) \
1535 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1540 /* delay EOF state for a snarfed empty file */
1541 #define SNARF_EOF(gimme,rs,io,sv) \
1542 (gimme != G_SCALAR || SvCUR(sv) \
1543 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1547 if (!sv_gets(sv, fp, offset)
1548 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1550 PerlIO_clearerr(fp);
1551 if (IoFLAGS(io) & IOf_ARGV) {
1552 fp = nextargv(PL_last_in_gv);
1555 (void)do_close(PL_last_in_gv, FALSE);
1557 else if (type == OP_GLOB) {
1558 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1559 Perl_warner(aTHX_ WARN_GLOB,
1560 "glob failed (child exited with status %d%s)",
1561 (int)(STATUS_CURRENT >> 8),
1562 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1565 if (gimme == G_SCALAR) {
1566 (void)SvOK_off(TARG);
1570 MAYBE_TAINT_LINE(io, sv);
1573 MAYBE_TAINT_LINE(io, sv);
1575 IoFLAGS(io) |= IOf_NOLINE;
1579 if (type == OP_GLOB) {
1582 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1583 tmps = SvEND(sv) - 1;
1584 if (*tmps == *SvPVX(PL_rs)) {
1589 for (tmps = SvPVX(sv); *tmps; tmps++)
1590 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1591 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1593 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1594 (void)POPs; /* Unmatched wildcard? Chuck it... */
1598 if (gimme == G_ARRAY) {
1599 if (SvLEN(sv) - SvCUR(sv) > 20) {
1600 SvLEN_set(sv, SvCUR(sv)+1);
1601 Renew(SvPVX(sv), SvLEN(sv), char);
1603 sv = sv_2mortal(NEWSV(58, 80));
1606 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1607 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1611 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1612 Renew(SvPVX(sv), SvLEN(sv), char);
1621 register PERL_CONTEXT *cx;
1622 I32 gimme = OP_GIMME(PL_op, -1);
1625 if (cxstack_ix >= 0)
1626 gimme = cxstack[cxstack_ix].blk_gimme;
1634 PUSHBLOCK(cx, CXt_BLOCK, SP);
1646 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1647 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1649 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1652 if (SvTYPE(hv) == SVt_PVHV) {
1653 if (PL_op->op_private & OPpLVAL_INTRO)
1654 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1655 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1656 svp = he ? &HeVAL(he) : 0;
1658 else if (SvTYPE(hv) == SVt_PVAV) {
1659 if (PL_op->op_private & OPpLVAL_INTRO)
1660 DIE(aTHX_ "Can't localize pseudo-hash element");
1661 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1667 if (!svp || *svp == &PL_sv_undef) {
1672 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1674 lv = sv_newmortal();
1675 sv_upgrade(lv, SVt_PVLV);
1677 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1678 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1679 LvTARG(lv) = SvREFCNT_inc(hv);
1684 if (PL_op->op_private & OPpLVAL_INTRO) {
1685 if (HvNAME(hv) && isGV(*svp))
1686 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1690 char *key = SvPV(keysv, keylen);
1691 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1693 save_helem(hv, keysv, svp);
1696 else if (PL_op->op_private & OPpDEREF)
1697 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1699 sv = (svp ? *svp : &PL_sv_undef);
1700 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1701 * Pushing the magical RHS on to the stack is useless, since
1702 * that magic is soon destined to be misled by the local(),
1703 * and thus the later pp_sassign() will fail to mg_get() the
1704 * old value. This should also cure problems with delayed
1705 * mg_get()s. GSAR 98-07-03 */
1706 if (!lval && SvGMAGICAL(sv))
1707 sv = sv_mortalcopy(sv);
1715 register PERL_CONTEXT *cx;
1721 if (PL_op->op_flags & OPf_SPECIAL) {
1722 cx = &cxstack[cxstack_ix];
1723 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1728 gimme = OP_GIMME(PL_op, -1);
1730 if (cxstack_ix >= 0)
1731 gimme = cxstack[cxstack_ix].blk_gimme;
1737 if (gimme == G_VOID)
1739 else if (gimme == G_SCALAR) {
1742 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1745 *MARK = sv_mortalcopy(TOPs);
1748 *MARK = &PL_sv_undef;
1752 else if (gimme == G_ARRAY) {
1753 /* in case LEAVE wipes old return values */
1754 for (mark = newsp + 1; mark <= SP; mark++) {
1755 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1756 *mark = sv_mortalcopy(*mark);
1757 TAINT_NOT; /* Each item is independent */
1761 PL_curpm = newpm; /* Don't pop $1 et al till now */
1771 register PERL_CONTEXT *cx;
1777 cx = &cxstack[cxstack_ix];
1778 if (CxTYPE(cx) != CXt_LOOP)
1779 DIE(aTHX_ "panic: pp_iter");
1781 itersvp = CxITERVAR(cx);
1782 av = cx->blk_loop.iterary;
1783 if (SvTYPE(av) != SVt_PVAV) {
1784 /* iterate ($min .. $max) */
1785 if (cx->blk_loop.iterlval) {
1786 /* string increment */
1787 register SV* cur = cx->blk_loop.iterlval;
1789 char *max = SvPV((SV*)av, maxlen);
1790 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1791 #ifndef USE_5005THREADS /* don't risk potential race */
1792 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1793 /* safe to reuse old SV */
1794 sv_setsv(*itersvp, cur);
1799 /* we need a fresh SV every time so that loop body sees a
1800 * completely new SV for closures/references to work as
1802 SvREFCNT_dec(*itersvp);
1803 *itersvp = newSVsv(cur);
1805 if (strEQ(SvPVX(cur), max))
1806 sv_setiv(cur, 0); /* terminate next time */
1813 /* integer increment */
1814 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1817 #ifndef USE_5005THREADS /* don't risk potential race */
1818 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1819 /* safe to reuse old SV */
1820 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1825 /* we need a fresh SV every time so that loop body sees a
1826 * completely new SV for closures/references to work as they
1828 SvREFCNT_dec(*itersvp);
1829 *itersvp = newSViv(cx->blk_loop.iterix++);
1835 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1838 SvREFCNT_dec(*itersvp);
1840 if (SvMAGICAL(av) || AvREIFY(av)) {
1841 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1848 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1854 if (av != PL_curstack && sv == &PL_sv_undef) {
1855 SV *lv = cx->blk_loop.iterlval;
1856 if (lv && SvREFCNT(lv) > 1) {
1861 SvREFCNT_dec(LvTARG(lv));
1863 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1864 sv_upgrade(lv, SVt_PVLV);
1866 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1868 LvTARG(lv) = SvREFCNT_inc(av);
1869 LvTARGOFF(lv) = cx->blk_loop.iterix;
1870 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1874 *itersvp = SvREFCNT_inc(sv);
1881 register PMOP *pm = cPMOP;
1897 register REGEXP *rx = PM_GETRE(pm);
1899 int force_on_match = 0;
1900 I32 oldsave = PL_savestack_ix;
1903 /* known replacement string? */
1904 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1905 if (PL_op->op_flags & OPf_STACKED)
1912 if (SvFAKE(TARG) && SvREADONLY(TARG))
1913 sv_force_normal(TARG);
1914 if (SvREADONLY(TARG)
1915 || (SvTYPE(TARG) > SVt_PVLV
1916 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1917 DIE(aTHX_ PL_no_modify);
1920 s = SvPV(TARG, len);
1921 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1923 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1924 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1929 PL_reg_match_utf8 = DO_UTF8(TARG);
1933 DIE(aTHX_ "panic: pp_subst");
1936 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1937 maxiters = 2 * slen + 10; /* We can match twice at each
1938 position, once with zero-length,
1939 second time with non-zero. */
1941 if (!rx->prelen && PL_curpm) {
1945 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1946 ? REXEC_COPY_STR : 0;
1948 r_flags |= REXEC_SCREAM;
1949 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1950 SAVEINT(PL_multiline);
1951 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1954 if (rx->reganch & RE_USE_INTUIT) {
1956 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1960 /* How to do it in subst? */
1961 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1963 && ((rx->reganch & ROPT_NOSCAN)
1964 || !((rx->reganch & RE_INTUIT_TAIL)
1965 && (r_flags & REXEC_SCREAM))))
1970 /* only replace once? */
1971 once = !(rpm->op_pmflags & PMf_GLOBAL);
1973 /* known replacement string? */
1974 c = dstr ? SvPV(dstr, clen) : Nullch;
1976 /* can do inplace substitution? */
1977 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1978 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1979 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1980 r_flags | REXEC_CHECKED))
1984 LEAVE_SCOPE(oldsave);
1987 if (force_on_match) {
1989 s = SvPV_force(TARG, len);
1994 SvSCREAM_off(TARG); /* disable possible screamer */
1996 rxtainted |= RX_MATCH_TAINTED(rx);
1997 m = orig + rx->startp[0];
1998 d = orig + rx->endp[0];
2000 if (m - s > strend - d) { /* faster to shorten from end */
2002 Copy(c, m, clen, char);
2007 Move(d, m, i, char);
2011 SvCUR_set(TARG, m - s);
2014 else if ((i = m - s)) { /* faster from front */
2022 Copy(c, m, clen, char);
2027 Copy(c, d, clen, char);
2032 TAINT_IF(rxtainted & 1);
2038 if (iters++ > maxiters)
2039 DIE(aTHX_ "Substitution loop");
2040 rxtainted |= RX_MATCH_TAINTED(rx);
2041 m = rx->startp[0] + orig;
2045 Move(s, d, i, char);
2049 Copy(c, d, clen, char);
2052 s = rx->endp[0] + orig;
2053 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2055 /* don't match same null twice */
2056 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2059 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2060 Move(s, d, i+1, char); /* include the NUL */
2062 TAINT_IF(rxtainted & 1);
2064 PUSHs(sv_2mortal(newSViv((I32)iters)));
2066 (void)SvPOK_only_UTF8(TARG);
2067 TAINT_IF(rxtainted);
2068 if (SvSMAGICAL(TARG)) {
2074 LEAVE_SCOPE(oldsave);
2078 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2079 r_flags | REXEC_CHECKED))
2083 if (force_on_match) {
2085 s = SvPV_force(TARG, len);
2088 rxtainted |= RX_MATCH_TAINTED(rx);
2089 dstr = NEWSV(25, len);
2090 sv_setpvn(dstr, m, s-m);
2095 register PERL_CONTEXT *cx;
2098 RETURNOP(cPMOP->op_pmreplroot);
2100 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2102 if (iters++ > maxiters)
2103 DIE(aTHX_ "Substitution loop");
2104 rxtainted |= RX_MATCH_TAINTED(rx);
2105 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2110 strend = s + (strend - m);
2112 m = rx->startp[0] + orig;
2113 sv_catpvn(dstr, s, m-s);
2114 s = rx->endp[0] + orig;
2116 sv_catpvn(dstr, c, clen);
2119 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2120 TARG, NULL, r_flags));
2121 sv_catpvn(dstr, s, strend - s);
2123 (void)SvOOK_off(TARG);
2124 Safefree(SvPVX(TARG));
2125 SvPVX(TARG) = SvPVX(dstr);
2126 SvCUR_set(TARG, SvCUR(dstr));
2127 SvLEN_set(TARG, SvLEN(dstr));
2128 isutf8 = DO_UTF8(dstr);
2132 TAINT_IF(rxtainted & 1);
2134 PUSHs(sv_2mortal(newSViv((I32)iters)));
2136 (void)SvPOK_only(TARG);
2139 TAINT_IF(rxtainted);
2142 LEAVE_SCOPE(oldsave);
2151 LEAVE_SCOPE(oldsave);
2160 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2161 ++*PL_markstack_ptr;
2162 LEAVE; /* exit inner scope */
2165 if (PL_stack_base + *PL_markstack_ptr > SP) {
2167 I32 gimme = GIMME_V;
2169 LEAVE; /* exit outer scope */
2170 (void)POPMARK; /* pop src */
2171 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2172 (void)POPMARK; /* pop dst */
2173 SP = PL_stack_base + POPMARK; /* pop original mark */
2174 if (gimme == G_SCALAR) {
2178 else if (gimme == G_ARRAY)
2185 ENTER; /* enter inner scope */
2188 src = PL_stack_base[*PL_markstack_ptr];
2192 RETURNOP(cLOGOP->op_other);
2203 register PERL_CONTEXT *cx;
2209 if (gimme == G_SCALAR) {
2212 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2214 *MARK = SvREFCNT_inc(TOPs);
2219 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2221 *MARK = sv_mortalcopy(sv);
2226 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2230 *MARK = &PL_sv_undef;
2234 else if (gimme == G_ARRAY) {
2235 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2236 if (!SvTEMP(*MARK)) {
2237 *MARK = sv_mortalcopy(*MARK);
2238 TAINT_NOT; /* Each item is independent */
2244 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2245 PL_curpm = newpm; /* ... and pop $1 et al */
2249 return pop_return();
2252 /* This duplicates the above code because the above code must not
2253 * get any slower by more conditions */
2261 register PERL_CONTEXT *cx;
2268 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2269 /* We are an argument to a function or grep().
2270 * This kind of lvalueness was legal before lvalue
2271 * subroutines too, so be backward compatible:
2272 * cannot report errors. */
2274 /* Scalar context *is* possible, on the LHS of -> only,
2275 * as in f()->meth(). But this is not an lvalue. */
2276 if (gimme == G_SCALAR)
2278 if (gimme == G_ARRAY) {
2279 if (!CvLVALUE(cx->blk_sub.cv))
2280 goto temporise_array;
2281 EXTEND_MORTAL(SP - newsp);
2282 for (mark = newsp + 1; mark <= SP; mark++) {
2285 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2286 *mark = sv_mortalcopy(*mark);
2288 /* Can be a localized value subject to deletion. */
2289 PL_tmps_stack[++PL_tmps_ix] = *mark;
2290 (void)SvREFCNT_inc(*mark);
2295 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2296 /* Here we go for robustness, not for speed, so we change all
2297 * the refcounts so the caller gets a live guy. Cannot set
2298 * TEMP, so sv_2mortal is out of question. */
2299 if (!CvLVALUE(cx->blk_sub.cv)) {
2304 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2306 if (gimme == G_SCALAR) {
2310 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2315 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2316 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2318 else { /* Can be a localized value
2319 * subject to deletion. */
2320 PL_tmps_stack[++PL_tmps_ix] = *mark;
2321 (void)SvREFCNT_inc(*mark);
2324 else { /* Should not happen? */
2329 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2330 (MARK > SP ? "Empty array" : "Array"));
2334 else if (gimme == G_ARRAY) {
2335 EXTEND_MORTAL(SP - newsp);
2336 for (mark = newsp + 1; mark <= SP; mark++) {
2337 if (*mark != &PL_sv_undef
2338 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2339 /* Might be flattened array after $#array = */
2345 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2346 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2349 /* Can be a localized value subject to deletion. */
2350 PL_tmps_stack[++PL_tmps_ix] = *mark;
2351 (void)SvREFCNT_inc(*mark);
2357 if (gimme == G_SCALAR) {
2361 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2363 *MARK = SvREFCNT_inc(TOPs);
2368 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2370 *MARK = sv_mortalcopy(sv);
2375 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2379 *MARK = &PL_sv_undef;
2383 else if (gimme == G_ARRAY) {
2385 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2386 if (!SvTEMP(*MARK)) {
2387 *MARK = sv_mortalcopy(*MARK);
2388 TAINT_NOT; /* Each item is independent */
2395 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2396 PL_curpm = newpm; /* ... and pop $1 et al */
2400 return pop_return();
2405 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2407 SV *dbsv = GvSV(PL_DBsub);
2409 if (!PERLDB_SUB_NN) {
2413 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2414 || strEQ(GvNAME(gv), "END")
2415 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2416 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2417 && (gv = (GV*)*svp) ))) {
2418 /* Use GV from the stack as a fallback. */
2419 /* GV is potentially non-unique, or contain different CV. */
2420 SV *tmp = newRV((SV*)cv);
2421 sv_setsv(dbsv, tmp);
2425 gv_efullname3(dbsv, gv, Nullch);
2429 (void)SvUPGRADE(dbsv, SVt_PVIV);
2430 (void)SvIOK_on(dbsv);
2431 SAVEIV(SvIVX(dbsv));
2432 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2436 PL_curcopdb = PL_curcop;
2437 cv = GvCV(PL_DBsub);
2447 register PERL_CONTEXT *cx;
2449 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2452 DIE(aTHX_ "Not a CODE reference");
2453 switch (SvTYPE(sv)) {
2459 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2461 SP = PL_stack_base + POPMARK;
2464 if (SvGMAGICAL(sv)) {
2468 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2471 sym = SvPV(sv, n_a);
2473 DIE(aTHX_ PL_no_usym, "a subroutine");
2474 if (PL_op->op_private & HINT_STRICT_REFS)
2475 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2476 cv = get_cv(sym, TRUE);
2481 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2482 tryAMAGICunDEREF(to_cv);
2485 if (SvTYPE(cv) == SVt_PVCV)
2490 DIE(aTHX_ "Not a CODE reference");
2495 if (!(cv = GvCVu((GV*)sv)))
2496 cv = sv_2cv(sv, &stash, &gv, FALSE);
2509 if (!CvROOT(cv) && !CvXSUB(cv)) {
2513 /* anonymous or undef'd function leaves us no recourse */
2514 if (CvANON(cv) || !(gv = CvGV(cv)))
2515 DIE(aTHX_ "Undefined subroutine called");
2517 /* autoloaded stub? */
2518 if (cv != GvCV(gv)) {
2521 /* should call AUTOLOAD now? */
2524 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2531 sub_name = sv_newmortal();
2532 gv_efullname3(sub_name, gv, Nullch);
2533 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2537 DIE(aTHX_ "Not a CODE reference");
2542 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2543 cv = get_db_sub(&sv, cv);
2545 DIE(aTHX_ "No DBsub routine");
2548 #ifdef USE_5005THREADS
2550 * First we need to check if the sub or method requires locking.
2551 * If so, we gain a lock on the CV, the first argument or the
2552 * stash (for static methods), as appropriate. This has to be
2553 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2554 * reschedule by returning a new op.
2556 MUTEX_LOCK(CvMUTEXP(cv));
2557 if (CvFLAGS(cv) & CVf_LOCKED) {
2559 if (CvFLAGS(cv) & CVf_METHOD) {
2560 if (SP > PL_stack_base + TOPMARK)
2561 sv = *(PL_stack_base + TOPMARK + 1);
2563 AV *av = (AV*)PL_curpad[0];
2564 if (hasargs || !av || AvFILLp(av) < 0
2565 || !(sv = AvARRAY(av)[0]))
2567 MUTEX_UNLOCK(CvMUTEXP(cv));
2568 DIE(aTHX_ "no argument for locked method call");
2575 char *stashname = SvPV(sv, len);
2576 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2582 MUTEX_UNLOCK(CvMUTEXP(cv));
2583 mg = condpair_magic(sv);
2584 MUTEX_LOCK(MgMUTEXP(mg));
2585 if (MgOWNER(mg) == thr)
2586 MUTEX_UNLOCK(MgMUTEXP(mg));
2589 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2591 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2593 MUTEX_UNLOCK(MgMUTEXP(mg));
2594 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2596 MUTEX_LOCK(CvMUTEXP(cv));
2599 * Now we have permission to enter the sub, we must distinguish
2600 * four cases. (0) It's an XSUB (in which case we don't care
2601 * about ownership); (1) it's ours already (and we're recursing);
2602 * (2) it's free (but we may already be using a cached clone);
2603 * (3) another thread owns it. Case (1) is easy: we just use it.
2604 * Case (2) means we look for a clone--if we have one, use it
2605 * otherwise grab ownership of cv. Case (3) means we look for a
2606 * clone (for non-XSUBs) and have to create one if we don't
2608 * Why look for a clone in case (2) when we could just grab
2609 * ownership of cv straight away? Well, we could be recursing,
2610 * i.e. we originally tried to enter cv while another thread
2611 * owned it (hence we used a clone) but it has been freed up
2612 * and we're now recursing into it. It may or may not be "better"
2613 * to use the clone but at least CvDEPTH can be trusted.
2615 if (CvOWNER(cv) == thr || CvXSUB(cv))
2616 MUTEX_UNLOCK(CvMUTEXP(cv));
2618 /* Case (2) or (3) */
2622 * XXX Might it be better to release CvMUTEXP(cv) while we
2623 * do the hv_fetch? We might find someone has pinched it
2624 * when we look again, in which case we would be in case
2625 * (3) instead of (2) so we'd have to clone. Would the fact
2626 * that we released the mutex more quickly make up for this?
2628 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2630 /* We already have a clone to use */
2631 MUTEX_UNLOCK(CvMUTEXP(cv));
2633 DEBUG_S(PerlIO_printf(Perl_debug_log,
2634 "entersub: %p already has clone %p:%s\n",
2635 thr, cv, SvPEEK((SV*)cv)));
2638 if (CvDEPTH(cv) == 0)
2639 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2642 /* (2) => grab ownership of cv. (3) => make clone */
2646 MUTEX_UNLOCK(CvMUTEXP(cv));
2647 DEBUG_S(PerlIO_printf(Perl_debug_log,
2648 "entersub: %p grabbing %p:%s in stash %s\n",
2649 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2650 HvNAME(CvSTASH(cv)) : "(none)"));
2653 /* Make a new clone. */
2655 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2656 MUTEX_UNLOCK(CvMUTEXP(cv));
2657 DEBUG_S((PerlIO_printf(Perl_debug_log,
2658 "entersub: %p cloning %p:%s\n",
2659 thr, cv, SvPEEK((SV*)cv))));
2661 * We're creating a new clone so there's no race
2662 * between the original MUTEX_UNLOCK and the
2663 * SvREFCNT_inc since no one will be trying to undef
2664 * it out from underneath us. At least, I don't think
2667 clonecv = cv_clone(cv);
2668 SvREFCNT_dec(cv); /* finished with this */
2669 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2670 CvOWNER(clonecv) = thr;
2674 DEBUG_S(if (CvDEPTH(cv) != 0)
2675 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2677 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2680 #endif /* USE_5005THREADS */
2683 #ifdef PERL_XSUB_OLDSTYLE
2684 if (CvOLDSTYLE(cv)) {
2685 I32 (*fp3)(int,int,int);
2687 register I32 items = SP - MARK;
2688 /* We dont worry to copy from @_. */
2693 PL_stack_sp = mark + 1;
2694 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2695 items = (*fp3)(CvXSUBANY(cv).any_i32,
2696 MARK - PL_stack_base + 1,
2698 PL_stack_sp = PL_stack_base + items;
2701 #endif /* PERL_XSUB_OLDSTYLE */
2703 I32 markix = TOPMARK;
2708 /* Need to copy @_ to stack. Alternative may be to
2709 * switch stack to @_, and copy return values
2710 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2713 #ifdef USE_5005THREADS
2714 av = (AV*)PL_curpad[0];
2716 av = GvAV(PL_defgv);
2717 #endif /* USE_5005THREADS */
2718 items = AvFILLp(av) + 1; /* @_ is not tieable */
2721 /* Mark is at the end of the stack. */
2723 Copy(AvARRAY(av), SP + 1, items, SV*);
2728 /* We assume first XSUB in &DB::sub is the called one. */
2730 SAVEVPTR(PL_curcop);
2731 PL_curcop = PL_curcopdb;
2734 /* Do we need to open block here? XXXX */
2735 (void)(*CvXSUB(cv))(aTHX_ cv);
2737 /* Enforce some sanity in scalar context. */
2738 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2739 if (markix > PL_stack_sp - PL_stack_base)
2740 *(PL_stack_base + markix) = &PL_sv_undef;
2742 *(PL_stack_base + markix) = *PL_stack_sp;
2743 PL_stack_sp = PL_stack_base + markix;
2751 register I32 items = SP - MARK;
2752 AV* padlist = CvPADLIST(cv);
2753 SV** svp = AvARRAY(padlist);
2754 push_return(PL_op->op_next);
2755 PUSHBLOCK(cx, CXt_SUB, MARK);
2758 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2759 * that eval'' ops within this sub know the correct lexical space.
2760 * Owing the speed considerations, we choose to search for the cv
2761 * in doeval() instead.
2763 if (CvDEPTH(cv) < 2)
2764 (void)SvREFCNT_inc(cv);
2765 else { /* save temporaries on recursion? */
2766 PERL_STACK_OVERFLOW_CHECK();
2767 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2769 AV *newpad = newAV();
2770 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2771 I32 ix = AvFILLp((AV*)svp[1]);
2772 I32 names_fill = AvFILLp((AV*)svp[0]);
2773 svp = AvARRAY(svp[0]);
2774 for ( ;ix > 0; ix--) {
2775 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2776 char *name = SvPVX(svp[ix]);
2777 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2778 || *name == '&') /* anonymous code? */
2780 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2782 else { /* our own lexical */
2784 av_store(newpad, ix, sv = (SV*)newAV());
2785 else if (*name == '%')
2786 av_store(newpad, ix, sv = (SV*)newHV());
2788 av_store(newpad, ix, sv = NEWSV(0,0));
2792 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2793 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2796 av_store(newpad, ix, sv = NEWSV(0,0));
2800 av = newAV(); /* will be @_ */
2802 av_store(newpad, 0, (SV*)av);
2803 AvFLAGS(av) = AVf_REIFY;
2804 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2805 AvFILLp(padlist) = CvDEPTH(cv);
2806 svp = AvARRAY(padlist);
2809 #ifdef USE_5005THREADS
2811 AV* av = (AV*)PL_curpad[0];
2813 items = AvFILLp(av) + 1;
2815 /* Mark is at the end of the stack. */
2817 Copy(AvARRAY(av), SP + 1, items, SV*);
2822 #endif /* USE_5005THREADS */
2823 SAVEVPTR(PL_curpad);
2824 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2825 #ifndef USE_5005THREADS
2827 #endif /* USE_5005THREADS */
2833 DEBUG_S(PerlIO_printf(Perl_debug_log,
2834 "%p entersub preparing @_\n", thr));
2836 av = (AV*)PL_curpad[0];
2838 /* @_ is normally not REAL--this should only ever
2839 * happen when DB::sub() calls things that modify @_ */
2844 #ifndef USE_5005THREADS
2845 cx->blk_sub.savearray = GvAV(PL_defgv);
2846 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2847 #endif /* USE_5005THREADS */
2848 cx->blk_sub.oldcurpad = PL_curpad;
2849 cx->blk_sub.argarray = av;
2852 if (items > AvMAX(av) + 1) {
2854 if (AvARRAY(av) != ary) {
2855 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2856 SvPVX(av) = (char*)ary;
2858 if (items > AvMAX(av) + 1) {
2859 AvMAX(av) = items - 1;
2860 Renew(ary,items,SV*);
2862 SvPVX(av) = (char*)ary;
2865 Copy(MARK,AvARRAY(av),items,SV*);
2866 AvFILLp(av) = items - 1;
2874 /* warning must come *after* we fully set up the context
2875 * stuff so that __WARN__ handlers can safely dounwind()
2878 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2879 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2880 sub_crush_depth(cv);
2882 DEBUG_S(PerlIO_printf(Perl_debug_log,
2883 "%p entersub returning %p\n", thr, CvSTART(cv)));
2885 RETURNOP(CvSTART(cv));
2890 Perl_sub_crush_depth(pTHX_ CV *cv)
2893 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2895 SV* tmpstr = sv_newmortal();
2896 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2897 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2907 IV elem = SvIV(elemsv);
2909 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2910 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2913 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2914 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2916 elem -= PL_curcop->cop_arybase;
2917 if (SvTYPE(av) != SVt_PVAV)
2919 svp = av_fetch(av, elem, lval && !defer);
2921 if (!svp || *svp == &PL_sv_undef) {
2924 DIE(aTHX_ PL_no_aelem, elem);
2925 lv = sv_newmortal();
2926 sv_upgrade(lv, SVt_PVLV);
2928 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2929 LvTARG(lv) = SvREFCNT_inc(av);
2930 LvTARGOFF(lv) = elem;
2935 if (PL_op->op_private & OPpLVAL_INTRO)
2936 save_aelem(av, elem, svp);
2937 else if (PL_op->op_private & OPpDEREF)
2938 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2940 sv = (svp ? *svp : &PL_sv_undef);
2941 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2942 sv = sv_mortalcopy(sv);
2948 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2954 Perl_croak(aTHX_ PL_no_modify);
2955 if (SvTYPE(sv) < SVt_RV)
2956 sv_upgrade(sv, SVt_RV);
2957 else if (SvTYPE(sv) >= SVt_PV) {
2958 (void)SvOOK_off(sv);
2959 Safefree(SvPVX(sv));
2960 SvLEN(sv) = SvCUR(sv) = 0;
2964 SvRV(sv) = NEWSV(355,0);
2967 SvRV(sv) = (SV*)newAV();
2970 SvRV(sv) = (SV*)newHV();
2985 if (SvTYPE(rsv) == SVt_PVCV) {
2991 SETs(method_common(sv, Null(U32*)));
2998 SV* sv = cSVOP->op_sv;
2999 U32 hash = SvUVX(sv);
3001 XPUSHs(method_common(sv, &hash));
3006 S_method_common(pTHX_ SV* meth, U32* hashp)
3017 name = SvPV(meth, namelen);
3018 sv = *(PL_stack_base + TOPMARK + 1);
3021 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3030 /* this isn't a reference */
3033 !(packname = SvPV(sv, packlen)) ||
3034 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3035 !(ob=(SV*)GvIO(iogv)))
3037 /* this isn't the name of a filehandle either */
3039 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3040 ? !isIDFIRST_utf8((U8*)packname)
3041 : !isIDFIRST(*packname)
3044 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3045 SvOK(sv) ? "without a package or object reference"
3046 : "on an undefined value");
3048 /* assume it's a package name */
3049 stash = gv_stashpvn(packname, packlen, FALSE);
3052 /* it _is_ a filehandle name -- replace with a reference */
3053 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3056 /* if we got here, ob should be a reference or a glob */
3057 if (!ob || !(SvOBJECT(ob)
3058 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3061 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3065 stash = SvSTASH(ob);
3068 /* NOTE: stash may be null, hope hv_fetch_ent and
3069 gv_fetchmethod can cope (it seems they can) */
3071 /* shortcut for simple names */
3073 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3075 gv = (GV*)HeVAL(he);
3076 if (isGV(gv) && GvCV(gv) &&
3077 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3078 return (SV*)GvCV(gv);
3082 gv = gv_fetchmethod(stash, name);
3085 /* This code tries to figure out just what went wrong with
3086 gv_fetchmethod. It therefore needs to duplicate a lot of
3087 the internals of that function. We can't move it inside
3088 Perl_gv_fetchmethod_autoload(), however, since that would
3089 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3096 for (p = name; *p; p++) {
3098 sep = p, leaf = p + 1;
3099 else if (*p == ':' && *(p + 1) == ':')
3100 sep = p, leaf = p + 2;
3102 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3103 /* the method name is unqualified or starts with SUPER:: */
3104 packname = sep ? CopSTASHPV(PL_curcop) :
3105 stash ? HvNAME(stash) : packname;
3106 packlen = strlen(packname);
3109 /* the method name is qualified */
3111 packlen = sep - name;
3114 /* we're relying on gv_fetchmethod not autovivifying the stash */
3115 if (gv_stashpvn(packname, packlen, FALSE)) {
3117 "Can't locate object method \"%s\" via package \"%.*s\"",
3118 leaf, (int)packlen, packname);
3122 "Can't locate object method \"%s\" via package \"%.*s\""
3123 " (perhaps you forgot to load \"%.*s\"?)",
3124 leaf, (int)packlen, packname, (int)packlen, packname);
3127 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3130 #ifdef USE_5005THREADS
3132 unset_cvowner(pTHX_ void *cvarg)
3134 register CV* cv = (CV *) cvarg;
3136 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3137 thr, cv, SvPEEK((SV*)cv))));
3138 MUTEX_LOCK(CvMUTEXP(cv));
3139 DEBUG_S(if (CvDEPTH(cv) != 0)
3140 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3142 assert(thr == CvOWNER(cv));
3144 MUTEX_UNLOCK(CvMUTEXP(cv));
3147 #endif /* USE_5005THREADS */