3 * Copyright (c) 1991-2002, 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);
83 XPUSHs((SV*)cGVOP_gv);
94 RETURNOP(cLOGOP->op_other);
102 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
104 temp = left; left = right; right = temp;
106 if (PL_tainting && PL_tainted && !SvTAINTED(left))
108 SvSetMagicSV(right, left);
117 RETURNOP(cLOGOP->op_other);
119 RETURNOP(cLOGOP->op_next);
125 TAINT_NOT; /* Each statement is presumed innocent */
126 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
128 oldsave = PL_scopestack[PL_scopestack_ix - 1];
129 LEAVE_SCOPE(oldsave);
135 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
142 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
143 bool rbyte = !SvUTF8(right);
145 if (TARG == right && right != left) {
146 right = sv_2mortal(newSVpvn(rpv, rlen));
147 rpv = SvPV(right, rlen); /* no point setting UTF8 here */
151 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
152 lbyte = !SvUTF8(left);
153 sv_setpvn(TARG, lpv, llen);
159 else { /* TARG == left */
160 if (SvGMAGICAL(left))
161 mg_get(left); /* or mg_get(left) may happen here */
164 lpv = SvPV_nomg(left, llen);
165 lbyte = !SvUTF8(left);
168 #if defined(PERL_Y2KWARN)
169 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
170 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
171 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
173 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
174 "about to append an integer to '19'");
179 if (lbyte != rbyte) {
181 sv_utf8_upgrade_nomg(TARG);
183 sv_utf8_upgrade_nomg(right);
184 rpv = SvPV(right, rlen);
187 sv_catpvn_nomg(TARG, rpv, rlen);
198 if (PL_op->op_flags & OPf_MOD) {
199 if (PL_op->op_private & OPpLVAL_INTRO)
200 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
201 else if (PL_op->op_private & OPpDEREF) {
203 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
212 tryAMAGICunTARGET(iter, 0);
213 PL_last_in_gv = (GV*)(*PL_stack_sp--);
214 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
215 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
216 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
219 XPUSHs((SV*)PL_last_in_gv);
222 PL_last_in_gv = (GV*)(*PL_stack_sp--);
225 return do_readline();
230 dSP; tryAMAGICbinSET(eq,0);
231 #ifndef NV_PRESERVES_UV
232 if (SvROK(TOPs) && SvROK(TOPm1s)) {
234 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
238 #ifdef PERL_PRESERVE_IVUV
241 /* Unless the left argument is integer in range we are going
242 to have to use NV maths. Hence only attempt to coerce the
243 right argument if we know the left is integer. */
246 bool auvok = SvUOK(TOPm1s);
247 bool buvok = SvUOK(TOPs);
249 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
250 /* Casting IV to UV before comparison isn't going to matter
251 on 2s complement. On 1s complement or sign&magnitude
252 (if we have any of them) it could to make negative zero
253 differ from normal zero. As I understand it. (Need to
254 check - is negative zero implementation defined behaviour
256 UV buv = SvUVX(POPs);
257 UV auv = SvUVX(TOPs);
259 SETs(boolSV(auv == buv));
262 { /* ## Mixed IV,UV ## */
266 /* == is commutative so doesn't matter which is left or right */
268 /* top of stack (b) is the iv */
277 /* As uv is a UV, it's >0, so it cannot be == */
281 /* we know iv is >= 0 */
282 SETs(boolSV((UV)iv == SvUVX(uvp)));
290 SETs(boolSV(TOPn == value));
298 if (SvTYPE(TOPs) > SVt_PVLV)
299 DIE(aTHX_ PL_no_modify);
300 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
301 && SvIVX(TOPs) != IV_MAX)
304 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
306 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
319 RETURNOP(cLOGOP->op_other);
325 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
326 useleft = USE_LEFT(TOPm1s);
327 #ifdef PERL_PRESERVE_IVUV
328 /* We must see if we can perform the addition with integers if possible,
329 as the integer code detects overflow while the NV code doesn't.
330 If either argument hasn't had a numeric conversion yet attempt to get
331 the IV. It's important to do this now, rather than just assuming that
332 it's not IOK as a PV of "9223372036854775806" may not take well to NV
333 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
334 integer in case the second argument is IV=9223372036854775806
335 We can (now) rely on sv_2iv to do the right thing, only setting the
336 public IOK flag if the value in the NV (or PV) slot is truly integer.
338 A side effect is that this also aggressively prefers integer maths over
339 fp maths for integer values.
341 How to detect overflow?
343 C 99 section 6.2.6.1 says
345 The range of nonnegative values of a signed integer type is a subrange
346 of the corresponding unsigned integer type, and the representation of
347 the same value in each type is the same. A computation involving
348 unsigned operands can never overflow, because a result that cannot be
349 represented by the resulting unsigned integer type is reduced modulo
350 the number that is one greater than the largest value that can be
351 represented by the resulting type.
355 which I read as "unsigned ints wrap."
357 signed integer overflow seems to be classed as "exception condition"
359 If an exceptional condition occurs during the evaluation of an
360 expression (that is, if the result is not mathematically defined or not
361 in the range of representable values for its type), the behavior is
364 (6.5, the 5th paragraph)
366 I had assumed that on 2s complement machines signed arithmetic would
367 wrap, hence coded pp_add and pp_subtract on the assumption that
368 everything perl builds on would be happy. After much wailing and
369 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
370 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
371 unsigned code below is actually shorter than the old code. :-)
376 /* Unless the left argument is integer in range we are going to have to
377 use NV maths. Hence only attempt to coerce the right argument if
378 we know the left is integer. */
386 /* left operand is undef, treat as zero. + 0 is identity,
387 Could SETi or SETu right now, but space optimise by not adding
388 lots of code to speed up what is probably a rarish case. */
390 /* Left operand is defined, so is it IV? */
393 if ((auvok = SvUOK(TOPm1s)))
396 register IV aiv = SvIVX(TOPm1s);
399 auvok = 1; /* Now acting as a sign flag. */
400 } else { /* 2s complement assumption for IV_MIN */
408 bool result_good = 0;
411 bool buvok = SvUOK(TOPs);
416 register IV biv = SvIVX(TOPs);
423 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
424 else "IV" now, independent of how it came in.
425 if a, b represents positive, A, B negative, a maps to -A etc
430 all UV maths. negate result if A negative.
431 add if signs same, subtract if signs differ. */
437 /* Must get smaller */
443 /* result really should be -(auv-buv). as its negation
444 of true value, need to swap our result flag */
461 if (result <= (UV)IV_MIN)
464 /* result valid, but out of range for IV. */
469 } /* Overflow, drop through to NVs. */
476 /* left operand is undef, treat as zero. + 0.0 is identity. */
480 SETn( value + TOPn );
488 AV *av = GvAV(cGVOP_gv);
489 U32 lval = PL_op->op_flags & OPf_MOD;
490 SV** svp = av_fetch(av, PL_op->op_private, lval);
491 SV *sv = (svp ? *svp : &PL_sv_undef);
493 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
494 sv = sv_mortalcopy(sv);
503 do_join(TARG, *MARK, MARK, SP);
514 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
515 * will be enough to hold an OP*.
517 SV* sv = sv_newmortal();
518 sv_upgrade(sv, SVt_PVLV);
520 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
528 /* Oversized hot code. */
532 dSP; dMARK; dORIGMARK;
538 if (PL_op->op_flags & OPf_STACKED)
543 if (gv && (io = GvIO(gv))
544 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
547 if (MARK == ORIGMARK) {
548 /* If using default handle then we need to make space to
549 * pass object as 1st arg, so move other args up ...
553 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
557 *MARK = SvTIED_obj((SV*)io, mg);
560 call_method("PRINT", G_SCALAR);
568 if (!(io = GvIO(gv))) {
569 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
570 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
572 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
573 report_evil_fh(gv, io, PL_op->op_type);
574 SETERRNO(EBADF,RMS$_IFI);
577 else if (!(fp = IoOFP(io))) {
578 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
580 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
581 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
582 report_evil_fh(gv, io, PL_op->op_type);
584 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
589 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
591 if (!do_print(*MARK, fp))
595 if (!do_print(PL_ofs_sv, fp)) { /* $, */
604 if (!do_print(*MARK, fp))
612 if (PL_ors_sv && SvOK(PL_ors_sv))
613 if (!do_print(PL_ors_sv, fp)) /* $\ */
616 if (IoFLAGS(io) & IOf_FLUSH)
617 if (PerlIO_flush(fp) == EOF)
638 tryAMAGICunDEREF(to_av);
641 if (SvTYPE(av) != SVt_PVAV)
642 DIE(aTHX_ "Not an ARRAY reference");
643 if (PL_op->op_flags & OPf_REF) {
648 if (GIMME == G_SCALAR)
649 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
655 if (SvTYPE(sv) == SVt_PVAV) {
657 if (PL_op->op_flags & OPf_REF) {
662 if (GIMME == G_SCALAR)
663 Perl_croak(aTHX_ "Can't return array to lvalue"
672 if (SvTYPE(sv) != SVt_PVGV) {
676 if (SvGMAGICAL(sv)) {
682 if (PL_op->op_flags & OPf_REF ||
683 PL_op->op_private & HINT_STRICT_REFS)
684 DIE(aTHX_ PL_no_usym, "an ARRAY");
685 if (ckWARN(WARN_UNINITIALIZED))
687 if (GIMME == G_ARRAY) {
694 if ((PL_op->op_flags & OPf_SPECIAL) &&
695 !(PL_op->op_flags & OPf_MOD))
697 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
699 && (!is_gv_magical(sym,len,0)
700 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
706 if (PL_op->op_private & HINT_STRICT_REFS)
707 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
708 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
715 if (PL_op->op_private & OPpLVAL_INTRO)
717 if (PL_op->op_flags & OPf_REF) {
722 if (GIMME == G_SCALAR)
723 Perl_croak(aTHX_ "Can't return array to lvalue"
731 if (GIMME == G_ARRAY) {
732 I32 maxarg = AvFILL(av) + 1;
733 (void)POPs; /* XXXX May be optimized away? */
735 if (SvRMAGICAL(av)) {
737 for (i=0; i < maxarg; i++) {
738 SV **svp = av_fetch(av, i, FALSE);
739 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
743 Copy(AvARRAY(av), SP+1, maxarg, SV*);
749 I32 maxarg = AvFILL(av) + 1;
762 tryAMAGICunDEREF(to_hv);
765 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
766 DIE(aTHX_ "Not a HASH reference");
767 if (PL_op->op_flags & OPf_REF) {
772 if (GIMME == G_SCALAR)
773 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
779 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
781 if (PL_op->op_flags & OPf_REF) {
786 if (GIMME == G_SCALAR)
787 Perl_croak(aTHX_ "Can't return hash to lvalue"
796 if (SvTYPE(sv) != SVt_PVGV) {
800 if (SvGMAGICAL(sv)) {
806 if (PL_op->op_flags & OPf_REF ||
807 PL_op->op_private & HINT_STRICT_REFS)
808 DIE(aTHX_ PL_no_usym, "a HASH");
809 if (ckWARN(WARN_UNINITIALIZED))
811 if (GIMME == G_ARRAY) {
818 if ((PL_op->op_flags & OPf_SPECIAL) &&
819 !(PL_op->op_flags & OPf_MOD))
821 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
823 && (!is_gv_magical(sym,len,0)
824 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
830 if (PL_op->op_private & HINT_STRICT_REFS)
831 DIE(aTHX_ PL_no_symref, sym, "a HASH");
832 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
839 if (PL_op->op_private & OPpLVAL_INTRO)
841 if (PL_op->op_flags & OPf_REF) {
846 if (GIMME == G_SCALAR)
847 Perl_croak(aTHX_ "Can't return hash to lvalue"
855 if (GIMME == G_ARRAY) { /* array wanted */
856 *PL_stack_sp = (SV*)hv;
861 if (SvTYPE(hv) == SVt_PVAV)
862 hv = avhv_keys((AV*)hv);
864 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
865 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
875 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
881 leftop = ((BINOP*)PL_op)->op_last;
883 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
884 leftop = ((LISTOP*)leftop)->op_first;
886 /* Skip PUSHMARK and each element already assigned to. */
887 for (i = lelem - firstlelem; i > 0; i--) {
888 leftop = leftop->op_sibling;
891 if (leftop->op_type != OP_RV2HV)
896 av_fill(ary, 0); /* clear all but the fields hash */
897 if (lastrelem >= relem) {
898 while (relem < lastrelem) { /* gobble up all the rest */
902 /* Avoid a memory leak when avhv_store_ent dies. */
903 tmpstr = sv_newmortal();
904 sv_setsv(tmpstr,relem[1]); /* value */
906 if (avhv_store_ent(ary,relem[0],tmpstr,0))
907 (void)SvREFCNT_inc(tmpstr);
908 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
914 if (relem == lastrelem)
920 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
924 if (ckWARN(WARN_MISC)) {
925 if (relem == firstrelem &&
927 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
928 SvTYPE(SvRV(*relem)) == SVt_PVHV))
930 Perl_warner(aTHX_ packWARN(WARN_MISC),
931 "Reference found where even-sized list expected");
934 Perl_warner(aTHX_ packWARN(WARN_MISC),
935 "Odd number of elements in hash assignment");
937 if (SvTYPE(hash) == SVt_PVAV) {
939 tmpstr = sv_newmortal();
940 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
941 (void)SvREFCNT_inc(tmpstr);
942 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
947 tmpstr = NEWSV(29,0);
948 didstore = hv_store_ent(hash,*relem,tmpstr,0);
949 if (SvMAGICAL(hash)) {
950 if (SvSMAGICAL(tmpstr))
963 SV **lastlelem = PL_stack_sp;
964 SV **lastrelem = PL_stack_base + POPMARK;
965 SV **firstrelem = PL_stack_base + POPMARK + 1;
966 SV **firstlelem = lastrelem + 1;
979 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
981 /* If there's a common identifier on both sides we have to take
982 * special care that assigning the identifier on the left doesn't
983 * clobber a value on the right that's used later in the list.
985 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
986 EXTEND_MORTAL(lastrelem - firstrelem + 1);
987 for (relem = firstrelem; relem <= lastrelem; relem++) {
990 TAINT_NOT; /* Each item is independent */
991 *relem = sv_mortalcopy(sv);
1001 while (lelem <= lastlelem) {
1002 TAINT_NOT; /* Each item stands on its own, taintwise. */
1004 switch (SvTYPE(sv)) {
1007 magic = SvMAGICAL(ary) != 0;
1008 if (PL_op->op_private & OPpASSIGN_HASH) {
1009 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1015 do_oddball((HV*)ary, relem, firstrelem);
1017 relem = lastrelem + 1;
1022 av_extend(ary, lastrelem - relem);
1024 while (relem <= lastrelem) { /* gobble up all the rest */
1028 sv_setsv(sv,*relem);
1030 didstore = av_store(ary,i++,sv);
1040 case SVt_PVHV: { /* normal hash */
1044 magic = SvMAGICAL(hash) != 0;
1047 while (relem < lastrelem) { /* gobble up all the rest */
1052 sv = &PL_sv_no, relem++;
1053 tmpstr = NEWSV(29,0);
1055 sv_setsv(tmpstr,*relem); /* value */
1056 *(relem++) = tmpstr;
1057 didstore = hv_store_ent(hash,sv,tmpstr,0);
1059 if (SvSMAGICAL(tmpstr))
1066 if (relem == lastrelem) {
1067 do_oddball(hash, relem, firstrelem);
1073 if (SvIMMORTAL(sv)) {
1074 if (relem <= lastrelem)
1078 if (relem <= lastrelem) {
1079 sv_setsv(sv, *relem);
1083 sv_setsv(sv, &PL_sv_undef);
1088 if (PL_delaymagic & ~DM_DELAY) {
1089 if (PL_delaymagic & DM_UID) {
1090 #ifdef HAS_SETRESUID
1091 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1093 # ifdef HAS_SETREUID
1094 (void)setreuid(PL_uid,PL_euid);
1097 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1098 (void)setruid(PL_uid);
1099 PL_delaymagic &= ~DM_RUID;
1101 # endif /* HAS_SETRUID */
1103 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1104 (void)seteuid(PL_uid);
1105 PL_delaymagic &= ~DM_EUID;
1107 # endif /* HAS_SETEUID */
1108 if (PL_delaymagic & DM_UID) {
1109 if (PL_uid != PL_euid)
1110 DIE(aTHX_ "No setreuid available");
1111 (void)PerlProc_setuid(PL_uid);
1113 # endif /* HAS_SETREUID */
1114 #endif /* HAS_SETRESUID */
1115 PL_uid = PerlProc_getuid();
1116 PL_euid = PerlProc_geteuid();
1118 if (PL_delaymagic & DM_GID) {
1119 #ifdef HAS_SETRESGID
1120 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1122 # ifdef HAS_SETREGID
1123 (void)setregid(PL_gid,PL_egid);
1126 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1127 (void)setrgid(PL_gid);
1128 PL_delaymagic &= ~DM_RGID;
1130 # endif /* HAS_SETRGID */
1132 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1133 (void)setegid(PL_gid);
1134 PL_delaymagic &= ~DM_EGID;
1136 # endif /* HAS_SETEGID */
1137 if (PL_delaymagic & DM_GID) {
1138 if (PL_gid != PL_egid)
1139 DIE(aTHX_ "No setregid available");
1140 (void)PerlProc_setgid(PL_gid);
1142 # endif /* HAS_SETREGID */
1143 #endif /* HAS_SETRESGID */
1144 PL_gid = PerlProc_getgid();
1145 PL_egid = PerlProc_getegid();
1147 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1152 if (gimme == G_VOID)
1153 SP = firstrelem - 1;
1154 else if (gimme == G_SCALAR) {
1157 SETi(lastrelem - firstrelem + 1);
1163 SP = firstrelem + (lastlelem - firstlelem);
1164 lelem = firstlelem + (relem - firstrelem);
1166 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1174 register PMOP *pm = cPMOP;
1175 SV *rv = sv_newmortal();
1176 SV *sv = newSVrv(rv, "Regexp");
1177 if (pm->op_pmdynflags & PMdf_TAINTED)
1179 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1186 register PMOP *pm = cPMOP;
1191 I32 r_flags = REXEC_CHECKED;
1192 char *truebase; /* Start of string */
1193 register REGEXP *rx = PM_GETRE(pm);
1198 I32 oldsave = PL_savestack_ix;
1199 I32 update_minmatch = 1;
1200 I32 had_zerolen = 0;
1202 if (PL_op->op_flags & OPf_STACKED)
1209 PUTBACK; /* EVAL blocks need stack_sp. */
1210 s = SvPV(TARG, len);
1213 DIE(aTHX_ "panic: pp_match");
1214 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1215 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1218 PL_reg_match_utf8 = DO_UTF8(TARG);
1220 if (pm->op_pmdynflags & PMdf_USED) {
1222 if (gimme == G_ARRAY)
1227 if (!rx->prelen && PL_curpm) {
1231 if (rx->minlen > len)
1236 /* XXXX What part of this is needed with true \G-support? */
1237 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1239 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1240 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1241 if (mg && mg->mg_len >= 0) {
1242 if (!(rx->reganch & ROPT_GPOS_SEEN))
1243 rx->endp[0] = rx->startp[0] = mg->mg_len;
1244 else if (rx->reganch & ROPT_ANCH_GPOS) {
1245 r_flags |= REXEC_IGNOREPOS;
1246 rx->endp[0] = rx->startp[0] = mg->mg_len;
1248 minmatch = (mg->mg_flags & MGf_MINMATCH);
1249 update_minmatch = 0;
1253 if ((!global && rx->nparens)
1254 || SvTEMP(TARG) || PL_sawampersand)
1255 r_flags |= REXEC_COPY_STR;
1257 r_flags |= REXEC_SCREAM;
1259 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1260 SAVEINT(PL_multiline);
1261 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1265 if (global && rx->startp[0] != -1) {
1266 t = s = rx->endp[0] + truebase;
1267 if ((s + rx->minlen) > strend)
1269 if (update_minmatch++)
1270 minmatch = had_zerolen;
1272 if (rx->reganch & RE_USE_INTUIT &&
1273 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1274 PL_bostr = truebase;
1275 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1279 if ( (rx->reganch & ROPT_CHECK_ALL)
1281 && ((rx->reganch & ROPT_NOSCAN)
1282 || !((rx->reganch & RE_INTUIT_TAIL)
1283 && (r_flags & REXEC_SCREAM)))
1284 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1287 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1290 if (pm->op_pmflags & PMf_ONCE)
1291 pm->op_pmdynflags |= PMdf_USED;
1300 RX_MATCH_TAINTED_on(rx);
1301 TAINT_IF(RX_MATCH_TAINTED(rx));
1302 if (gimme == G_ARRAY) {
1303 I32 nparens, i, len;
1305 nparens = rx->nparens;
1306 if (global && !nparens)
1310 SPAGAIN; /* EVAL blocks could move the stack. */
1311 EXTEND(SP, nparens + i);
1312 EXTEND_MORTAL(nparens + i);
1313 for (i = !i; i <= nparens; i++) {
1314 PUSHs(sv_newmortal());
1316 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1317 len = rx->endp[i] - rx->startp[i];
1318 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1319 len < 0 || len > strend - s)
1320 DIE(aTHX_ "panic: pp_match start/end pointers");
1321 s = rx->startp[i] + truebase;
1322 sv_setpvn(*SP, s, len);
1323 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1328 if (pm->op_pmflags & PMf_CONTINUE) {
1330 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1331 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1333 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1334 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1336 if (rx->startp[0] != -1) {
1337 mg->mg_len = rx->endp[0];
1338 if (rx->startp[0] == rx->endp[0])
1339 mg->mg_flags |= MGf_MINMATCH;
1341 mg->mg_flags &= ~MGf_MINMATCH;
1344 had_zerolen = (rx->startp[0] != -1
1345 && rx->startp[0] == rx->endp[0]);
1346 PUTBACK; /* EVAL blocks may use stack */
1347 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1352 LEAVE_SCOPE(oldsave);
1358 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1359 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1361 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1362 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1364 if (rx->startp[0] != -1) {
1365 mg->mg_len = rx->endp[0];
1366 if (rx->startp[0] == rx->endp[0])
1367 mg->mg_flags |= MGf_MINMATCH;
1369 mg->mg_flags &= ~MGf_MINMATCH;
1372 LEAVE_SCOPE(oldsave);
1376 yup: /* Confirmed by INTUIT */
1378 RX_MATCH_TAINTED_on(rx);
1379 TAINT_IF(RX_MATCH_TAINTED(rx));
1381 if (pm->op_pmflags & PMf_ONCE)
1382 pm->op_pmdynflags |= PMdf_USED;
1383 if (RX_MATCH_COPIED(rx))
1384 Safefree(rx->subbeg);
1385 RX_MATCH_COPIED_off(rx);
1386 rx->subbeg = Nullch;
1388 rx->subbeg = truebase;
1389 rx->startp[0] = s - truebase;
1390 if (PL_reg_match_utf8) {
1391 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1392 rx->endp[0] = t - truebase;
1395 rx->endp[0] = s - truebase + rx->minlen;
1397 rx->sublen = strend - truebase;
1400 if (PL_sawampersand) {
1403 rx->subbeg = savepvn(t, strend - t);
1404 rx->sublen = strend - t;
1405 RX_MATCH_COPIED_on(rx);
1406 off = rx->startp[0] = s - t;
1407 rx->endp[0] = off + rx->minlen;
1409 else { /* startp/endp are used by @- @+. */
1410 rx->startp[0] = s - truebase;
1411 rx->endp[0] = s - truebase + rx->minlen;
1413 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1414 LEAVE_SCOPE(oldsave);
1419 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1420 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1421 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1426 LEAVE_SCOPE(oldsave);
1427 if (gimme == G_ARRAY)
1433 Perl_do_readline(pTHX)
1435 dSP; dTARGETSTACKED;
1440 register IO *io = GvIO(PL_last_in_gv);
1441 register I32 type = PL_op->op_type;
1442 I32 gimme = GIMME_V;
1445 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1447 XPUSHs(SvTIED_obj((SV*)io, mg));
1450 call_method("READLINE", gimme);
1453 if (gimme == G_SCALAR)
1454 SvSetMagicSV_nosteal(TARG, TOPs);
1461 if (IoFLAGS(io) & IOf_ARGV) {
1462 if (IoFLAGS(io) & IOf_START) {
1464 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1465 IoFLAGS(io) &= ~IOf_START;
1466 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1467 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1468 SvSETMAGIC(GvSV(PL_last_in_gv));
1473 fp = nextargv(PL_last_in_gv);
1474 if (!fp) { /* Note: fp != IoIFP(io) */
1475 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1478 else if (type == OP_GLOB)
1479 fp = Perl_start_glob(aTHX_ POPs, io);
1481 else if (type == OP_GLOB)
1483 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1484 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1488 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1489 && (!io || !(IoFLAGS(io) & IOf_START))) {
1490 if (type == OP_GLOB)
1491 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1492 "glob failed (can't start child: %s)",
1495 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1497 if (gimme == G_SCALAR) {
1498 (void)SvOK_off(TARG);
1504 if (gimme == G_SCALAR) {
1508 (void)SvUPGRADE(sv, SVt_PV);
1509 tmplen = SvLEN(sv); /* remember if already alloced */
1511 Sv_Grow(sv, 80); /* try short-buffering it */
1512 if (type == OP_RCATLINE)
1518 sv = sv_2mortal(NEWSV(57, 80));
1522 /* This should not be marked tainted if the fp is marked clean */
1523 #define MAYBE_TAINT_LINE(io, sv) \
1524 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1529 /* delay EOF state for a snarfed empty file */
1530 #define SNARF_EOF(gimme,rs,io,sv) \
1531 (gimme != G_SCALAR || SvCUR(sv) \
1532 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1536 if (!sv_gets(sv, fp, offset)
1537 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1539 PerlIO_clearerr(fp);
1540 if (IoFLAGS(io) & IOf_ARGV) {
1541 fp = nextargv(PL_last_in_gv);
1544 (void)do_close(PL_last_in_gv, FALSE);
1546 else if (type == OP_GLOB) {
1547 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1548 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1549 "glob failed (child exited with status %d%s)",
1550 (int)(STATUS_CURRENT >> 8),
1551 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1554 if (gimme == G_SCALAR) {
1555 (void)SvOK_off(TARG);
1559 MAYBE_TAINT_LINE(io, sv);
1562 MAYBE_TAINT_LINE(io, sv);
1564 IoFLAGS(io) |= IOf_NOLINE;
1568 if (type == OP_GLOB) {
1571 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1572 tmps = SvEND(sv) - 1;
1573 if (*tmps == *SvPVX(PL_rs)) {
1578 for (tmps = SvPVX(sv); *tmps; tmps++)
1579 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1580 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1582 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1583 (void)POPs; /* Unmatched wildcard? Chuck it... */
1587 if (gimme == G_ARRAY) {
1588 if (SvLEN(sv) - SvCUR(sv) > 20) {
1589 SvLEN_set(sv, SvCUR(sv)+1);
1590 Renew(SvPVX(sv), SvLEN(sv), char);
1592 sv = sv_2mortal(NEWSV(58, 80));
1595 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1596 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1600 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1601 Renew(SvPVX(sv), SvLEN(sv), char);
1610 register PERL_CONTEXT *cx;
1611 I32 gimme = OP_GIMME(PL_op, -1);
1614 if (cxstack_ix >= 0)
1615 gimme = cxstack[cxstack_ix].blk_gimme;
1623 PUSHBLOCK(cx, CXt_BLOCK, SP);
1635 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1636 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1638 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1641 if (SvTYPE(hv) == SVt_PVHV) {
1642 if (PL_op->op_private & OPpLVAL_INTRO)
1643 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1644 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1645 svp = he ? &HeVAL(he) : 0;
1647 else if (SvTYPE(hv) == SVt_PVAV) {
1648 if (PL_op->op_private & OPpLVAL_INTRO)
1649 DIE(aTHX_ "Can't localize pseudo-hash element");
1650 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1656 if (!svp || *svp == &PL_sv_undef) {
1661 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1663 lv = sv_newmortal();
1664 sv_upgrade(lv, SVt_PVLV);
1666 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1667 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1668 LvTARG(lv) = SvREFCNT_inc(hv);
1673 if (PL_op->op_private & OPpLVAL_INTRO) {
1674 if (HvNAME(hv) && isGV(*svp))
1675 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1679 char *key = SvPV(keysv, keylen);
1680 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1682 save_helem(hv, keysv, svp);
1685 else if (PL_op->op_private & OPpDEREF)
1686 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1688 sv = (svp ? *svp : &PL_sv_undef);
1689 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1690 * Pushing the magical RHS on to the stack is useless, since
1691 * that magic is soon destined to be misled by the local(),
1692 * and thus the later pp_sassign() will fail to mg_get() the
1693 * old value. This should also cure problems with delayed
1694 * mg_get()s. GSAR 98-07-03 */
1695 if (!lval && SvGMAGICAL(sv))
1696 sv = sv_mortalcopy(sv);
1704 register PERL_CONTEXT *cx;
1710 if (PL_op->op_flags & OPf_SPECIAL) {
1711 cx = &cxstack[cxstack_ix];
1712 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1717 gimme = OP_GIMME(PL_op, -1);
1719 if (cxstack_ix >= 0)
1720 gimme = cxstack[cxstack_ix].blk_gimme;
1726 if (gimme == G_VOID)
1728 else if (gimme == G_SCALAR) {
1731 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1734 *MARK = sv_mortalcopy(TOPs);
1737 *MARK = &PL_sv_undef;
1741 else if (gimme == G_ARRAY) {
1742 /* in case LEAVE wipes old return values */
1743 for (mark = newsp + 1; mark <= SP; mark++) {
1744 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1745 *mark = sv_mortalcopy(*mark);
1746 TAINT_NOT; /* Each item is independent */
1750 PL_curpm = newpm; /* Don't pop $1 et al till now */
1760 register PERL_CONTEXT *cx;
1766 cx = &cxstack[cxstack_ix];
1767 if (CxTYPE(cx) != CXt_LOOP)
1768 DIE(aTHX_ "panic: pp_iter");
1770 itersvp = CxITERVAR(cx);
1771 av = cx->blk_loop.iterary;
1772 if (SvTYPE(av) != SVt_PVAV) {
1773 /* iterate ($min .. $max) */
1774 if (cx->blk_loop.iterlval) {
1775 /* string increment */
1776 register SV* cur = cx->blk_loop.iterlval;
1778 char *max = SvPV((SV*)av, maxlen);
1779 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1780 #ifndef USE_5005THREADS /* don't risk potential race */
1781 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1782 /* safe to reuse old SV */
1783 sv_setsv(*itersvp, cur);
1788 /* we need a fresh SV every time so that loop body sees a
1789 * completely new SV for closures/references to work as
1791 SvREFCNT_dec(*itersvp);
1792 *itersvp = newSVsv(cur);
1794 if (strEQ(SvPVX(cur), max))
1795 sv_setiv(cur, 0); /* terminate next time */
1802 /* integer increment */
1803 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1806 #ifndef USE_5005THREADS /* don't risk potential race */
1807 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1808 /* safe to reuse old SV */
1809 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1814 /* we need a fresh SV every time so that loop body sees a
1815 * completely new SV for closures/references to work as they
1817 SvREFCNT_dec(*itersvp);
1818 *itersvp = newSViv(cx->blk_loop.iterix++);
1824 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1827 SvREFCNT_dec(*itersvp);
1829 if (SvMAGICAL(av) || AvREIFY(av)) {
1830 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1837 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1843 if (av != PL_curstack && sv == &PL_sv_undef) {
1844 SV *lv = cx->blk_loop.iterlval;
1845 if (lv && SvREFCNT(lv) > 1) {
1850 SvREFCNT_dec(LvTARG(lv));
1852 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1853 sv_upgrade(lv, SVt_PVLV);
1855 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1857 LvTARG(lv) = SvREFCNT_inc(av);
1858 LvTARGOFF(lv) = cx->blk_loop.iterix;
1859 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1863 *itersvp = SvREFCNT_inc(sv);
1870 register PMOP *pm = cPMOP;
1886 register REGEXP *rx = PM_GETRE(pm);
1888 int force_on_match = 0;
1889 I32 oldsave = PL_savestack_ix;
1891 bool doutf8 = FALSE;
1893 /* known replacement string? */
1894 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1895 if (PL_op->op_flags & OPf_STACKED)
1902 if (SvFAKE(TARG) && SvREADONLY(TARG))
1903 sv_force_normal(TARG);
1904 if (SvREADONLY(TARG)
1905 || (SvTYPE(TARG) > SVt_PVLV
1906 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1907 DIE(aTHX_ PL_no_modify);
1910 s = SvPV(TARG, len);
1911 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1913 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1914 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1919 PL_reg_match_utf8 = DO_UTF8(TARG);
1923 DIE(aTHX_ "panic: pp_subst");
1926 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1927 maxiters = 2 * slen + 10; /* We can match twice at each
1928 position, once with zero-length,
1929 second time with non-zero. */
1931 if (!rx->prelen && PL_curpm) {
1935 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1936 ? REXEC_COPY_STR : 0;
1938 r_flags |= REXEC_SCREAM;
1939 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1940 SAVEINT(PL_multiline);
1941 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1944 if (rx->reganch & RE_USE_INTUIT) {
1946 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1950 /* How to do it in subst? */
1951 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1953 && ((rx->reganch & ROPT_NOSCAN)
1954 || !((rx->reganch & RE_INTUIT_TAIL)
1955 && (r_flags & REXEC_SCREAM))))
1960 /* only replace once? */
1961 once = !(rpm->op_pmflags & PMf_GLOBAL);
1963 /* known replacement string? */
1965 c = SvPV(dstr, clen);
1966 doutf8 = DO_UTF8(dstr);
1973 /* can do inplace substitution? */
1974 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1975 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1976 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1977 r_flags | REXEC_CHECKED))
1981 LEAVE_SCOPE(oldsave);
1984 if (force_on_match) {
1986 s = SvPV_force(TARG, len);
1991 SvSCREAM_off(TARG); /* disable possible screamer */
1993 rxtainted |= RX_MATCH_TAINTED(rx);
1994 m = orig + rx->startp[0];
1995 d = orig + rx->endp[0];
1997 if (m - s > strend - d) { /* faster to shorten from end */
1999 Copy(c, m, clen, char);
2004 Move(d, m, i, char);
2008 SvCUR_set(TARG, m - s);
2011 else if ((i = m - s)) { /* faster from front */
2019 Copy(c, m, clen, char);
2024 Copy(c, d, clen, char);
2029 TAINT_IF(rxtainted & 1);
2035 if (iters++ > maxiters)
2036 DIE(aTHX_ "Substitution loop");
2037 rxtainted |= RX_MATCH_TAINTED(rx);
2038 m = rx->startp[0] + orig;
2042 Move(s, d, i, char);
2046 Copy(c, d, clen, char);
2049 s = rx->endp[0] + orig;
2050 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2052 /* don't match same null twice */
2053 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2056 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2057 Move(s, d, i+1, char); /* include the NUL */
2059 TAINT_IF(rxtainted & 1);
2061 PUSHs(sv_2mortal(newSViv((I32)iters)));
2063 (void)SvPOK_only_UTF8(TARG);
2064 TAINT_IF(rxtainted);
2065 if (SvSMAGICAL(TARG)) {
2071 LEAVE_SCOPE(oldsave);
2075 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2076 r_flags | REXEC_CHECKED))
2078 if (force_on_match) {
2080 s = SvPV_force(TARG, len);
2083 rxtainted |= RX_MATCH_TAINTED(rx);
2084 dstr = NEWSV(25, len);
2085 sv_setpvn(dstr, m, s-m);
2090 register PERL_CONTEXT *cx;
2093 RETURNOP(cPMOP->op_pmreplroot);
2095 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2097 if (iters++ > maxiters)
2098 DIE(aTHX_ "Substitution loop");
2099 rxtainted |= RX_MATCH_TAINTED(rx);
2100 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2105 strend = s + (strend - m);
2107 m = rx->startp[0] + orig;
2108 sv_catpvn(dstr, s, m-s);
2109 s = rx->endp[0] + orig;
2111 sv_catpvn(dstr, c, clen);
2114 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2115 TARG, NULL, r_flags));
2116 sv_catpvn(dstr, s, strend - s);
2118 (void)SvOOK_off(TARG);
2119 Safefree(SvPVX(TARG));
2120 SvPVX(TARG) = SvPVX(dstr);
2121 SvCUR_set(TARG, SvCUR(dstr));
2122 SvLEN_set(TARG, SvLEN(dstr));
2123 doutf8 |= DO_UTF8(dstr);
2127 TAINT_IF(rxtainted & 1);
2129 PUSHs(sv_2mortal(newSViv((I32)iters)));
2131 (void)SvPOK_only(TARG);
2134 TAINT_IF(rxtainted);
2137 LEAVE_SCOPE(oldsave);
2146 LEAVE_SCOPE(oldsave);
2155 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2156 ++*PL_markstack_ptr;
2157 LEAVE; /* exit inner scope */
2160 if (PL_stack_base + *PL_markstack_ptr > SP) {
2162 I32 gimme = GIMME_V;
2164 LEAVE; /* exit outer scope */
2165 (void)POPMARK; /* pop src */
2166 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2167 (void)POPMARK; /* pop dst */
2168 SP = PL_stack_base + POPMARK; /* pop original mark */
2169 if (gimme == G_SCALAR) {
2173 else if (gimme == G_ARRAY)
2180 ENTER; /* enter inner scope */
2183 src = PL_stack_base[*PL_markstack_ptr];
2187 RETURNOP(cLOGOP->op_other);
2198 register PERL_CONTEXT *cx;
2204 if (gimme == G_SCALAR) {
2207 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2209 *MARK = SvREFCNT_inc(TOPs);
2214 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2216 *MARK = sv_mortalcopy(sv);
2221 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2225 *MARK = &PL_sv_undef;
2229 else if (gimme == G_ARRAY) {
2230 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2231 if (!SvTEMP(*MARK)) {
2232 *MARK = sv_mortalcopy(*MARK);
2233 TAINT_NOT; /* Each item is independent */
2239 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2240 PL_curpm = newpm; /* ... and pop $1 et al */
2244 return pop_return();
2247 /* This duplicates the above code because the above code must not
2248 * get any slower by more conditions */
2256 register PERL_CONTEXT *cx;
2263 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2264 /* We are an argument to a function or grep().
2265 * This kind of lvalueness was legal before lvalue
2266 * subroutines too, so be backward compatible:
2267 * cannot report errors. */
2269 /* Scalar context *is* possible, on the LHS of -> only,
2270 * as in f()->meth(). But this is not an lvalue. */
2271 if (gimme == G_SCALAR)
2273 if (gimme == G_ARRAY) {
2274 if (!CvLVALUE(cx->blk_sub.cv))
2275 goto temporise_array;
2276 EXTEND_MORTAL(SP - newsp);
2277 for (mark = newsp + 1; mark <= SP; mark++) {
2280 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2281 *mark = sv_mortalcopy(*mark);
2283 /* Can be a localized value subject to deletion. */
2284 PL_tmps_stack[++PL_tmps_ix] = *mark;
2285 (void)SvREFCNT_inc(*mark);
2290 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2291 /* Here we go for robustness, not for speed, so we change all
2292 * the refcounts so the caller gets a live guy. Cannot set
2293 * TEMP, so sv_2mortal is out of question. */
2294 if (!CvLVALUE(cx->blk_sub.cv)) {
2299 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2301 if (gimme == G_SCALAR) {
2305 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2310 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2311 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2313 else { /* Can be a localized value
2314 * subject to deletion. */
2315 PL_tmps_stack[++PL_tmps_ix] = *mark;
2316 (void)SvREFCNT_inc(*mark);
2319 else { /* Should not happen? */
2324 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2325 (MARK > SP ? "Empty array" : "Array"));
2329 else if (gimme == G_ARRAY) {
2330 EXTEND_MORTAL(SP - newsp);
2331 for (mark = newsp + 1; mark <= SP; mark++) {
2332 if (*mark != &PL_sv_undef
2333 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2334 /* Might be flattened array after $#array = */
2340 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2341 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2344 /* Can be a localized value subject to deletion. */
2345 PL_tmps_stack[++PL_tmps_ix] = *mark;
2346 (void)SvREFCNT_inc(*mark);
2352 if (gimme == G_SCALAR) {
2356 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2358 *MARK = SvREFCNT_inc(TOPs);
2363 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2365 *MARK = sv_mortalcopy(sv);
2370 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2374 *MARK = &PL_sv_undef;
2378 else if (gimme == G_ARRAY) {
2380 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2381 if (!SvTEMP(*MARK)) {
2382 *MARK = sv_mortalcopy(*MARK);
2383 TAINT_NOT; /* Each item is independent */
2390 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2391 PL_curpm = newpm; /* ... and pop $1 et al */
2395 return pop_return();
2400 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2402 SV *dbsv = GvSV(PL_DBsub);
2404 if (!PERLDB_SUB_NN) {
2408 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2409 || strEQ(GvNAME(gv), "END")
2410 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2411 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2412 && (gv = (GV*)*svp) ))) {
2413 /* Use GV from the stack as a fallback. */
2414 /* GV is potentially non-unique, or contain different CV. */
2415 SV *tmp = newRV((SV*)cv);
2416 sv_setsv(dbsv, tmp);
2420 gv_efullname3(dbsv, gv, Nullch);
2424 (void)SvUPGRADE(dbsv, SVt_PVIV);
2425 (void)SvIOK_on(dbsv);
2426 SAVEIV(SvIVX(dbsv));
2427 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2431 PL_curcopdb = PL_curcop;
2432 cv = GvCV(PL_DBsub);
2442 register PERL_CONTEXT *cx;
2444 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2447 DIE(aTHX_ "Not a CODE reference");
2448 switch (SvTYPE(sv)) {
2454 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2456 SP = PL_stack_base + POPMARK;
2459 if (SvGMAGICAL(sv)) {
2463 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2466 sym = SvPV(sv, n_a);
2468 DIE(aTHX_ PL_no_usym, "a subroutine");
2469 if (PL_op->op_private & HINT_STRICT_REFS)
2470 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2471 cv = get_cv(sym, TRUE);
2476 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2477 tryAMAGICunDEREF(to_cv);
2480 if (SvTYPE(cv) == SVt_PVCV)
2485 DIE(aTHX_ "Not a CODE reference");
2490 if (!(cv = GvCVu((GV*)sv)))
2491 cv = sv_2cv(sv, &stash, &gv, FALSE);
2504 if (!CvROOT(cv) && !CvXSUB(cv)) {
2508 /* anonymous or undef'd function leaves us no recourse */
2509 if (CvANON(cv) || !(gv = CvGV(cv)))
2510 DIE(aTHX_ "Undefined subroutine called");
2512 /* autoloaded stub? */
2513 if (cv != GvCV(gv)) {
2516 /* should call AUTOLOAD now? */
2519 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2526 sub_name = sv_newmortal();
2527 gv_efullname3(sub_name, gv, Nullch);
2528 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2532 DIE(aTHX_ "Not a CODE reference");
2537 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2538 cv = get_db_sub(&sv, cv);
2540 DIE(aTHX_ "No DBsub routine");
2543 #ifdef USE_5005THREADS
2545 * First we need to check if the sub or method requires locking.
2546 * If so, we gain a lock on the CV, the first argument or the
2547 * stash (for static methods), as appropriate. This has to be
2548 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2549 * reschedule by returning a new op.
2551 MUTEX_LOCK(CvMUTEXP(cv));
2552 if (CvFLAGS(cv) & CVf_LOCKED) {
2554 if (CvFLAGS(cv) & CVf_METHOD) {
2555 if (SP > PL_stack_base + TOPMARK)
2556 sv = *(PL_stack_base + TOPMARK + 1);
2558 AV *av = (AV*)PL_curpad[0];
2559 if (hasargs || !av || AvFILLp(av) < 0
2560 || !(sv = AvARRAY(av)[0]))
2562 MUTEX_UNLOCK(CvMUTEXP(cv));
2563 DIE(aTHX_ "no argument for locked method call");
2570 char *stashname = SvPV(sv, len);
2571 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2577 MUTEX_UNLOCK(CvMUTEXP(cv));
2578 mg = condpair_magic(sv);
2579 MUTEX_LOCK(MgMUTEXP(mg));
2580 if (MgOWNER(mg) == thr)
2581 MUTEX_UNLOCK(MgMUTEXP(mg));
2584 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2586 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2588 MUTEX_UNLOCK(MgMUTEXP(mg));
2589 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2591 MUTEX_LOCK(CvMUTEXP(cv));
2594 * Now we have permission to enter the sub, we must distinguish
2595 * four cases. (0) It's an XSUB (in which case we don't care
2596 * about ownership); (1) it's ours already (and we're recursing);
2597 * (2) it's free (but we may already be using a cached clone);
2598 * (3) another thread owns it. Case (1) is easy: we just use it.
2599 * Case (2) means we look for a clone--if we have one, use it
2600 * otherwise grab ownership of cv. Case (3) means we look for a
2601 * clone (for non-XSUBs) and have to create one if we don't
2603 * Why look for a clone in case (2) when we could just grab
2604 * ownership of cv straight away? Well, we could be recursing,
2605 * i.e. we originally tried to enter cv while another thread
2606 * owned it (hence we used a clone) but it has been freed up
2607 * and we're now recursing into it. It may or may not be "better"
2608 * to use the clone but at least CvDEPTH can be trusted.
2610 if (CvOWNER(cv) == thr || CvXSUB(cv))
2611 MUTEX_UNLOCK(CvMUTEXP(cv));
2613 /* Case (2) or (3) */
2617 * XXX Might it be better to release CvMUTEXP(cv) while we
2618 * do the hv_fetch? We might find someone has pinched it
2619 * when we look again, in which case we would be in case
2620 * (3) instead of (2) so we'd have to clone. Would the fact
2621 * that we released the mutex more quickly make up for this?
2623 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2625 /* We already have a clone to use */
2626 MUTEX_UNLOCK(CvMUTEXP(cv));
2628 DEBUG_S(PerlIO_printf(Perl_debug_log,
2629 "entersub: %p already has clone %p:%s\n",
2630 thr, cv, SvPEEK((SV*)cv)));
2633 if (CvDEPTH(cv) == 0)
2634 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2637 /* (2) => grab ownership of cv. (3) => make clone */
2641 MUTEX_UNLOCK(CvMUTEXP(cv));
2642 DEBUG_S(PerlIO_printf(Perl_debug_log,
2643 "entersub: %p grabbing %p:%s in stash %s\n",
2644 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2645 HvNAME(CvSTASH(cv)) : "(none)"));
2648 /* Make a new clone. */
2650 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2651 MUTEX_UNLOCK(CvMUTEXP(cv));
2652 DEBUG_S((PerlIO_printf(Perl_debug_log,
2653 "entersub: %p cloning %p:%s\n",
2654 thr, cv, SvPEEK((SV*)cv))));
2656 * We're creating a new clone so there's no race
2657 * between the original MUTEX_UNLOCK and the
2658 * SvREFCNT_inc since no one will be trying to undef
2659 * it out from underneath us. At least, I don't think
2662 clonecv = cv_clone(cv);
2663 SvREFCNT_dec(cv); /* finished with this */
2664 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2665 CvOWNER(clonecv) = thr;
2669 DEBUG_S(if (CvDEPTH(cv) != 0)
2670 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2672 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2675 #endif /* USE_5005THREADS */
2678 #ifdef PERL_XSUB_OLDSTYLE
2679 if (CvOLDSTYLE(cv)) {
2680 I32 (*fp3)(int,int,int);
2682 register I32 items = SP - MARK;
2683 /* We dont worry to copy from @_. */
2688 PL_stack_sp = mark + 1;
2689 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2690 items = (*fp3)(CvXSUBANY(cv).any_i32,
2691 MARK - PL_stack_base + 1,
2693 PL_stack_sp = PL_stack_base + items;
2696 #endif /* PERL_XSUB_OLDSTYLE */
2698 I32 markix = TOPMARK;
2703 /* Need to copy @_ to stack. Alternative may be to
2704 * switch stack to @_, and copy return values
2705 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2708 #ifdef USE_5005THREADS
2709 av = (AV*)PL_curpad[0];
2711 av = GvAV(PL_defgv);
2712 #endif /* USE_5005THREADS */
2713 items = AvFILLp(av) + 1; /* @_ is not tieable */
2716 /* Mark is at the end of the stack. */
2718 Copy(AvARRAY(av), SP + 1, items, SV*);
2723 /* We assume first XSUB in &DB::sub is the called one. */
2725 SAVEVPTR(PL_curcop);
2726 PL_curcop = PL_curcopdb;
2729 /* Do we need to open block here? XXXX */
2730 (void)(*CvXSUB(cv))(aTHX_ cv);
2732 /* Enforce some sanity in scalar context. */
2733 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2734 if (markix > PL_stack_sp - PL_stack_base)
2735 *(PL_stack_base + markix) = &PL_sv_undef;
2737 *(PL_stack_base + markix) = *PL_stack_sp;
2738 PL_stack_sp = PL_stack_base + markix;
2746 register I32 items = SP - MARK;
2747 AV* padlist = CvPADLIST(cv);
2748 SV** svp = AvARRAY(padlist);
2749 push_return(PL_op->op_next);
2750 PUSHBLOCK(cx, CXt_SUB, MARK);
2753 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2754 * that eval'' ops within this sub know the correct lexical space.
2755 * Owing the speed considerations, we choose to search for the cv
2756 * in doeval() instead.
2758 if (CvDEPTH(cv) < 2)
2759 (void)SvREFCNT_inc(cv);
2760 else { /* save temporaries on recursion? */
2761 PERL_STACK_OVERFLOW_CHECK();
2762 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2764 AV *newpad = newAV();
2765 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2766 I32 ix = AvFILLp((AV*)svp[1]);
2767 I32 names_fill = AvFILLp((AV*)svp[0]);
2768 svp = AvARRAY(svp[0]);
2769 for ( ;ix > 0; ix--) {
2770 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2771 char *name = SvPVX(svp[ix]);
2772 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2773 || *name == '&') /* anonymous code? */
2775 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2777 else { /* our own lexical */
2779 av_store(newpad, ix, sv = (SV*)newAV());
2780 else if (*name == '%')
2781 av_store(newpad, ix, sv = (SV*)newHV());
2783 av_store(newpad, ix, sv = NEWSV(0,0));
2787 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2788 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2791 av_store(newpad, ix, sv = NEWSV(0,0));
2795 av = newAV(); /* will be @_ */
2797 av_store(newpad, 0, (SV*)av);
2798 AvFLAGS(av) = AVf_REIFY;
2799 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2800 AvFILLp(padlist) = CvDEPTH(cv);
2801 svp = AvARRAY(padlist);
2804 #ifdef USE_5005THREADS
2806 AV* av = (AV*)PL_curpad[0];
2808 items = AvFILLp(av) + 1;
2810 /* Mark is at the end of the stack. */
2812 Copy(AvARRAY(av), SP + 1, items, SV*);
2817 #endif /* USE_5005THREADS */
2818 SAVEVPTR(PL_curpad);
2819 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2820 #ifndef USE_5005THREADS
2822 #endif /* USE_5005THREADS */
2828 DEBUG_S(PerlIO_printf(Perl_debug_log,
2829 "%p entersub preparing @_\n", thr));
2831 av = (AV*)PL_curpad[0];
2833 /* @_ is normally not REAL--this should only ever
2834 * happen when DB::sub() calls things that modify @_ */
2839 #ifndef USE_5005THREADS
2840 cx->blk_sub.savearray = GvAV(PL_defgv);
2841 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2842 #endif /* USE_5005THREADS */
2843 cx->blk_sub.oldcurpad = PL_curpad;
2844 cx->blk_sub.argarray = av;
2847 if (items > AvMAX(av) + 1) {
2849 if (AvARRAY(av) != ary) {
2850 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2851 SvPVX(av) = (char*)ary;
2853 if (items > AvMAX(av) + 1) {
2854 AvMAX(av) = items - 1;
2855 Renew(ary,items,SV*);
2857 SvPVX(av) = (char*)ary;
2860 Copy(MARK,AvARRAY(av),items,SV*);
2861 AvFILLp(av) = items - 1;
2869 /* warning must come *after* we fully set up the context
2870 * stuff so that __WARN__ handlers can safely dounwind()
2873 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2874 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2875 sub_crush_depth(cv);
2877 DEBUG_S(PerlIO_printf(Perl_debug_log,
2878 "%p entersub returning %p\n", thr, CvSTART(cv)));
2880 RETURNOP(CvSTART(cv));
2885 Perl_sub_crush_depth(pTHX_ CV *cv)
2888 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2890 SV* tmpstr = sv_newmortal();
2891 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2892 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
2902 IV elem = SvIV(elemsv);
2904 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2905 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2908 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2909 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2911 elem -= PL_curcop->cop_arybase;
2912 if (SvTYPE(av) != SVt_PVAV)
2914 svp = av_fetch(av, elem, lval && !defer);
2916 if (!svp || *svp == &PL_sv_undef) {
2919 DIE(aTHX_ PL_no_aelem, elem);
2920 lv = sv_newmortal();
2921 sv_upgrade(lv, SVt_PVLV);
2923 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2924 LvTARG(lv) = SvREFCNT_inc(av);
2925 LvTARGOFF(lv) = elem;
2930 if (PL_op->op_private & OPpLVAL_INTRO)
2931 save_aelem(av, elem, svp);
2932 else if (PL_op->op_private & OPpDEREF)
2933 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2935 sv = (svp ? *svp : &PL_sv_undef);
2936 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2937 sv = sv_mortalcopy(sv);
2943 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2949 Perl_croak(aTHX_ PL_no_modify);
2950 if (SvTYPE(sv) < SVt_RV)
2951 sv_upgrade(sv, SVt_RV);
2952 else if (SvTYPE(sv) >= SVt_PV) {
2953 (void)SvOOK_off(sv);
2954 Safefree(SvPVX(sv));
2955 SvLEN(sv) = SvCUR(sv) = 0;
2959 SvRV(sv) = NEWSV(355,0);
2962 SvRV(sv) = (SV*)newAV();
2965 SvRV(sv) = (SV*)newHV();
2980 if (SvTYPE(rsv) == SVt_PVCV) {
2986 SETs(method_common(sv, Null(U32*)));
2993 SV* sv = cSVOP->op_sv;
2994 U32 hash = SvUVX(sv);
2996 XPUSHs(method_common(sv, &hash));
3001 S_method_common(pTHX_ SV* meth, U32* hashp)
3012 name = SvPV(meth, namelen);
3013 sv = *(PL_stack_base + TOPMARK + 1);
3016 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3025 /* this isn't a reference */
3028 !(packname = SvPV(sv, packlen)) ||
3029 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3030 !(ob=(SV*)GvIO(iogv)))
3032 /* this isn't the name of a filehandle either */
3034 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3035 ? !isIDFIRST_utf8((U8*)packname)
3036 : !isIDFIRST(*packname)
3039 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3040 SvOK(sv) ? "without a package or object reference"
3041 : "on an undefined value");
3043 /* assume it's a package name */
3044 stash = gv_stashpvn(packname, packlen, FALSE);
3047 /* it _is_ a filehandle name -- replace with a reference */
3048 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3051 /* if we got here, ob should be a reference or a glob */
3052 if (!ob || !(SvOBJECT(ob)
3053 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3056 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3060 stash = SvSTASH(ob);
3063 /* NOTE: stash may be null, hope hv_fetch_ent and
3064 gv_fetchmethod can cope (it seems they can) */
3066 /* shortcut for simple names */
3068 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3070 gv = (GV*)HeVAL(he);
3071 if (isGV(gv) && GvCV(gv) &&
3072 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3073 return (SV*)GvCV(gv);
3077 gv = gv_fetchmethod(stash, name);
3080 /* This code tries to figure out just what went wrong with
3081 gv_fetchmethod. It therefore needs to duplicate a lot of
3082 the internals of that function. We can't move it inside
3083 Perl_gv_fetchmethod_autoload(), however, since that would
3084 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3091 for (p = name; *p; p++) {
3093 sep = p, leaf = p + 1;
3094 else if (*p == ':' && *(p + 1) == ':')
3095 sep = p, leaf = p + 2;
3097 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3098 /* the method name is unqualified or starts with SUPER:: */
3099 packname = sep ? CopSTASHPV(PL_curcop) :
3100 stash ? HvNAME(stash) : packname;
3101 packlen = strlen(packname);
3104 /* the method name is qualified */
3106 packlen = sep - name;
3109 /* we're relying on gv_fetchmethod not autovivifying the stash */
3110 if (gv_stashpvn(packname, packlen, FALSE)) {
3112 "Can't locate object method \"%s\" via package \"%.*s\"",
3113 leaf, (int)packlen, packname);
3117 "Can't locate object method \"%s\" via package \"%.*s\""
3118 " (perhaps you forgot to load \"%.*s\"?)",
3119 leaf, (int)packlen, packname, (int)packlen, packname);
3122 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3125 #ifdef USE_5005THREADS
3127 unset_cvowner(pTHX_ void *cvarg)
3129 register CV* cv = (CV *) cvarg;
3131 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3132 thr, cv, SvPEEK((SV*)cv))));
3133 MUTEX_LOCK(CvMUTEXP(cv));
3134 DEBUG_S(if (CvDEPTH(cv) != 0)
3135 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3137 assert(thr == CvOWNER(cv));
3139 MUTEX_UNLOCK(CvMUTEXP(cv));
3142 #endif /* USE_5005THREADS */