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 if (uv > (UV) IV_MAX) {
301 SETs(boolSV((UV)iv == uv));
309 SETs(boolSV(TOPn == value));
317 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
318 DIE(aTHX_ PL_no_modify);
319 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
320 SvIVX(TOPs) != IV_MAX)
323 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
325 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
338 RETURNOP(cLOGOP->op_other);
344 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
345 useleft = USE_LEFT(TOPm1s);
346 #ifdef PERL_PRESERVE_IVUV
347 /* We must see if we can perform the addition with integers if possible,
348 as the integer code detects overflow while the NV code doesn't.
349 If either argument hasn't had a numeric conversion yet attempt to get
350 the IV. It's important to do this now, rather than just assuming that
351 it's not IOK as a PV of "9223372036854775806" may not take well to NV
352 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
353 integer in case the second argument is IV=9223372036854775806
354 We can (now) rely on sv_2iv to do the right thing, only setting the
355 public IOK flag if the value in the NV (or PV) slot is truly integer.
357 A side effect is that this also aggressively prefers integer maths over
358 fp maths for integer values.
360 How to detect overflow?
362 C 99 section 6.2.6.1 says
364 The range of nonnegative values of a signed integer type is a subrange
365 of the corresponding unsigned integer type, and the representation of
366 the same value in each type is the same. A computation involving
367 unsigned operands can never overflow, because a result that cannot be
368 represented by the resulting unsigned integer type is reduced modulo
369 the number that is one greater than the largest value that can be
370 represented by the resulting type.
374 which I read as "unsigned ints wrap."
376 signed integer overflow seems to be classed as "exception condition"
378 If an exceptional condition occurs during the evaluation of an
379 expression (that is, if the result is not mathematically defined or not
380 in the range of representable values for its type), the behavior is
383 (6.5, the 5th paragraph)
385 I had assumed that on 2s complement machines signed arithmetic would
386 wrap, hence coded pp_add and pp_subtract on the assumption that
387 everything perl builds on would be happy. After much wailing and
388 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
389 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
390 unsigned code below is actually shorter than the old code. :-)
395 /* Unless the left argument is integer in range we are going to have to
396 use NV maths. Hence only attempt to coerce the right argument if
397 we know the left is integer. */
405 /* left operand is undef, treat as zero. + 0 is identity,
406 Could SETi or SETu right now, but space optimise by not adding
407 lots of code to speed up what is probably a rarish case. */
409 /* Left operand is defined, so is it IV? */
412 if ((auvok = SvUOK(TOPm1s)))
415 register IV aiv = SvIVX(TOPm1s);
418 auvok = 1; /* Now acting as a sign flag. */
419 } else { /* 2s complement assumption for IV_MIN */
427 bool result_good = 0;
430 bool buvok = SvUOK(TOPs);
435 register IV biv = SvIVX(TOPs);
442 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
443 else "IV" now, independant of how it came in.
444 if a, b represents positive, A, B negative, a maps to -A etc
449 all UV maths. negate result if A negative.
450 add if signs same, subtract if signs differ. */
456 /* Must get smaller */
462 /* result really should be -(auv-buv). as its negation
463 of true value, need to swap our result flag */
480 if (result <= (UV)IV_MIN)
483 /* result valid, but out of range for IV. */
488 } /* Overflow, drop through to NVs. */
495 /* left operand is undef, treat as zero. + 0.0 is identity. */
499 SETn( value + TOPn );
507 AV *av = GvAV(cGVOP_gv);
508 U32 lval = PL_op->op_flags & OPf_MOD;
509 SV** svp = av_fetch(av, PL_op->op_private, lval);
510 SV *sv = (svp ? *svp : &PL_sv_undef);
512 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
513 sv = sv_mortalcopy(sv);
522 do_join(TARG, *MARK, MARK, SP);
533 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
534 * will be enough to hold an OP*.
536 SV* sv = sv_newmortal();
537 sv_upgrade(sv, SVt_PVLV);
539 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
547 /* Oversized hot code. */
551 dSP; dMARK; dORIGMARK;
557 if (PL_op->op_flags & OPf_STACKED)
562 if (gv && (io = GvIO(gv))
563 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
566 if (MARK == ORIGMARK) {
567 /* If using default handle then we need to make space to
568 * pass object as 1st arg, so move other args up ...
572 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
576 *MARK = SvTIED_obj((SV*)io, mg);
579 call_method("PRINT", G_SCALAR);
587 if (!(io = GvIO(gv))) {
588 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
589 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
591 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
592 report_evil_fh(gv, io, PL_op->op_type);
593 SETERRNO(EBADF,RMS$_IFI);
596 else if (!(fp = IoOFP(io))) {
597 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
599 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
600 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
601 report_evil_fh(gv, io, PL_op->op_type);
603 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
608 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
610 if (!do_print(*MARK, fp))
614 if (!do_print(PL_ofs_sv, fp)) { /* $, */
623 if (!do_print(*MARK, fp))
631 if (PL_ors_sv && SvOK(PL_ors_sv))
632 if (!do_print(PL_ors_sv, fp)) /* $\ */
635 if (IoFLAGS(io) & IOf_FLUSH)
636 if (PerlIO_flush(fp) == EOF)
657 tryAMAGICunDEREF(to_av);
660 if (SvTYPE(av) != SVt_PVAV)
661 DIE(aTHX_ "Not an ARRAY reference");
662 if (PL_op->op_flags & OPf_REF) {
667 if (GIMME == G_SCALAR)
668 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
674 if (SvTYPE(sv) == SVt_PVAV) {
676 if (PL_op->op_flags & OPf_REF) {
681 if (GIMME == G_SCALAR)
682 Perl_croak(aTHX_ "Can't return array to lvalue"
691 if (SvTYPE(sv) != SVt_PVGV) {
695 if (SvGMAGICAL(sv)) {
701 if (PL_op->op_flags & OPf_REF ||
702 PL_op->op_private & HINT_STRICT_REFS)
703 DIE(aTHX_ PL_no_usym, "an ARRAY");
704 if (ckWARN(WARN_UNINITIALIZED))
706 if (GIMME == G_ARRAY) {
713 if ((PL_op->op_flags & OPf_SPECIAL) &&
714 !(PL_op->op_flags & OPf_MOD))
716 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
718 && (!is_gv_magical(sym,len,0)
719 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
725 if (PL_op->op_private & HINT_STRICT_REFS)
726 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
727 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
734 if (PL_op->op_private & OPpLVAL_INTRO)
736 if (PL_op->op_flags & OPf_REF) {
741 if (GIMME == G_SCALAR)
742 Perl_croak(aTHX_ "Can't return array to lvalue"
750 if (GIMME == G_ARRAY) {
751 I32 maxarg = AvFILL(av) + 1;
752 (void)POPs; /* XXXX May be optimized away? */
754 if (SvRMAGICAL(av)) {
756 for (i=0; i < maxarg; i++) {
757 SV **svp = av_fetch(av, i, FALSE);
758 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
762 Copy(AvARRAY(av), SP+1, maxarg, SV*);
768 I32 maxarg = AvFILL(av) + 1;
781 tryAMAGICunDEREF(to_hv);
784 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
785 DIE(aTHX_ "Not a HASH reference");
786 if (PL_op->op_flags & OPf_REF) {
791 if (GIMME == G_SCALAR)
792 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
798 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
800 if (PL_op->op_flags & OPf_REF) {
805 if (GIMME == G_SCALAR)
806 Perl_croak(aTHX_ "Can't return hash to lvalue"
815 if (SvTYPE(sv) != SVt_PVGV) {
819 if (SvGMAGICAL(sv)) {
825 if (PL_op->op_flags & OPf_REF ||
826 PL_op->op_private & HINT_STRICT_REFS)
827 DIE(aTHX_ PL_no_usym, "a HASH");
828 if (ckWARN(WARN_UNINITIALIZED))
830 if (GIMME == G_ARRAY) {
837 if ((PL_op->op_flags & OPf_SPECIAL) &&
838 !(PL_op->op_flags & OPf_MOD))
840 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
842 && (!is_gv_magical(sym,len,0)
843 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
849 if (PL_op->op_private & HINT_STRICT_REFS)
850 DIE(aTHX_ PL_no_symref, sym, "a HASH");
851 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
858 if (PL_op->op_private & OPpLVAL_INTRO)
860 if (PL_op->op_flags & OPf_REF) {
865 if (GIMME == G_SCALAR)
866 Perl_croak(aTHX_ "Can't return hash to lvalue"
874 if (GIMME == G_ARRAY) { /* array wanted */
875 *PL_stack_sp = (SV*)hv;
880 if (SvTYPE(hv) == SVt_PVAV)
881 hv = avhv_keys((AV*)hv);
883 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
884 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
894 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
900 leftop = ((BINOP*)PL_op)->op_last;
902 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
903 leftop = ((LISTOP*)leftop)->op_first;
905 /* Skip PUSHMARK and each element already assigned to. */
906 for (i = lelem - firstlelem; i > 0; i--) {
907 leftop = leftop->op_sibling;
910 if (leftop->op_type != OP_RV2HV)
915 av_fill(ary, 0); /* clear all but the fields hash */
916 if (lastrelem >= relem) {
917 while (relem < lastrelem) { /* gobble up all the rest */
921 /* Avoid a memory leak when avhv_store_ent dies. */
922 tmpstr = sv_newmortal();
923 sv_setsv(tmpstr,relem[1]); /* value */
925 if (avhv_store_ent(ary,relem[0],tmpstr,0))
926 (void)SvREFCNT_inc(tmpstr);
927 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
933 if (relem == lastrelem)
939 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
943 if (ckWARN(WARN_MISC)) {
944 if (relem == firstrelem &&
946 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
947 SvTYPE(SvRV(*relem)) == SVt_PVHV))
949 Perl_warner(aTHX_ WARN_MISC,
950 "Reference found where even-sized list expected");
953 Perl_warner(aTHX_ WARN_MISC,
954 "Odd number of elements in hash assignment");
956 if (SvTYPE(hash) == SVt_PVAV) {
958 tmpstr = sv_newmortal();
959 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
960 (void)SvREFCNT_inc(tmpstr);
961 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
966 tmpstr = NEWSV(29,0);
967 didstore = hv_store_ent(hash,*relem,tmpstr,0);
968 if (SvMAGICAL(hash)) {
969 if (SvSMAGICAL(tmpstr))
982 SV **lastlelem = PL_stack_sp;
983 SV **lastrelem = PL_stack_base + POPMARK;
984 SV **firstrelem = PL_stack_base + POPMARK + 1;
985 SV **firstlelem = lastrelem + 1;
998 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1000 /* If there's a common identifier on both sides we have to take
1001 * special care that assigning the identifier on the left doesn't
1002 * clobber a value on the right that's used later in the list.
1004 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1005 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1006 for (relem = firstrelem; relem <= lastrelem; relem++) {
1008 if ((sv = *relem)) {
1009 TAINT_NOT; /* Each item is independent */
1010 *relem = sv_mortalcopy(sv);
1020 while (lelem <= lastlelem) {
1021 TAINT_NOT; /* Each item stands on its own, taintwise. */
1023 switch (SvTYPE(sv)) {
1026 magic = SvMAGICAL(ary) != 0;
1027 if (PL_op->op_private & OPpASSIGN_HASH) {
1028 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1034 do_oddball((HV*)ary, relem, firstrelem);
1036 relem = lastrelem + 1;
1041 av_extend(ary, lastrelem - relem);
1043 while (relem <= lastrelem) { /* gobble up all the rest */
1047 sv_setsv(sv,*relem);
1049 didstore = av_store(ary,i++,sv);
1059 case SVt_PVHV: { /* normal hash */
1063 magic = SvMAGICAL(hash) != 0;
1066 while (relem < lastrelem) { /* gobble up all the rest */
1071 sv = &PL_sv_no, relem++;
1072 tmpstr = NEWSV(29,0);
1074 sv_setsv(tmpstr,*relem); /* value */
1075 *(relem++) = tmpstr;
1076 didstore = hv_store_ent(hash,sv,tmpstr,0);
1078 if (SvSMAGICAL(tmpstr))
1085 if (relem == lastrelem) {
1086 do_oddball(hash, relem, firstrelem);
1092 if (SvIMMORTAL(sv)) {
1093 if (relem <= lastrelem)
1097 if (relem <= lastrelem) {
1098 sv_setsv(sv, *relem);
1102 sv_setsv(sv, &PL_sv_undef);
1107 if (PL_delaymagic & ~DM_DELAY) {
1108 if (PL_delaymagic & DM_UID) {
1109 #ifdef HAS_SETRESUID
1110 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1112 # ifdef HAS_SETREUID
1113 (void)setreuid(PL_uid,PL_euid);
1116 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1117 (void)setruid(PL_uid);
1118 PL_delaymagic &= ~DM_RUID;
1120 # endif /* HAS_SETRUID */
1122 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1123 (void)seteuid(PL_uid);
1124 PL_delaymagic &= ~DM_EUID;
1126 # endif /* HAS_SETEUID */
1127 if (PL_delaymagic & DM_UID) {
1128 if (PL_uid != PL_euid)
1129 DIE(aTHX_ "No setreuid available");
1130 (void)PerlProc_setuid(PL_uid);
1132 # endif /* HAS_SETREUID */
1133 #endif /* HAS_SETRESUID */
1134 PL_uid = PerlProc_getuid();
1135 PL_euid = PerlProc_geteuid();
1137 if (PL_delaymagic & DM_GID) {
1138 #ifdef HAS_SETRESGID
1139 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1141 # ifdef HAS_SETREGID
1142 (void)setregid(PL_gid,PL_egid);
1145 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1146 (void)setrgid(PL_gid);
1147 PL_delaymagic &= ~DM_RGID;
1149 # endif /* HAS_SETRGID */
1151 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1152 (void)setegid(PL_gid);
1153 PL_delaymagic &= ~DM_EGID;
1155 # endif /* HAS_SETEGID */
1156 if (PL_delaymagic & DM_GID) {
1157 if (PL_gid != PL_egid)
1158 DIE(aTHX_ "No setregid available");
1159 (void)PerlProc_setgid(PL_gid);
1161 # endif /* HAS_SETREGID */
1162 #endif /* HAS_SETRESGID */
1163 PL_gid = PerlProc_getgid();
1164 PL_egid = PerlProc_getegid();
1166 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1171 if (gimme == G_VOID)
1172 SP = firstrelem - 1;
1173 else if (gimme == G_SCALAR) {
1176 SETi(lastrelem - firstrelem + 1);
1182 SP = firstrelem + (lastlelem - firstlelem);
1183 lelem = firstlelem + (relem - firstrelem);
1185 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1193 register PMOP *pm = cPMOP;
1194 SV *rv = sv_newmortal();
1195 SV *sv = newSVrv(rv, "Regexp");
1196 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1203 register PMOP *pm = cPMOP;
1208 I32 r_flags = REXEC_CHECKED;
1209 char *truebase; /* Start of string */
1210 register REGEXP *rx = PM_GETRE(pm);
1215 I32 oldsave = PL_savestack_ix;
1216 I32 update_minmatch = 1;
1217 I32 had_zerolen = 0;
1219 if (PL_op->op_flags & OPf_STACKED)
1226 PUTBACK; /* EVAL blocks need stack_sp. */
1227 s = SvPV(TARG, len);
1230 DIE(aTHX_ "panic: pp_match");
1231 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1232 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1235 PL_reg_match_utf8 = DO_UTF8(TARG);
1237 if (pm->op_pmdynflags & PMdf_USED) {
1239 if (gimme == G_ARRAY)
1244 if (!rx->prelen && PL_curpm) {
1248 if (rx->minlen > len) goto failure;
1252 /* XXXX What part of this is needed with true \G-support? */
1253 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1255 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1256 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1257 if (mg && mg->mg_len >= 0) {
1258 if (!(rx->reganch & ROPT_GPOS_SEEN))
1259 rx->endp[0] = rx->startp[0] = mg->mg_len;
1260 else if (rx->reganch & ROPT_ANCH_GPOS) {
1261 r_flags |= REXEC_IGNOREPOS;
1262 rx->endp[0] = rx->startp[0] = mg->mg_len;
1264 minmatch = (mg->mg_flags & MGf_MINMATCH);
1265 update_minmatch = 0;
1269 if ((!global && rx->nparens)
1270 || SvTEMP(TARG) || PL_sawampersand)
1271 r_flags |= REXEC_COPY_STR;
1273 r_flags |= REXEC_SCREAM;
1275 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1276 SAVEINT(PL_multiline);
1277 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1281 if (global && rx->startp[0] != -1) {
1282 t = s = rx->endp[0] + truebase;
1283 if ((s + rx->minlen) > strend)
1285 if (update_minmatch++)
1286 minmatch = had_zerolen;
1288 if (rx->reganch & RE_USE_INTUIT &&
1289 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1290 PL_bostr = truebase;
1291 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1295 if ( (rx->reganch & ROPT_CHECK_ALL)
1297 && ((rx->reganch & ROPT_NOSCAN)
1298 || !((rx->reganch & RE_INTUIT_TAIL)
1299 && (r_flags & REXEC_SCREAM)))
1300 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1303 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1306 if (pm->op_pmflags & PMf_ONCE)
1307 pm->op_pmdynflags |= PMdf_USED;
1316 RX_MATCH_TAINTED_on(rx);
1317 TAINT_IF(RX_MATCH_TAINTED(rx));
1318 if (gimme == G_ARRAY) {
1319 I32 nparens, i, len;
1321 nparens = rx->nparens;
1322 if (global && !nparens)
1326 SPAGAIN; /* EVAL blocks could move the stack. */
1327 EXTEND(SP, nparens + i);
1328 EXTEND_MORTAL(nparens + i);
1329 for (i = !i; i <= nparens; i++) {
1330 PUSHs(sv_newmortal());
1332 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1333 len = rx->endp[i] - rx->startp[i];
1334 s = rx->startp[i] + truebase;
1335 sv_setpvn(*SP, s, len);
1336 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1341 if (pm->op_pmflags & PMf_CONTINUE) {
1343 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1344 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1346 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1347 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1349 if (rx->startp[0] != -1) {
1350 mg->mg_len = rx->endp[0];
1351 if (rx->startp[0] == rx->endp[0])
1352 mg->mg_flags |= MGf_MINMATCH;
1354 mg->mg_flags &= ~MGf_MINMATCH;
1357 had_zerolen = (rx->startp[0] != -1
1358 && rx->startp[0] == rx->endp[0]);
1359 PUTBACK; /* EVAL blocks may use stack */
1360 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1365 LEAVE_SCOPE(oldsave);
1371 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1372 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1374 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1375 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1377 if (rx->startp[0] != -1) {
1378 mg->mg_len = rx->endp[0];
1379 if (rx->startp[0] == rx->endp[0])
1380 mg->mg_flags |= MGf_MINMATCH;
1382 mg->mg_flags &= ~MGf_MINMATCH;
1385 LEAVE_SCOPE(oldsave);
1389 yup: /* Confirmed by INTUIT */
1391 RX_MATCH_TAINTED_on(rx);
1392 TAINT_IF(RX_MATCH_TAINTED(rx));
1394 if (pm->op_pmflags & PMf_ONCE)
1395 pm->op_pmdynflags |= PMdf_USED;
1396 if (RX_MATCH_COPIED(rx))
1397 Safefree(rx->subbeg);
1398 RX_MATCH_COPIED_off(rx);
1399 rx->subbeg = Nullch;
1401 rx->subbeg = truebase;
1402 rx->startp[0] = s - truebase;
1403 if (PL_reg_match_utf8) {
1404 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1405 rx->endp[0] = t - truebase;
1408 rx->endp[0] = s - truebase + rx->minlen;
1410 rx->sublen = strend - truebase;
1413 if (PL_sawampersand) {
1416 rx->subbeg = savepvn(t, strend - t);
1417 rx->sublen = strend - t;
1418 RX_MATCH_COPIED_on(rx);
1419 off = rx->startp[0] = s - t;
1420 rx->endp[0] = off + rx->minlen;
1422 else { /* startp/endp are used by @- @+. */
1423 rx->startp[0] = s - truebase;
1424 rx->endp[0] = s - truebase + rx->minlen;
1426 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1427 LEAVE_SCOPE(oldsave);
1432 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1433 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1434 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1439 LEAVE_SCOPE(oldsave);
1440 if (gimme == G_ARRAY)
1446 Perl_do_readline(pTHX)
1448 dSP; dTARGETSTACKED;
1453 register IO *io = GvIO(PL_last_in_gv);
1454 register I32 type = PL_op->op_type;
1455 I32 gimme = GIMME_V;
1458 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1460 XPUSHs(SvTIED_obj((SV*)io, mg));
1463 call_method("READLINE", gimme);
1466 if (gimme == G_SCALAR)
1467 SvSetMagicSV_nosteal(TARG, TOPs);
1474 if (IoFLAGS(io) & IOf_ARGV) {
1475 if (IoFLAGS(io) & IOf_START) {
1477 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1478 IoFLAGS(io) &= ~IOf_START;
1479 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1480 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1481 SvSETMAGIC(GvSV(PL_last_in_gv));
1486 fp = nextargv(PL_last_in_gv);
1487 if (!fp) { /* Note: fp != IoIFP(io) */
1488 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1491 else if (type == OP_GLOB)
1492 fp = Perl_start_glob(aTHX_ POPs, io);
1494 else if (type == OP_GLOB)
1496 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1497 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1501 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1502 && (!io || !(IoFLAGS(io) & IOf_START))) {
1503 if (type == OP_GLOB)
1504 Perl_warner(aTHX_ WARN_GLOB,
1505 "glob failed (can't start child: %s)",
1508 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1510 if (gimme == G_SCALAR) {
1511 (void)SvOK_off(TARG);
1517 if (gimme == G_SCALAR) {
1521 (void)SvUPGRADE(sv, SVt_PV);
1522 tmplen = SvLEN(sv); /* remember if already alloced */
1524 Sv_Grow(sv, 80); /* try short-buffering it */
1525 if (type == OP_RCATLINE)
1531 sv = sv_2mortal(NEWSV(57, 80));
1535 /* This should not be marked tainted if the fp is marked clean */
1536 #define MAYBE_TAINT_LINE(io, sv) \
1537 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1542 /* delay EOF state for a snarfed empty file */
1543 #define SNARF_EOF(gimme,rs,io,sv) \
1544 (gimme != G_SCALAR || SvCUR(sv) \
1545 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1549 if (!sv_gets(sv, fp, offset)
1550 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1552 PerlIO_clearerr(fp);
1553 if (IoFLAGS(io) & IOf_ARGV) {
1554 fp = nextargv(PL_last_in_gv);
1557 (void)do_close(PL_last_in_gv, FALSE);
1559 else if (type == OP_GLOB) {
1560 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1561 Perl_warner(aTHX_ WARN_GLOB,
1562 "glob failed (child exited with status %d%s)",
1563 (int)(STATUS_CURRENT >> 8),
1564 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1567 if (gimme == G_SCALAR) {
1568 (void)SvOK_off(TARG);
1572 MAYBE_TAINT_LINE(io, sv);
1575 MAYBE_TAINT_LINE(io, sv);
1577 IoFLAGS(io) |= IOf_NOLINE;
1581 if (type == OP_GLOB) {
1584 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1585 tmps = SvEND(sv) - 1;
1586 if (*tmps == *SvPVX(PL_rs)) {
1591 for (tmps = SvPVX(sv); *tmps; tmps++)
1592 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1593 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1595 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1596 (void)POPs; /* Unmatched wildcard? Chuck it... */
1600 if (gimme == G_ARRAY) {
1601 if (SvLEN(sv) - SvCUR(sv) > 20) {
1602 SvLEN_set(sv, SvCUR(sv)+1);
1603 Renew(SvPVX(sv), SvLEN(sv), char);
1605 sv = sv_2mortal(NEWSV(58, 80));
1608 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1609 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1613 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1614 Renew(SvPVX(sv), SvLEN(sv), char);
1623 register PERL_CONTEXT *cx;
1624 I32 gimme = OP_GIMME(PL_op, -1);
1627 if (cxstack_ix >= 0)
1628 gimme = cxstack[cxstack_ix].blk_gimme;
1636 PUSHBLOCK(cx, CXt_BLOCK, SP);
1648 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1649 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1651 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1654 if (SvTYPE(hv) == SVt_PVHV) {
1655 if (PL_op->op_private & OPpLVAL_INTRO)
1656 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1657 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1658 svp = he ? &HeVAL(he) : 0;
1660 else if (SvTYPE(hv) == SVt_PVAV) {
1661 if (PL_op->op_private & OPpLVAL_INTRO)
1662 DIE(aTHX_ "Can't localize pseudo-hash element");
1663 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1669 if (!svp || *svp == &PL_sv_undef) {
1674 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1676 lv = sv_newmortal();
1677 sv_upgrade(lv, SVt_PVLV);
1679 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1680 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1681 LvTARG(lv) = SvREFCNT_inc(hv);
1686 if (PL_op->op_private & OPpLVAL_INTRO) {
1687 if (HvNAME(hv) && isGV(*svp))
1688 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1692 char *key = SvPV(keysv, keylen);
1693 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1695 save_helem(hv, keysv, svp);
1698 else if (PL_op->op_private & OPpDEREF)
1699 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1701 sv = (svp ? *svp : &PL_sv_undef);
1702 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1703 * Pushing the magical RHS on to the stack is useless, since
1704 * that magic is soon destined to be misled by the local(),
1705 * and thus the later pp_sassign() will fail to mg_get() the
1706 * old value. This should also cure problems with delayed
1707 * mg_get()s. GSAR 98-07-03 */
1708 if (!lval && SvGMAGICAL(sv))
1709 sv = sv_mortalcopy(sv);
1717 register PERL_CONTEXT *cx;
1723 if (PL_op->op_flags & OPf_SPECIAL) {
1724 cx = &cxstack[cxstack_ix];
1725 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1730 gimme = OP_GIMME(PL_op, -1);
1732 if (cxstack_ix >= 0)
1733 gimme = cxstack[cxstack_ix].blk_gimme;
1739 if (gimme == G_VOID)
1741 else if (gimme == G_SCALAR) {
1744 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1747 *MARK = sv_mortalcopy(TOPs);
1750 *MARK = &PL_sv_undef;
1754 else if (gimme == G_ARRAY) {
1755 /* in case LEAVE wipes old return values */
1756 for (mark = newsp + 1; mark <= SP; mark++) {
1757 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1758 *mark = sv_mortalcopy(*mark);
1759 TAINT_NOT; /* Each item is independent */
1763 PL_curpm = newpm; /* Don't pop $1 et al till now */
1773 register PERL_CONTEXT *cx;
1779 cx = &cxstack[cxstack_ix];
1780 if (CxTYPE(cx) != CXt_LOOP)
1781 DIE(aTHX_ "panic: pp_iter");
1783 itersvp = CxITERVAR(cx);
1784 av = cx->blk_loop.iterary;
1785 if (SvTYPE(av) != SVt_PVAV) {
1786 /* iterate ($min .. $max) */
1787 if (cx->blk_loop.iterlval) {
1788 /* string increment */
1789 register SV* cur = cx->blk_loop.iterlval;
1791 char *max = SvPV((SV*)av, maxlen);
1792 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1793 #ifndef USE_5005THREADS /* don't risk potential race */
1794 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1795 /* safe to reuse old SV */
1796 sv_setsv(*itersvp, cur);
1801 /* we need a fresh SV every time so that loop body sees a
1802 * completely new SV for closures/references to work as
1804 SvREFCNT_dec(*itersvp);
1805 *itersvp = newSVsv(cur);
1807 if (strEQ(SvPVX(cur), max))
1808 sv_setiv(cur, 0); /* terminate next time */
1815 /* integer increment */
1816 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1819 #ifndef USE_5005THREADS /* don't risk potential race */
1820 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1821 /* safe to reuse old SV */
1822 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1827 /* we need a fresh SV every time so that loop body sees a
1828 * completely new SV for closures/references to work as they
1830 SvREFCNT_dec(*itersvp);
1831 *itersvp = newSViv(cx->blk_loop.iterix++);
1837 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1840 SvREFCNT_dec(*itersvp);
1842 if (SvMAGICAL(av) || AvREIFY(av)) {
1843 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1850 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1856 if (av != PL_curstack && sv == &PL_sv_undef) {
1857 SV *lv = cx->blk_loop.iterlval;
1858 if (lv && SvREFCNT(lv) > 1) {
1863 SvREFCNT_dec(LvTARG(lv));
1865 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1866 sv_upgrade(lv, SVt_PVLV);
1868 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1870 LvTARG(lv) = SvREFCNT_inc(av);
1871 LvTARGOFF(lv) = cx->blk_loop.iterix;
1872 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1876 *itersvp = SvREFCNT_inc(sv);
1883 register PMOP *pm = cPMOP;
1899 register REGEXP *rx = PM_GETRE(pm);
1901 int force_on_match = 0;
1902 I32 oldsave = PL_savestack_ix;
1905 /* known replacement string? */
1906 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1907 if (PL_op->op_flags & OPf_STACKED)
1914 if (SvFAKE(TARG) && SvREADONLY(TARG))
1915 sv_force_normal(TARG);
1916 if (SvREADONLY(TARG)
1917 || (SvTYPE(TARG) > SVt_PVLV
1918 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1919 DIE(aTHX_ PL_no_modify);
1922 s = SvPV(TARG, len);
1923 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1925 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1926 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1931 PL_reg_match_utf8 = DO_UTF8(TARG);
1935 DIE(aTHX_ "panic: pp_subst");
1938 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1939 maxiters = 2 * slen + 10; /* We can match twice at each
1940 position, once with zero-length,
1941 second time with non-zero. */
1943 if (!rx->prelen && PL_curpm) {
1947 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1948 ? REXEC_COPY_STR : 0;
1950 r_flags |= REXEC_SCREAM;
1951 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1952 SAVEINT(PL_multiline);
1953 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1956 if (rx->reganch & RE_USE_INTUIT) {
1958 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1962 /* How to do it in subst? */
1963 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1965 && ((rx->reganch & ROPT_NOSCAN)
1966 || !((rx->reganch & RE_INTUIT_TAIL)
1967 && (r_flags & REXEC_SCREAM))))
1972 /* only replace once? */
1973 once = !(rpm->op_pmflags & PMf_GLOBAL);
1975 /* known replacement string? */
1976 c = dstr ? SvPV(dstr, clen) : Nullch;
1978 /* can do inplace substitution? */
1979 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1980 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1981 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1982 r_flags | REXEC_CHECKED))
1986 LEAVE_SCOPE(oldsave);
1989 if (force_on_match) {
1991 s = SvPV_force(TARG, len);
1996 SvSCREAM_off(TARG); /* disable possible screamer */
1998 rxtainted |= RX_MATCH_TAINTED(rx);
1999 m = orig + rx->startp[0];
2000 d = orig + rx->endp[0];
2002 if (m - s > strend - d) { /* faster to shorten from end */
2004 Copy(c, m, clen, char);
2009 Move(d, m, i, char);
2013 SvCUR_set(TARG, m - s);
2016 else if ((i = m - s)) { /* faster from front */
2024 Copy(c, m, clen, char);
2029 Copy(c, d, clen, char);
2034 TAINT_IF(rxtainted & 1);
2040 if (iters++ > maxiters)
2041 DIE(aTHX_ "Substitution loop");
2042 rxtainted |= RX_MATCH_TAINTED(rx);
2043 m = rx->startp[0] + orig;
2047 Move(s, d, i, char);
2051 Copy(c, d, clen, char);
2054 s = rx->endp[0] + orig;
2055 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2057 /* don't match same null twice */
2058 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2061 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2062 Move(s, d, i+1, char); /* include the NUL */
2064 TAINT_IF(rxtainted & 1);
2066 PUSHs(sv_2mortal(newSViv((I32)iters)));
2068 (void)SvPOK_only_UTF8(TARG);
2069 TAINT_IF(rxtainted);
2070 if (SvSMAGICAL(TARG)) {
2076 LEAVE_SCOPE(oldsave);
2080 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2081 r_flags | REXEC_CHECKED))
2085 if (force_on_match) {
2087 s = SvPV_force(TARG, len);
2090 rxtainted |= RX_MATCH_TAINTED(rx);
2091 dstr = NEWSV(25, len);
2092 sv_setpvn(dstr, m, s-m);
2097 register PERL_CONTEXT *cx;
2100 RETURNOP(cPMOP->op_pmreplroot);
2102 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2104 if (iters++ > maxiters)
2105 DIE(aTHX_ "Substitution loop");
2106 rxtainted |= RX_MATCH_TAINTED(rx);
2107 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2112 strend = s + (strend - m);
2114 m = rx->startp[0] + orig;
2115 sv_catpvn(dstr, s, m-s);
2116 s = rx->endp[0] + orig;
2118 sv_catpvn(dstr, c, clen);
2121 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2122 TARG, NULL, r_flags));
2123 sv_catpvn(dstr, s, strend - s);
2125 (void)SvOOK_off(TARG);
2126 Safefree(SvPVX(TARG));
2127 SvPVX(TARG) = SvPVX(dstr);
2128 SvCUR_set(TARG, SvCUR(dstr));
2129 SvLEN_set(TARG, SvLEN(dstr));
2130 isutf8 = DO_UTF8(dstr);
2134 TAINT_IF(rxtainted & 1);
2136 PUSHs(sv_2mortal(newSViv((I32)iters)));
2138 (void)SvPOK_only(TARG);
2141 TAINT_IF(rxtainted);
2144 LEAVE_SCOPE(oldsave);
2153 LEAVE_SCOPE(oldsave);
2162 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2163 ++*PL_markstack_ptr;
2164 LEAVE; /* exit inner scope */
2167 if (PL_stack_base + *PL_markstack_ptr > SP) {
2169 I32 gimme = GIMME_V;
2171 LEAVE; /* exit outer scope */
2172 (void)POPMARK; /* pop src */
2173 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2174 (void)POPMARK; /* pop dst */
2175 SP = PL_stack_base + POPMARK; /* pop original mark */
2176 if (gimme == G_SCALAR) {
2180 else if (gimme == G_ARRAY)
2187 ENTER; /* enter inner scope */
2190 src = PL_stack_base[*PL_markstack_ptr];
2194 RETURNOP(cLOGOP->op_other);
2205 register PERL_CONTEXT *cx;
2211 if (gimme == G_SCALAR) {
2214 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2216 *MARK = SvREFCNT_inc(TOPs);
2221 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2223 *MARK = sv_mortalcopy(sv);
2228 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2232 *MARK = &PL_sv_undef;
2236 else if (gimme == G_ARRAY) {
2237 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2238 if (!SvTEMP(*MARK)) {
2239 *MARK = sv_mortalcopy(*MARK);
2240 TAINT_NOT; /* Each item is independent */
2246 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2247 PL_curpm = newpm; /* ... and pop $1 et al */
2251 return pop_return();
2254 /* This duplicates the above code because the above code must not
2255 * get any slower by more conditions */
2263 register PERL_CONTEXT *cx;
2270 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2271 /* We are an argument to a function or grep().
2272 * This kind of lvalueness was legal before lvalue
2273 * subroutines too, so be backward compatible:
2274 * cannot report errors. */
2276 /* Scalar context *is* possible, on the LHS of -> only,
2277 * as in f()->meth(). But this is not an lvalue. */
2278 if (gimme == G_SCALAR)
2280 if (gimme == G_ARRAY) {
2281 if (!CvLVALUE(cx->blk_sub.cv))
2282 goto temporise_array;
2283 EXTEND_MORTAL(SP - newsp);
2284 for (mark = newsp + 1; mark <= SP; mark++) {
2287 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2288 *mark = sv_mortalcopy(*mark);
2290 /* Can be a localized value subject to deletion. */
2291 PL_tmps_stack[++PL_tmps_ix] = *mark;
2292 (void)SvREFCNT_inc(*mark);
2297 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2298 /* Here we go for robustness, not for speed, so we change all
2299 * the refcounts so the caller gets a live guy. Cannot set
2300 * TEMP, so sv_2mortal is out of question. */
2301 if (!CvLVALUE(cx->blk_sub.cv)) {
2306 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2308 if (gimme == G_SCALAR) {
2312 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2317 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2318 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2320 else { /* Can be a localized value
2321 * subject to deletion. */
2322 PL_tmps_stack[++PL_tmps_ix] = *mark;
2323 (void)SvREFCNT_inc(*mark);
2326 else { /* Should not happen? */
2331 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2332 (MARK > SP ? "Empty array" : "Array"));
2336 else if (gimme == G_ARRAY) {
2337 EXTEND_MORTAL(SP - newsp);
2338 for (mark = newsp + 1; mark <= SP; mark++) {
2339 if (*mark != &PL_sv_undef
2340 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2341 /* Might be flattened array after $#array = */
2347 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2348 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2351 /* Can be a localized value subject to deletion. */
2352 PL_tmps_stack[++PL_tmps_ix] = *mark;
2353 (void)SvREFCNT_inc(*mark);
2359 if (gimme == G_SCALAR) {
2363 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2365 *MARK = SvREFCNT_inc(TOPs);
2370 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2372 *MARK = sv_mortalcopy(sv);
2377 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2381 *MARK = &PL_sv_undef;
2385 else if (gimme == G_ARRAY) {
2387 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2388 if (!SvTEMP(*MARK)) {
2389 *MARK = sv_mortalcopy(*MARK);
2390 TAINT_NOT; /* Each item is independent */
2397 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2398 PL_curpm = newpm; /* ... and pop $1 et al */
2402 return pop_return();
2407 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2409 SV *dbsv = GvSV(PL_DBsub);
2411 if (!PERLDB_SUB_NN) {
2415 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2416 || strEQ(GvNAME(gv), "END")
2417 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2418 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2419 && (gv = (GV*)*svp) ))) {
2420 /* Use GV from the stack as a fallback. */
2421 /* GV is potentially non-unique, or contain different CV. */
2422 SV *tmp = newRV((SV*)cv);
2423 sv_setsv(dbsv, tmp);
2427 gv_efullname3(dbsv, gv, Nullch);
2431 (void)SvUPGRADE(dbsv, SVt_PVIV);
2432 (void)SvIOK_on(dbsv);
2433 SAVEIV(SvIVX(dbsv));
2434 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2438 PL_curcopdb = PL_curcop;
2439 cv = GvCV(PL_DBsub);
2449 register PERL_CONTEXT *cx;
2451 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2454 DIE(aTHX_ "Not a CODE reference");
2455 switch (SvTYPE(sv)) {
2461 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2463 SP = PL_stack_base + POPMARK;
2466 if (SvGMAGICAL(sv)) {
2470 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2473 sym = SvPV(sv, n_a);
2475 DIE(aTHX_ PL_no_usym, "a subroutine");
2476 if (PL_op->op_private & HINT_STRICT_REFS)
2477 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2478 cv = get_cv(sym, TRUE);
2483 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2484 tryAMAGICunDEREF(to_cv);
2487 if (SvTYPE(cv) == SVt_PVCV)
2492 DIE(aTHX_ "Not a CODE reference");
2497 if (!(cv = GvCVu((GV*)sv)))
2498 cv = sv_2cv(sv, &stash, &gv, FALSE);
2511 if (!CvROOT(cv) && !CvXSUB(cv)) {
2515 /* anonymous or undef'd function leaves us no recourse */
2516 if (CvANON(cv) || !(gv = CvGV(cv)))
2517 DIE(aTHX_ "Undefined subroutine called");
2519 /* autoloaded stub? */
2520 if (cv != GvCV(gv)) {
2523 /* should call AUTOLOAD now? */
2526 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2533 sub_name = sv_newmortal();
2534 gv_efullname3(sub_name, gv, Nullch);
2535 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2539 DIE(aTHX_ "Not a CODE reference");
2544 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2545 cv = get_db_sub(&sv, cv);
2547 DIE(aTHX_ "No DBsub routine");
2550 #ifdef USE_5005THREADS
2552 * First we need to check if the sub or method requires locking.
2553 * If so, we gain a lock on the CV, the first argument or the
2554 * stash (for static methods), as appropriate. This has to be
2555 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2556 * reschedule by returning a new op.
2558 MUTEX_LOCK(CvMUTEXP(cv));
2559 if (CvFLAGS(cv) & CVf_LOCKED) {
2561 if (CvFLAGS(cv) & CVf_METHOD) {
2562 if (SP > PL_stack_base + TOPMARK)
2563 sv = *(PL_stack_base + TOPMARK + 1);
2565 AV *av = (AV*)PL_curpad[0];
2566 if (hasargs || !av || AvFILLp(av) < 0
2567 || !(sv = AvARRAY(av)[0]))
2569 MUTEX_UNLOCK(CvMUTEXP(cv));
2570 DIE(aTHX_ "no argument for locked method call");
2577 char *stashname = SvPV(sv, len);
2578 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2584 MUTEX_UNLOCK(CvMUTEXP(cv));
2585 mg = condpair_magic(sv);
2586 MUTEX_LOCK(MgMUTEXP(mg));
2587 if (MgOWNER(mg) == thr)
2588 MUTEX_UNLOCK(MgMUTEXP(mg));
2591 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2593 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2595 MUTEX_UNLOCK(MgMUTEXP(mg));
2596 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2598 MUTEX_LOCK(CvMUTEXP(cv));
2601 * Now we have permission to enter the sub, we must distinguish
2602 * four cases. (0) It's an XSUB (in which case we don't care
2603 * about ownership); (1) it's ours already (and we're recursing);
2604 * (2) it's free (but we may already be using a cached clone);
2605 * (3) another thread owns it. Case (1) is easy: we just use it.
2606 * Case (2) means we look for a clone--if we have one, use it
2607 * otherwise grab ownership of cv. Case (3) means we look for a
2608 * clone (for non-XSUBs) and have to create one if we don't
2610 * Why look for a clone in case (2) when we could just grab
2611 * ownership of cv straight away? Well, we could be recursing,
2612 * i.e. we originally tried to enter cv while another thread
2613 * owned it (hence we used a clone) but it has been freed up
2614 * and we're now recursing into it. It may or may not be "better"
2615 * to use the clone but at least CvDEPTH can be trusted.
2617 if (CvOWNER(cv) == thr || CvXSUB(cv))
2618 MUTEX_UNLOCK(CvMUTEXP(cv));
2620 /* Case (2) or (3) */
2624 * XXX Might it be better to release CvMUTEXP(cv) while we
2625 * do the hv_fetch? We might find someone has pinched it
2626 * when we look again, in which case we would be in case
2627 * (3) instead of (2) so we'd have to clone. Would the fact
2628 * that we released the mutex more quickly make up for this?
2630 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2632 /* We already have a clone to use */
2633 MUTEX_UNLOCK(CvMUTEXP(cv));
2635 DEBUG_S(PerlIO_printf(Perl_debug_log,
2636 "entersub: %p already has clone %p:%s\n",
2637 thr, cv, SvPEEK((SV*)cv)));
2640 if (CvDEPTH(cv) == 0)
2641 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2644 /* (2) => grab ownership of cv. (3) => make clone */
2648 MUTEX_UNLOCK(CvMUTEXP(cv));
2649 DEBUG_S(PerlIO_printf(Perl_debug_log,
2650 "entersub: %p grabbing %p:%s in stash %s\n",
2651 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2652 HvNAME(CvSTASH(cv)) : "(none)"));
2655 /* Make a new clone. */
2657 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2658 MUTEX_UNLOCK(CvMUTEXP(cv));
2659 DEBUG_S((PerlIO_printf(Perl_debug_log,
2660 "entersub: %p cloning %p:%s\n",
2661 thr, cv, SvPEEK((SV*)cv))));
2663 * We're creating a new clone so there's no race
2664 * between the original MUTEX_UNLOCK and the
2665 * SvREFCNT_inc since no one will be trying to undef
2666 * it out from underneath us. At least, I don't think
2669 clonecv = cv_clone(cv);
2670 SvREFCNT_dec(cv); /* finished with this */
2671 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2672 CvOWNER(clonecv) = thr;
2676 DEBUG_S(if (CvDEPTH(cv) != 0)
2677 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2679 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2682 #endif /* USE_5005THREADS */
2685 #ifdef PERL_XSUB_OLDSTYLE
2686 if (CvOLDSTYLE(cv)) {
2687 I32 (*fp3)(int,int,int);
2689 register I32 items = SP - MARK;
2690 /* We dont worry to copy from @_. */
2695 PL_stack_sp = mark + 1;
2696 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2697 items = (*fp3)(CvXSUBANY(cv).any_i32,
2698 MARK - PL_stack_base + 1,
2700 PL_stack_sp = PL_stack_base + items;
2703 #endif /* PERL_XSUB_OLDSTYLE */
2705 I32 markix = TOPMARK;
2710 /* Need to copy @_ to stack. Alternative may be to
2711 * switch stack to @_, and copy return values
2712 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2715 #ifdef USE_5005THREADS
2716 av = (AV*)PL_curpad[0];
2718 av = GvAV(PL_defgv);
2719 #endif /* USE_5005THREADS */
2720 items = AvFILLp(av) + 1; /* @_ is not tieable */
2723 /* Mark is at the end of the stack. */
2725 Copy(AvARRAY(av), SP + 1, items, SV*);
2730 /* We assume first XSUB in &DB::sub is the called one. */
2732 SAVEVPTR(PL_curcop);
2733 PL_curcop = PL_curcopdb;
2736 /* Do we need to open block here? XXXX */
2737 (void)(*CvXSUB(cv))(aTHX_ cv);
2739 /* Enforce some sanity in scalar context. */
2740 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2741 if (markix > PL_stack_sp - PL_stack_base)
2742 *(PL_stack_base + markix) = &PL_sv_undef;
2744 *(PL_stack_base + markix) = *PL_stack_sp;
2745 PL_stack_sp = PL_stack_base + markix;
2753 register I32 items = SP - MARK;
2754 AV* padlist = CvPADLIST(cv);
2755 SV** svp = AvARRAY(padlist);
2756 push_return(PL_op->op_next);
2757 PUSHBLOCK(cx, CXt_SUB, MARK);
2760 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2761 * that eval'' ops within this sub know the correct lexical space.
2762 * Owing the speed considerations, we choose to search for the cv
2763 * in doeval() instead.
2765 if (CvDEPTH(cv) < 2)
2766 (void)SvREFCNT_inc(cv);
2767 else { /* save temporaries on recursion? */
2768 PERL_STACK_OVERFLOW_CHECK();
2769 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2771 AV *newpad = newAV();
2772 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2773 I32 ix = AvFILLp((AV*)svp[1]);
2774 I32 names_fill = AvFILLp((AV*)svp[0]);
2775 svp = AvARRAY(svp[0]);
2776 for ( ;ix > 0; ix--) {
2777 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2778 char *name = SvPVX(svp[ix]);
2779 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2780 || *name == '&') /* anonymous code? */
2782 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2784 else { /* our own lexical */
2786 av_store(newpad, ix, sv = (SV*)newAV());
2787 else if (*name == '%')
2788 av_store(newpad, ix, sv = (SV*)newHV());
2790 av_store(newpad, ix, sv = NEWSV(0,0));
2794 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2795 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2798 av_store(newpad, ix, sv = NEWSV(0,0));
2802 av = newAV(); /* will be @_ */
2804 av_store(newpad, 0, (SV*)av);
2805 AvFLAGS(av) = AVf_REIFY;
2806 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2807 AvFILLp(padlist) = CvDEPTH(cv);
2808 svp = AvARRAY(padlist);
2811 #ifdef USE_5005THREADS
2813 AV* av = (AV*)PL_curpad[0];
2815 items = AvFILLp(av) + 1;
2817 /* Mark is at the end of the stack. */
2819 Copy(AvARRAY(av), SP + 1, items, SV*);
2824 #endif /* USE_5005THREADS */
2825 SAVEVPTR(PL_curpad);
2826 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2827 #ifndef USE_5005THREADS
2829 #endif /* USE_5005THREADS */
2835 DEBUG_S(PerlIO_printf(Perl_debug_log,
2836 "%p entersub preparing @_\n", thr));
2838 av = (AV*)PL_curpad[0];
2840 /* @_ is normally not REAL--this should only ever
2841 * happen when DB::sub() calls things that modify @_ */
2846 #ifndef USE_5005THREADS
2847 cx->blk_sub.savearray = GvAV(PL_defgv);
2848 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2849 #endif /* USE_5005THREADS */
2850 cx->blk_sub.oldcurpad = PL_curpad;
2851 cx->blk_sub.argarray = av;
2854 if (items > AvMAX(av) + 1) {
2856 if (AvARRAY(av) != ary) {
2857 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2858 SvPVX(av) = (char*)ary;
2860 if (items > AvMAX(av) + 1) {
2861 AvMAX(av) = items - 1;
2862 Renew(ary,items,SV*);
2864 SvPVX(av) = (char*)ary;
2867 Copy(MARK,AvARRAY(av),items,SV*);
2868 AvFILLp(av) = items - 1;
2876 /* warning must come *after* we fully set up the context
2877 * stuff so that __WARN__ handlers can safely dounwind()
2880 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2881 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2882 sub_crush_depth(cv);
2884 DEBUG_S(PerlIO_printf(Perl_debug_log,
2885 "%p entersub returning %p\n", thr, CvSTART(cv)));
2887 RETURNOP(CvSTART(cv));
2892 Perl_sub_crush_depth(pTHX_ CV *cv)
2895 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2897 SV* tmpstr = sv_newmortal();
2898 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2899 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2909 IV elem = SvIV(elemsv);
2911 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2912 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2915 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2916 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2918 elem -= PL_curcop->cop_arybase;
2919 if (SvTYPE(av) != SVt_PVAV)
2921 svp = av_fetch(av, elem, lval && !defer);
2923 if (!svp || *svp == &PL_sv_undef) {
2926 DIE(aTHX_ PL_no_aelem, elem);
2927 lv = sv_newmortal();
2928 sv_upgrade(lv, SVt_PVLV);
2930 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2931 LvTARG(lv) = SvREFCNT_inc(av);
2932 LvTARGOFF(lv) = elem;
2937 if (PL_op->op_private & OPpLVAL_INTRO)
2938 save_aelem(av, elem, svp);
2939 else if (PL_op->op_private & OPpDEREF)
2940 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2942 sv = (svp ? *svp : &PL_sv_undef);
2943 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2944 sv = sv_mortalcopy(sv);
2950 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2956 Perl_croak(aTHX_ PL_no_modify);
2957 if (SvTYPE(sv) < SVt_RV)
2958 sv_upgrade(sv, SVt_RV);
2959 else if (SvTYPE(sv) >= SVt_PV) {
2960 (void)SvOOK_off(sv);
2961 Safefree(SvPVX(sv));
2962 SvLEN(sv) = SvCUR(sv) = 0;
2966 SvRV(sv) = NEWSV(355,0);
2969 SvRV(sv) = (SV*)newAV();
2972 SvRV(sv) = (SV*)newHV();
2987 if (SvTYPE(rsv) == SVt_PVCV) {
2993 SETs(method_common(sv, Null(U32*)));
3000 SV* sv = cSVOP->op_sv;
3001 U32 hash = SvUVX(sv);
3003 XPUSHs(method_common(sv, &hash));
3008 S_method_common(pTHX_ SV* meth, U32* hashp)
3019 name = SvPV(meth, namelen);
3020 sv = *(PL_stack_base + TOPMARK + 1);
3023 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3032 /* this isn't a reference */
3035 !(packname = SvPV(sv, packlen)) ||
3036 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3037 !(ob=(SV*)GvIO(iogv)))
3039 /* this isn't the name of a filehandle either */
3041 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3042 ? !isIDFIRST_utf8((U8*)packname)
3043 : !isIDFIRST(*packname)
3046 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3047 SvOK(sv) ? "without a package or object reference"
3048 : "on an undefined value");
3050 /* assume it's a package name */
3051 stash = gv_stashpvn(packname, packlen, FALSE);
3054 /* it _is_ a filehandle name -- replace with a reference */
3055 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3058 /* if we got here, ob should be a reference or a glob */
3059 if (!ob || !(SvOBJECT(ob)
3060 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3063 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3067 stash = SvSTASH(ob);
3070 /* NOTE: stash may be null, hope hv_fetch_ent and
3071 gv_fetchmethod can cope (it seems they can) */
3073 /* shortcut for simple names */
3075 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3077 gv = (GV*)HeVAL(he);
3078 if (isGV(gv) && GvCV(gv) &&
3079 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3080 return (SV*)GvCV(gv);
3084 gv = gv_fetchmethod(stash, name);
3087 /* This code tries to figure out just what went wrong with
3088 gv_fetchmethod. It therefore needs to duplicate a lot of
3089 the internals of that function. We can't move it inside
3090 Perl_gv_fetchmethod_autoload(), however, since that would
3091 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3098 for (p = name; *p; p++) {
3100 sep = p, leaf = p + 1;
3101 else if (*p == ':' && *(p + 1) == ':')
3102 sep = p, leaf = p + 2;
3104 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3105 /* the method name is unqualified or starts with SUPER:: */
3106 packname = sep ? CopSTASHPV(PL_curcop) :
3107 stash ? HvNAME(stash) : packname;
3108 packlen = strlen(packname);
3111 /* the method name is qualified */
3113 packlen = sep - name;
3116 /* we're relying on gv_fetchmethod not autovivifying the stash */
3117 if (gv_stashpvn(packname, packlen, FALSE)) {
3119 "Can't locate object method \"%s\" via package \"%.*s\"",
3120 leaf, (int)packlen, packname);
3124 "Can't locate object method \"%s\" via package \"%.*s\""
3125 " (perhaps you forgot to load \"%.*s\"?)",
3126 leaf, (int)packlen, packname, (int)packlen, packname);
3129 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3132 #ifdef USE_5005THREADS
3134 unset_cvowner(pTHX_ void *cvarg)
3136 register CV* cv = (CV *) cvarg;
3138 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3139 thr, cv, SvPEEK((SV*)cv))));
3140 MUTEX_LOCK(CvMUTEXP(cv));
3141 DEBUG_S(if (CvDEPTH(cv) != 0)
3142 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3144 assert(thr == CvOWNER(cv));
3146 MUTEX_UNLOCK(CvMUTEXP(cv));
3149 #endif /* USE_5005THREADS */