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
25 static void unset_cvowner(pTHXo_ void *cvarg);
26 #endif /* USE_THREADS */
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)
561 if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
563 if (MARK == ORIGMARK) {
564 /* If using default handle then we need to make space to
565 * pass object as 1st arg, so move other args up ...
569 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
573 *MARK = SvTIED_obj((SV*)gv, mg);
576 call_method("PRINT", G_SCALAR);
584 if (!(io = GvIO(gv))) {
586 && (mg = SvTIED_mg((SV*)GvEGV(gv), PERL_MAGIC_tiedscalar)))
588 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
589 report_evil_fh(gv, io, PL_op->op_type);
590 SETERRNO(EBADF,RMS$_IFI);
593 else if (!(fp = IoOFP(io))) {
594 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
596 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
597 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
598 report_evil_fh(gv, io, PL_op->op_type);
600 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
605 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
607 if (!do_print(*MARK, fp))
611 if (!do_print(PL_ofs_sv, fp)) { /* $, */
620 if (!do_print(*MARK, fp))
628 if (PL_ors_sv && SvOK(PL_ors_sv))
629 if (!do_print(PL_ors_sv, fp)) /* $\ */
632 if (IoFLAGS(io) & IOf_FLUSH)
633 if (PerlIO_flush(fp) == EOF)
654 tryAMAGICunDEREF(to_av);
657 if (SvTYPE(av) != SVt_PVAV)
658 DIE(aTHX_ "Not an ARRAY reference");
659 if (PL_op->op_flags & OPf_REF) {
664 if (GIMME == G_SCALAR)
665 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
671 if (SvTYPE(sv) == SVt_PVAV) {
673 if (PL_op->op_flags & OPf_REF) {
678 if (GIMME == G_SCALAR)
679 Perl_croak(aTHX_ "Can't return array to lvalue"
688 if (SvTYPE(sv) != SVt_PVGV) {
692 if (SvGMAGICAL(sv)) {
698 if (PL_op->op_flags & OPf_REF ||
699 PL_op->op_private & HINT_STRICT_REFS)
700 DIE(aTHX_ PL_no_usym, "an ARRAY");
701 if (ckWARN(WARN_UNINITIALIZED))
703 if (GIMME == G_ARRAY) {
710 if ((PL_op->op_flags & OPf_SPECIAL) &&
711 !(PL_op->op_flags & OPf_MOD))
713 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
715 && (!is_gv_magical(sym,len,0)
716 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
722 if (PL_op->op_private & HINT_STRICT_REFS)
723 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
724 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
731 if (PL_op->op_private & OPpLVAL_INTRO)
733 if (PL_op->op_flags & OPf_REF) {
738 if (GIMME == G_SCALAR)
739 Perl_croak(aTHX_ "Can't return array to lvalue"
747 if (GIMME == G_ARRAY) {
748 I32 maxarg = AvFILL(av) + 1;
749 (void)POPs; /* XXXX May be optimized away? */
751 if (SvRMAGICAL(av)) {
753 for (i=0; i < maxarg; i++) {
754 SV **svp = av_fetch(av, i, FALSE);
755 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
759 Copy(AvARRAY(av), SP+1, maxarg, SV*);
765 I32 maxarg = AvFILL(av) + 1;
778 tryAMAGICunDEREF(to_hv);
781 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
782 DIE(aTHX_ "Not a HASH reference");
783 if (PL_op->op_flags & OPf_REF) {
788 if (GIMME == G_SCALAR)
789 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
795 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
797 if (PL_op->op_flags & OPf_REF) {
802 if (GIMME == G_SCALAR)
803 Perl_croak(aTHX_ "Can't return hash to lvalue"
812 if (SvTYPE(sv) != SVt_PVGV) {
816 if (SvGMAGICAL(sv)) {
822 if (PL_op->op_flags & OPf_REF ||
823 PL_op->op_private & HINT_STRICT_REFS)
824 DIE(aTHX_ PL_no_usym, "a HASH");
825 if (ckWARN(WARN_UNINITIALIZED))
827 if (GIMME == G_ARRAY) {
834 if ((PL_op->op_flags & OPf_SPECIAL) &&
835 !(PL_op->op_flags & OPf_MOD))
837 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
839 && (!is_gv_magical(sym,len,0)
840 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
846 if (PL_op->op_private & HINT_STRICT_REFS)
847 DIE(aTHX_ PL_no_symref, sym, "a HASH");
848 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
855 if (PL_op->op_private & OPpLVAL_INTRO)
857 if (PL_op->op_flags & OPf_REF) {
862 if (GIMME == G_SCALAR)
863 Perl_croak(aTHX_ "Can't return hash to lvalue"
871 if (GIMME == G_ARRAY) { /* array wanted */
872 *PL_stack_sp = (SV*)hv;
877 if (SvTYPE(hv) == SVt_PVAV)
878 hv = avhv_keys((AV*)hv);
880 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
881 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
891 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
897 leftop = ((BINOP*)PL_op)->op_last;
899 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
900 leftop = ((LISTOP*)leftop)->op_first;
902 /* Skip PUSHMARK and each element already assigned to. */
903 for (i = lelem - firstlelem; i > 0; i--) {
904 leftop = leftop->op_sibling;
907 if (leftop->op_type != OP_RV2HV)
912 av_fill(ary, 0); /* clear all but the fields hash */
913 if (lastrelem >= relem) {
914 while (relem < lastrelem) { /* gobble up all the rest */
918 /* Avoid a memory leak when avhv_store_ent dies. */
919 tmpstr = sv_newmortal();
920 sv_setsv(tmpstr,relem[1]); /* value */
922 if (avhv_store_ent(ary,relem[0],tmpstr,0))
923 (void)SvREFCNT_inc(tmpstr);
924 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
930 if (relem == lastrelem)
936 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
940 if (ckWARN(WARN_MISC)) {
941 if (relem == firstrelem &&
943 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
944 SvTYPE(SvRV(*relem)) == SVt_PVHV))
946 Perl_warner(aTHX_ WARN_MISC,
947 "Reference found where even-sized list expected");
950 Perl_warner(aTHX_ WARN_MISC,
951 "Odd number of elements in hash assignment");
953 if (SvTYPE(hash) == SVt_PVAV) {
955 tmpstr = sv_newmortal();
956 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
957 (void)SvREFCNT_inc(tmpstr);
958 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
963 tmpstr = NEWSV(29,0);
964 didstore = hv_store_ent(hash,*relem,tmpstr,0);
965 if (SvMAGICAL(hash)) {
966 if (SvSMAGICAL(tmpstr))
979 SV **lastlelem = PL_stack_sp;
980 SV **lastrelem = PL_stack_base + POPMARK;
981 SV **firstrelem = PL_stack_base + POPMARK + 1;
982 SV **firstlelem = lastrelem + 1;
995 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
997 /* If there's a common identifier on both sides we have to take
998 * special care that assigning the identifier on the left doesn't
999 * clobber a value on the right that's used later in the list.
1001 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1002 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1003 for (relem = firstrelem; relem <= lastrelem; relem++) {
1005 if ((sv = *relem)) {
1006 TAINT_NOT; /* Each item is independent */
1007 *relem = sv_mortalcopy(sv);
1017 while (lelem <= lastlelem) {
1018 TAINT_NOT; /* Each item stands on its own, taintwise. */
1020 switch (SvTYPE(sv)) {
1023 magic = SvMAGICAL(ary) != 0;
1024 if (PL_op->op_private & OPpASSIGN_HASH) {
1025 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1031 do_oddball((HV*)ary, relem, firstrelem);
1033 relem = lastrelem + 1;
1038 av_extend(ary, lastrelem - relem);
1040 while (relem <= lastrelem) { /* gobble up all the rest */
1044 sv_setsv(sv,*relem);
1046 didstore = av_store(ary,i++,sv);
1056 case SVt_PVHV: { /* normal hash */
1060 magic = SvMAGICAL(hash) != 0;
1063 while (relem < lastrelem) { /* gobble up all the rest */
1068 sv = &PL_sv_no, relem++;
1069 tmpstr = NEWSV(29,0);
1071 sv_setsv(tmpstr,*relem); /* value */
1072 *(relem++) = tmpstr;
1073 didstore = hv_store_ent(hash,sv,tmpstr,0);
1075 if (SvSMAGICAL(tmpstr))
1082 if (relem == lastrelem) {
1083 do_oddball(hash, relem, firstrelem);
1089 if (SvIMMORTAL(sv)) {
1090 if (relem <= lastrelem)
1094 if (relem <= lastrelem) {
1095 sv_setsv(sv, *relem);
1099 sv_setsv(sv, &PL_sv_undef);
1104 if (PL_delaymagic & ~DM_DELAY) {
1105 if (PL_delaymagic & DM_UID) {
1106 #ifdef HAS_SETRESUID
1107 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1109 # ifdef HAS_SETREUID
1110 (void)setreuid(PL_uid,PL_euid);
1113 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1114 (void)setruid(PL_uid);
1115 PL_delaymagic &= ~DM_RUID;
1117 # endif /* HAS_SETRUID */
1119 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1120 (void)seteuid(PL_uid);
1121 PL_delaymagic &= ~DM_EUID;
1123 # endif /* HAS_SETEUID */
1124 if (PL_delaymagic & DM_UID) {
1125 if (PL_uid != PL_euid)
1126 DIE(aTHX_ "No setreuid available");
1127 (void)PerlProc_setuid(PL_uid);
1129 # endif /* HAS_SETREUID */
1130 #endif /* HAS_SETRESUID */
1131 PL_uid = PerlProc_getuid();
1132 PL_euid = PerlProc_geteuid();
1134 if (PL_delaymagic & DM_GID) {
1135 #ifdef HAS_SETRESGID
1136 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1138 # ifdef HAS_SETREGID
1139 (void)setregid(PL_gid,PL_egid);
1142 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1143 (void)setrgid(PL_gid);
1144 PL_delaymagic &= ~DM_RGID;
1146 # endif /* HAS_SETRGID */
1148 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1149 (void)setegid(PL_gid);
1150 PL_delaymagic &= ~DM_EGID;
1152 # endif /* HAS_SETEGID */
1153 if (PL_delaymagic & DM_GID) {
1154 if (PL_gid != PL_egid)
1155 DIE(aTHX_ "No setregid available");
1156 (void)PerlProc_setgid(PL_gid);
1158 # endif /* HAS_SETREGID */
1159 #endif /* HAS_SETRESGID */
1160 PL_gid = PerlProc_getgid();
1161 PL_egid = PerlProc_getegid();
1163 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1168 if (gimme == G_VOID)
1169 SP = firstrelem - 1;
1170 else if (gimme == G_SCALAR) {
1173 SETi(lastrelem - firstrelem + 1);
1179 SP = firstrelem + (lastlelem - firstlelem);
1180 lelem = firstlelem + (relem - firstrelem);
1182 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1190 register PMOP *pm = cPMOP;
1191 SV *rv = sv_newmortal();
1192 SV *sv = newSVrv(rv, "Regexp");
1193 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1200 register PMOP *pm = cPMOP;
1205 I32 r_flags = REXEC_CHECKED;
1206 char *truebase; /* Start of string */
1207 register REGEXP *rx = PM_GETRE(pm);
1212 I32 oldsave = PL_savestack_ix;
1213 I32 update_minmatch = 1;
1214 I32 had_zerolen = 0;
1216 if (PL_op->op_flags & OPf_STACKED)
1223 PUTBACK; /* EVAL blocks need stack_sp. */
1224 s = SvPV(TARG, len);
1227 DIE(aTHX_ "panic: pp_match");
1228 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1229 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1232 if (pm->op_pmdynflags & PMdf_USED) {
1234 if (gimme == G_ARRAY)
1239 if (!rx->prelen && PL_curpm) {
1243 if (rx->minlen > len) goto failure;
1247 /* XXXX What part of this is needed with true \G-support? */
1248 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1250 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1251 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1252 if (mg && mg->mg_len >= 0) {
1253 if (!(rx->reganch & ROPT_GPOS_SEEN))
1254 rx->endp[0] = rx->startp[0] = mg->mg_len;
1255 else if (rx->reganch & ROPT_ANCH_GPOS) {
1256 r_flags |= REXEC_IGNOREPOS;
1257 rx->endp[0] = rx->startp[0] = mg->mg_len;
1259 minmatch = (mg->mg_flags & MGf_MINMATCH);
1260 update_minmatch = 0;
1264 if ((!global && rx->nparens)
1265 || SvTEMP(TARG) || PL_sawampersand)
1266 r_flags |= REXEC_COPY_STR;
1268 r_flags |= REXEC_SCREAM;
1270 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1271 SAVEINT(PL_multiline);
1272 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1276 if (global && rx->startp[0] != -1) {
1277 t = s = rx->endp[0] + truebase;
1278 if ((s + rx->minlen) > strend)
1280 if (update_minmatch++)
1281 minmatch = had_zerolen;
1283 if (rx->reganch & RE_USE_INTUIT &&
1284 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1285 PL_bostr = truebase;
1286 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1290 if ( (rx->reganch & ROPT_CHECK_ALL)
1292 && ((rx->reganch & ROPT_NOSCAN)
1293 || !((rx->reganch & RE_INTUIT_TAIL)
1294 && (r_flags & REXEC_SCREAM)))
1295 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1298 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1301 if (pm->op_pmflags & PMf_ONCE)
1302 pm->op_pmdynflags |= PMdf_USED;
1311 RX_MATCH_TAINTED_on(rx);
1312 TAINT_IF(RX_MATCH_TAINTED(rx));
1313 if (gimme == G_ARRAY) {
1314 I32 nparens, i, len;
1316 nparens = rx->nparens;
1317 if (global && !nparens)
1321 SPAGAIN; /* EVAL blocks could move the stack. */
1322 EXTEND(SP, nparens + i);
1323 EXTEND_MORTAL(nparens + i);
1324 for (i = !i; i <= nparens; i++) {
1325 PUSHs(sv_newmortal());
1327 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1328 len = rx->endp[i] - rx->startp[i];
1329 s = rx->startp[i] + truebase;
1330 sv_setpvn(*SP, s, len);
1336 had_zerolen = (rx->startp[0] != -1
1337 && rx->startp[0] == rx->endp[0]);
1338 PUTBACK; /* EVAL blocks may use stack */
1339 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1344 LEAVE_SCOPE(oldsave);
1350 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1351 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1353 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1354 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1356 if (rx->startp[0] != -1) {
1357 mg->mg_len = rx->endp[0];
1358 if (rx->startp[0] == rx->endp[0])
1359 mg->mg_flags |= MGf_MINMATCH;
1361 mg->mg_flags &= ~MGf_MINMATCH;
1364 LEAVE_SCOPE(oldsave);
1368 yup: /* Confirmed by INTUIT */
1370 RX_MATCH_TAINTED_on(rx);
1371 TAINT_IF(RX_MATCH_TAINTED(rx));
1373 if (pm->op_pmflags & PMf_ONCE)
1374 pm->op_pmdynflags |= PMdf_USED;
1375 if (RX_MATCH_COPIED(rx))
1376 Safefree(rx->subbeg);
1377 RX_MATCH_COPIED_off(rx);
1378 rx->subbeg = Nullch;
1380 rx->subbeg = truebase;
1381 rx->startp[0] = s - truebase;
1382 if (DO_UTF8(PL_reg_sv)) {
1383 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1384 rx->endp[0] = t - truebase;
1387 rx->endp[0] = s - truebase + rx->minlen;
1389 rx->sublen = strend - truebase;
1392 if (PL_sawampersand) {
1395 rx->subbeg = savepvn(t, strend - t);
1396 rx->sublen = strend - t;
1397 RX_MATCH_COPIED_on(rx);
1398 off = rx->startp[0] = s - t;
1399 rx->endp[0] = off + rx->minlen;
1401 else { /* startp/endp are used by @- @+. */
1402 rx->startp[0] = s - truebase;
1403 rx->endp[0] = s - truebase + rx->minlen;
1405 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1406 LEAVE_SCOPE(oldsave);
1411 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1412 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1413 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1418 LEAVE_SCOPE(oldsave);
1419 if (gimme == G_ARRAY)
1425 Perl_do_readline(pTHX)
1427 dSP; dTARGETSTACKED;
1432 register IO *io = GvIO(PL_last_in_gv);
1433 register I32 type = PL_op->op_type;
1434 I32 gimme = GIMME_V;
1437 if ((mg = SvTIED_mg((SV*)PL_last_in_gv, PERL_MAGIC_tiedscalar))) {
1439 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1442 call_method("READLINE", gimme);
1445 if (gimme == G_SCALAR)
1446 SvSetMagicSV_nosteal(TARG, TOPs);
1453 if (IoFLAGS(io) & IOf_ARGV) {
1454 if (IoFLAGS(io) & IOf_START) {
1456 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1457 IoFLAGS(io) &= ~IOf_START;
1458 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1459 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1460 SvSETMAGIC(GvSV(PL_last_in_gv));
1465 fp = nextargv(PL_last_in_gv);
1466 if (!fp) { /* Note: fp != IoIFP(io) */
1467 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1470 else if (type == OP_GLOB)
1471 fp = Perl_start_glob(aTHX_ POPs, io);
1473 else if (type == OP_GLOB)
1475 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1476 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1480 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1481 && (!io || !(IoFLAGS(io) & IOf_START))) {
1482 if (type == OP_GLOB)
1483 Perl_warner(aTHX_ WARN_GLOB,
1484 "glob failed (can't start child: %s)",
1487 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1489 if (gimme == G_SCALAR) {
1490 (void)SvOK_off(TARG);
1496 if (gimme == G_SCALAR) {
1500 (void)SvUPGRADE(sv, SVt_PV);
1501 tmplen = SvLEN(sv); /* remember if already alloced */
1503 Sv_Grow(sv, 80); /* try short-buffering it */
1504 if (type == OP_RCATLINE)
1510 sv = sv_2mortal(NEWSV(57, 80));
1514 /* This should not be marked tainted if the fp is marked clean */
1515 #define MAYBE_TAINT_LINE(io, sv) \
1516 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1521 /* delay EOF state for a snarfed empty file */
1522 #define SNARF_EOF(gimme,rs,io,sv) \
1523 (gimme != G_SCALAR || SvCUR(sv) \
1524 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1528 if (!sv_gets(sv, fp, offset)
1529 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1531 PerlIO_clearerr(fp);
1532 if (IoFLAGS(io) & IOf_ARGV) {
1533 fp = nextargv(PL_last_in_gv);
1536 (void)do_close(PL_last_in_gv, FALSE);
1538 else if (type == OP_GLOB) {
1539 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1540 Perl_warner(aTHX_ WARN_GLOB,
1541 "glob failed (child exited with status %d%s)",
1542 (int)(STATUS_CURRENT >> 8),
1543 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1546 if (gimme == G_SCALAR) {
1547 (void)SvOK_off(TARG);
1551 MAYBE_TAINT_LINE(io, sv);
1554 MAYBE_TAINT_LINE(io, sv);
1556 IoFLAGS(io) |= IOf_NOLINE;
1560 if (type == OP_GLOB) {
1563 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1564 tmps = SvEND(sv) - 1;
1565 if (*tmps == *SvPVX(PL_rs)) {
1570 for (tmps = SvPVX(sv); *tmps; tmps++)
1571 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1572 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1574 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1575 (void)POPs; /* Unmatched wildcard? Chuck it... */
1579 if (gimme == G_ARRAY) {
1580 if (SvLEN(sv) - SvCUR(sv) > 20) {
1581 SvLEN_set(sv, SvCUR(sv)+1);
1582 Renew(SvPVX(sv), SvLEN(sv), char);
1584 sv = sv_2mortal(NEWSV(58, 80));
1587 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1588 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1592 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1593 Renew(SvPVX(sv), SvLEN(sv), char);
1602 register PERL_CONTEXT *cx;
1603 I32 gimme = OP_GIMME(PL_op, -1);
1606 if (cxstack_ix >= 0)
1607 gimme = cxstack[cxstack_ix].blk_gimme;
1615 PUSHBLOCK(cx, CXt_BLOCK, SP);
1627 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1628 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1630 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1633 if (SvTYPE(hv) == SVt_PVHV) {
1634 if (PL_op->op_private & OPpLVAL_INTRO)
1635 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1636 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1637 svp = he ? &HeVAL(he) : 0;
1639 else if (SvTYPE(hv) == SVt_PVAV) {
1640 if (PL_op->op_private & OPpLVAL_INTRO)
1641 DIE(aTHX_ "Can't localize pseudo-hash element");
1642 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1648 if (!svp || *svp == &PL_sv_undef) {
1653 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1655 lv = sv_newmortal();
1656 sv_upgrade(lv, SVt_PVLV);
1658 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1659 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1660 LvTARG(lv) = SvREFCNT_inc(hv);
1665 if (PL_op->op_private & OPpLVAL_INTRO) {
1666 if (HvNAME(hv) && isGV(*svp))
1667 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1671 char *key = SvPV(keysv, keylen);
1672 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1674 save_helem(hv, keysv, svp);
1677 else if (PL_op->op_private & OPpDEREF)
1678 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1680 sv = (svp ? *svp : &PL_sv_undef);
1681 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1682 * Pushing the magical RHS on to the stack is useless, since
1683 * that magic is soon destined to be misled by the local(),
1684 * and thus the later pp_sassign() will fail to mg_get() the
1685 * old value. This should also cure problems with delayed
1686 * mg_get()s. GSAR 98-07-03 */
1687 if (!lval && SvGMAGICAL(sv))
1688 sv = sv_mortalcopy(sv);
1696 register PERL_CONTEXT *cx;
1702 if (PL_op->op_flags & OPf_SPECIAL) {
1703 cx = &cxstack[cxstack_ix];
1704 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1709 gimme = OP_GIMME(PL_op, -1);
1711 if (cxstack_ix >= 0)
1712 gimme = cxstack[cxstack_ix].blk_gimme;
1718 if (gimme == G_VOID)
1720 else if (gimme == G_SCALAR) {
1723 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1726 *MARK = sv_mortalcopy(TOPs);
1729 *MARK = &PL_sv_undef;
1733 else if (gimme == G_ARRAY) {
1734 /* in case LEAVE wipes old return values */
1735 for (mark = newsp + 1; mark <= SP; mark++) {
1736 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1737 *mark = sv_mortalcopy(*mark);
1738 TAINT_NOT; /* Each item is independent */
1742 PL_curpm = newpm; /* Don't pop $1 et al till now */
1752 register PERL_CONTEXT *cx;
1758 cx = &cxstack[cxstack_ix];
1759 if (CxTYPE(cx) != CXt_LOOP)
1760 DIE(aTHX_ "panic: pp_iter");
1762 itersvp = CxITERVAR(cx);
1763 av = cx->blk_loop.iterary;
1764 if (SvTYPE(av) != SVt_PVAV) {
1765 /* iterate ($min .. $max) */
1766 if (cx->blk_loop.iterlval) {
1767 /* string increment */
1768 register SV* cur = cx->blk_loop.iterlval;
1770 char *max = SvPV((SV*)av, maxlen);
1771 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1772 #ifndef USE_THREADS /* don't risk potential race */
1773 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1774 /* safe to reuse old SV */
1775 sv_setsv(*itersvp, cur);
1780 /* we need a fresh SV every time so that loop body sees a
1781 * completely new SV for closures/references to work as
1783 SvREFCNT_dec(*itersvp);
1784 *itersvp = newSVsv(cur);
1786 if (strEQ(SvPVX(cur), max))
1787 sv_setiv(cur, 0); /* terminate next time */
1794 /* integer increment */
1795 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1798 #ifndef USE_THREADS /* don't risk potential race */
1799 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1800 /* safe to reuse old SV */
1801 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1806 /* we need a fresh SV every time so that loop body sees a
1807 * completely new SV for closures/references to work as they
1809 SvREFCNT_dec(*itersvp);
1810 *itersvp = newSViv(cx->blk_loop.iterix++);
1816 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1819 SvREFCNT_dec(*itersvp);
1821 if (SvMAGICAL(av) || AvREIFY(av)) {
1822 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1829 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1835 if (av != PL_curstack && sv == &PL_sv_undef) {
1836 SV *lv = cx->blk_loop.iterlval;
1837 if (lv && SvREFCNT(lv) > 1) {
1842 SvREFCNT_dec(LvTARG(lv));
1844 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1845 sv_upgrade(lv, SVt_PVLV);
1847 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1849 LvTARG(lv) = SvREFCNT_inc(av);
1850 LvTARGOFF(lv) = cx->blk_loop.iterix;
1851 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1855 *itersvp = SvREFCNT_inc(sv);
1862 register PMOP *pm = cPMOP;
1878 register REGEXP *rx = PM_GETRE(pm);
1880 int force_on_match = 0;
1881 I32 oldsave = PL_savestack_ix;
1885 /* known replacement string? */
1886 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1887 if (PL_op->op_flags & OPf_STACKED)
1894 do_utf8 = DO_UTF8(PL_reg_sv);
1895 if (SvFAKE(TARG) && SvREADONLY(TARG))
1896 sv_force_normal(TARG);
1897 if (SvREADONLY(TARG)
1898 || (SvTYPE(TARG) > SVt_PVLV
1899 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1900 DIE(aTHX_ PL_no_modify);
1903 s = SvPV(TARG, len);
1904 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1906 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1907 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1914 DIE(aTHX_ "panic: pp_subst");
1917 slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1918 maxiters = 2 * slen + 10; /* We can match twice at each
1919 position, once with zero-length,
1920 second time with non-zero. */
1922 if (!rx->prelen && PL_curpm) {
1926 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1927 ? REXEC_COPY_STR : 0;
1929 r_flags |= REXEC_SCREAM;
1930 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1931 SAVEINT(PL_multiline);
1932 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1935 if (rx->reganch & RE_USE_INTUIT) {
1937 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1941 /* How to do it in subst? */
1942 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1944 && ((rx->reganch & ROPT_NOSCAN)
1945 || !((rx->reganch & RE_INTUIT_TAIL)
1946 && (r_flags & REXEC_SCREAM))))
1951 /* only replace once? */
1952 once = !(rpm->op_pmflags & PMf_GLOBAL);
1954 /* known replacement string? */
1955 c = dstr ? SvPV(dstr, clen) : Nullch;
1957 /* can do inplace substitution? */
1958 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1959 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1960 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1961 r_flags | REXEC_CHECKED))
1965 LEAVE_SCOPE(oldsave);
1968 if (force_on_match) {
1970 s = SvPV_force(TARG, len);
1975 SvSCREAM_off(TARG); /* disable possible screamer */
1977 rxtainted |= RX_MATCH_TAINTED(rx);
1978 m = orig + rx->startp[0];
1979 d = orig + rx->endp[0];
1981 if (m - s > strend - d) { /* faster to shorten from end */
1983 Copy(c, m, clen, char);
1988 Move(d, m, i, char);
1992 SvCUR_set(TARG, m - s);
1995 else if ((i = m - s)) { /* faster from front */
2003 Copy(c, m, clen, char);
2008 Copy(c, d, clen, char);
2013 TAINT_IF(rxtainted & 1);
2019 if (iters++ > maxiters)
2020 DIE(aTHX_ "Substitution loop");
2021 rxtainted |= RX_MATCH_TAINTED(rx);
2022 m = rx->startp[0] + orig;
2026 Move(s, d, i, char);
2030 Copy(c, d, clen, char);
2033 s = rx->endp[0] + orig;
2034 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2036 /* don't match same null twice */
2037 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2040 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2041 Move(s, d, i+1, char); /* include the NUL */
2043 TAINT_IF(rxtainted & 1);
2045 PUSHs(sv_2mortal(newSViv((I32)iters)));
2047 (void)SvPOK_only_UTF8(TARG);
2048 TAINT_IF(rxtainted);
2049 if (SvSMAGICAL(TARG)) {
2055 LEAVE_SCOPE(oldsave);
2059 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2060 r_flags | REXEC_CHECKED))
2064 if (force_on_match) {
2066 s = SvPV_force(TARG, len);
2069 rxtainted |= RX_MATCH_TAINTED(rx);
2070 dstr = NEWSV(25, len);
2071 sv_setpvn(dstr, m, s-m);
2076 register PERL_CONTEXT *cx;
2079 RETURNOP(cPMOP->op_pmreplroot);
2081 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2083 if (iters++ > maxiters)
2084 DIE(aTHX_ "Substitution loop");
2085 rxtainted |= RX_MATCH_TAINTED(rx);
2086 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2091 strend = s + (strend - m);
2093 m = rx->startp[0] + orig;
2094 sv_catpvn(dstr, s, m-s);
2095 s = rx->endp[0] + orig;
2097 sv_catpvn(dstr, c, clen);
2100 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2101 TARG, NULL, r_flags));
2102 sv_catpvn(dstr, s, strend - s);
2104 (void)SvOOK_off(TARG);
2105 Safefree(SvPVX(TARG));
2106 SvPVX(TARG) = SvPVX(dstr);
2107 SvCUR_set(TARG, SvCUR(dstr));
2108 SvLEN_set(TARG, SvLEN(dstr));
2109 isutf8 = DO_UTF8(dstr);
2113 TAINT_IF(rxtainted & 1);
2115 PUSHs(sv_2mortal(newSViv((I32)iters)));
2117 (void)SvPOK_only(TARG);
2120 TAINT_IF(rxtainted);
2123 LEAVE_SCOPE(oldsave);
2132 LEAVE_SCOPE(oldsave);
2141 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2142 ++*PL_markstack_ptr;
2143 LEAVE; /* exit inner scope */
2146 if (PL_stack_base + *PL_markstack_ptr > SP) {
2148 I32 gimme = GIMME_V;
2150 LEAVE; /* exit outer scope */
2151 (void)POPMARK; /* pop src */
2152 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2153 (void)POPMARK; /* pop dst */
2154 SP = PL_stack_base + POPMARK; /* pop original mark */
2155 if (gimme == G_SCALAR) {
2159 else if (gimme == G_ARRAY)
2166 ENTER; /* enter inner scope */
2169 src = PL_stack_base[*PL_markstack_ptr];
2173 RETURNOP(cLOGOP->op_other);
2184 register PERL_CONTEXT *cx;
2190 if (gimme == G_SCALAR) {
2193 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2195 *MARK = SvREFCNT_inc(TOPs);
2200 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2202 *MARK = sv_mortalcopy(sv);
2207 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2211 *MARK = &PL_sv_undef;
2215 else if (gimme == G_ARRAY) {
2216 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2217 if (!SvTEMP(*MARK)) {
2218 *MARK = sv_mortalcopy(*MARK);
2219 TAINT_NOT; /* Each item is independent */
2225 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2226 PL_curpm = newpm; /* ... and pop $1 et al */
2230 return pop_return();
2233 /* This duplicates the above code because the above code must not
2234 * get any slower by more conditions */
2242 register PERL_CONTEXT *cx;
2249 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2250 /* We are an argument to a function or grep().
2251 * This kind of lvalueness was legal before lvalue
2252 * subroutines too, so be backward compatible:
2253 * cannot report errors. */
2255 /* Scalar context *is* possible, on the LHS of -> only,
2256 * as in f()->meth(). But this is not an lvalue. */
2257 if (gimme == G_SCALAR)
2259 if (gimme == G_ARRAY) {
2260 if (!CvLVALUE(cx->blk_sub.cv))
2261 goto temporise_array;
2262 EXTEND_MORTAL(SP - newsp);
2263 for (mark = newsp + 1; mark <= SP; mark++) {
2266 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2267 *mark = sv_mortalcopy(*mark);
2269 /* Can be a localized value subject to deletion. */
2270 PL_tmps_stack[++PL_tmps_ix] = *mark;
2271 (void)SvREFCNT_inc(*mark);
2276 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2277 /* Here we go for robustness, not for speed, so we change all
2278 * the refcounts so the caller gets a live guy. Cannot set
2279 * TEMP, so sv_2mortal is out of question. */
2280 if (!CvLVALUE(cx->blk_sub.cv)) {
2285 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2287 if (gimme == G_SCALAR) {
2291 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2296 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2297 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2299 else { /* Can be a localized value
2300 * subject to deletion. */
2301 PL_tmps_stack[++PL_tmps_ix] = *mark;
2302 (void)SvREFCNT_inc(*mark);
2305 else { /* Should not happen? */
2310 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2311 (MARK > SP ? "Empty array" : "Array"));
2315 else if (gimme == G_ARRAY) {
2316 EXTEND_MORTAL(SP - newsp);
2317 for (mark = newsp + 1; mark <= SP; mark++) {
2318 if (*mark != &PL_sv_undef
2319 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2320 /* Might be flattened array after $#array = */
2326 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2327 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2330 /* Can be a localized value subject to deletion. */
2331 PL_tmps_stack[++PL_tmps_ix] = *mark;
2332 (void)SvREFCNT_inc(*mark);
2338 if (gimme == G_SCALAR) {
2342 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2344 *MARK = SvREFCNT_inc(TOPs);
2349 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2351 *MARK = sv_mortalcopy(sv);
2356 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2360 *MARK = &PL_sv_undef;
2364 else if (gimme == G_ARRAY) {
2366 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2367 if (!SvTEMP(*MARK)) {
2368 *MARK = sv_mortalcopy(*MARK);
2369 TAINT_NOT; /* Each item is independent */
2376 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2377 PL_curpm = newpm; /* ... and pop $1 et al */
2381 return pop_return();
2386 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2388 SV *dbsv = GvSV(PL_DBsub);
2390 if (!PERLDB_SUB_NN) {
2394 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2395 || strEQ(GvNAME(gv), "END")
2396 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2397 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2398 && (gv = (GV*)*svp) ))) {
2399 /* Use GV from the stack as a fallback. */
2400 /* GV is potentially non-unique, or contain different CV. */
2401 SV *tmp = newRV((SV*)cv);
2402 sv_setsv(dbsv, tmp);
2406 gv_efullname3(dbsv, gv, Nullch);
2410 (void)SvUPGRADE(dbsv, SVt_PVIV);
2411 (void)SvIOK_on(dbsv);
2412 SAVEIV(SvIVX(dbsv));
2413 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2417 PL_curcopdb = PL_curcop;
2418 cv = GvCV(PL_DBsub);
2428 register PERL_CONTEXT *cx;
2430 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2433 DIE(aTHX_ "Not a CODE reference");
2434 switch (SvTYPE(sv)) {
2440 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2442 SP = PL_stack_base + POPMARK;
2445 if (SvGMAGICAL(sv)) {
2447 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2450 sym = SvPV(sv, n_a);
2452 DIE(aTHX_ PL_no_usym, "a subroutine");
2453 if (PL_op->op_private & HINT_STRICT_REFS)
2454 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2455 cv = get_cv(sym, TRUE);
2459 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2460 tryAMAGICunDEREF(to_cv);
2463 if (SvTYPE(cv) == SVt_PVCV)
2468 DIE(aTHX_ "Not a CODE reference");
2473 if (!(cv = GvCVu((GV*)sv)))
2474 cv = sv_2cv(sv, &stash, &gv, FALSE);
2487 if (!CvROOT(cv) && !CvXSUB(cv)) {
2491 /* anonymous or undef'd function leaves us no recourse */
2492 if (CvANON(cv) || !(gv = CvGV(cv)))
2493 DIE(aTHX_ "Undefined subroutine called");
2495 /* autoloaded stub? */
2496 if (cv != GvCV(gv)) {
2499 /* should call AUTOLOAD now? */
2502 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2509 sub_name = sv_newmortal();
2510 gv_efullname3(sub_name, gv, Nullch);
2511 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2515 DIE(aTHX_ "Not a CODE reference");
2520 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2521 cv = get_db_sub(&sv, cv);
2523 DIE(aTHX_ "No DBsub routine");
2528 * First we need to check if the sub or method requires locking.
2529 * If so, we gain a lock on the CV, the first argument or the
2530 * stash (for static methods), as appropriate. This has to be
2531 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2532 * reschedule by returning a new op.
2534 MUTEX_LOCK(CvMUTEXP(cv));
2535 if (CvFLAGS(cv) & CVf_LOCKED) {
2537 if (CvFLAGS(cv) & CVf_METHOD) {
2538 if (SP > PL_stack_base + TOPMARK)
2539 sv = *(PL_stack_base + TOPMARK + 1);
2541 AV *av = (AV*)PL_curpad[0];
2542 if (hasargs || !av || AvFILLp(av) < 0
2543 || !(sv = AvARRAY(av)[0]))
2545 MUTEX_UNLOCK(CvMUTEXP(cv));
2546 DIE(aTHX_ "no argument for locked method call");
2553 char *stashname = SvPV(sv, len);
2554 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2560 MUTEX_UNLOCK(CvMUTEXP(cv));
2561 mg = condpair_magic(sv);
2562 MUTEX_LOCK(MgMUTEXP(mg));
2563 if (MgOWNER(mg) == thr)
2564 MUTEX_UNLOCK(MgMUTEXP(mg));
2567 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2569 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2571 MUTEX_UNLOCK(MgMUTEXP(mg));
2572 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2574 MUTEX_LOCK(CvMUTEXP(cv));
2577 * Now we have permission to enter the sub, we must distinguish
2578 * four cases. (0) It's an XSUB (in which case we don't care
2579 * about ownership); (1) it's ours already (and we're recursing);
2580 * (2) it's free (but we may already be using a cached clone);
2581 * (3) another thread owns it. Case (1) is easy: we just use it.
2582 * Case (2) means we look for a clone--if we have one, use it
2583 * otherwise grab ownership of cv. Case (3) means we look for a
2584 * clone (for non-XSUBs) and have to create one if we don't
2586 * Why look for a clone in case (2) when we could just grab
2587 * ownership of cv straight away? Well, we could be recursing,
2588 * i.e. we originally tried to enter cv while another thread
2589 * owned it (hence we used a clone) but it has been freed up
2590 * and we're now recursing into it. It may or may not be "better"
2591 * to use the clone but at least CvDEPTH can be trusted.
2593 if (CvOWNER(cv) == thr || CvXSUB(cv))
2594 MUTEX_UNLOCK(CvMUTEXP(cv));
2596 /* Case (2) or (3) */
2600 * XXX Might it be better to release CvMUTEXP(cv) while we
2601 * do the hv_fetch? We might find someone has pinched it
2602 * when we look again, in which case we would be in case
2603 * (3) instead of (2) so we'd have to clone. Would the fact
2604 * that we released the mutex more quickly make up for this?
2606 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2608 /* We already have a clone to use */
2609 MUTEX_UNLOCK(CvMUTEXP(cv));
2611 DEBUG_S(PerlIO_printf(Perl_debug_log,
2612 "entersub: %p already has clone %p:%s\n",
2613 thr, cv, SvPEEK((SV*)cv)));
2616 if (CvDEPTH(cv) == 0)
2617 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2620 /* (2) => grab ownership of cv. (3) => make clone */
2624 MUTEX_UNLOCK(CvMUTEXP(cv));
2625 DEBUG_S(PerlIO_printf(Perl_debug_log,
2626 "entersub: %p grabbing %p:%s in stash %s\n",
2627 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2628 HvNAME(CvSTASH(cv)) : "(none)"));
2631 /* Make a new clone. */
2633 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2634 MUTEX_UNLOCK(CvMUTEXP(cv));
2635 DEBUG_S((PerlIO_printf(Perl_debug_log,
2636 "entersub: %p cloning %p:%s\n",
2637 thr, cv, SvPEEK((SV*)cv))));
2639 * We're creating a new clone so there's no race
2640 * between the original MUTEX_UNLOCK and the
2641 * SvREFCNT_inc since no one will be trying to undef
2642 * it out from underneath us. At least, I don't think
2645 clonecv = cv_clone(cv);
2646 SvREFCNT_dec(cv); /* finished with this */
2647 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2648 CvOWNER(clonecv) = thr;
2652 DEBUG_S(if (CvDEPTH(cv) != 0)
2653 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2655 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2658 #endif /* USE_THREADS */
2661 #ifdef PERL_XSUB_OLDSTYLE
2662 if (CvOLDSTYLE(cv)) {
2663 I32 (*fp3)(int,int,int);
2665 register I32 items = SP - MARK;
2666 /* We dont worry to copy from @_. */
2671 PL_stack_sp = mark + 1;
2672 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2673 items = (*fp3)(CvXSUBANY(cv).any_i32,
2674 MARK - PL_stack_base + 1,
2676 PL_stack_sp = PL_stack_base + items;
2679 #endif /* PERL_XSUB_OLDSTYLE */
2681 I32 markix = TOPMARK;
2686 /* Need to copy @_ to stack. Alternative may be to
2687 * switch stack to @_, and copy return values
2688 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2692 av = (AV*)PL_curpad[0];
2694 av = GvAV(PL_defgv);
2695 #endif /* USE_THREADS */
2696 items = AvFILLp(av) + 1; /* @_ is not tieable */
2699 /* Mark is at the end of the stack. */
2701 Copy(AvARRAY(av), SP + 1, items, SV*);
2706 /* We assume first XSUB in &DB::sub is the called one. */
2708 SAVEVPTR(PL_curcop);
2709 PL_curcop = PL_curcopdb;
2712 /* Do we need to open block here? XXXX */
2713 (void)(*CvXSUB(cv))(aTHXo_ cv);
2715 /* Enforce some sanity in scalar context. */
2716 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2717 if (markix > PL_stack_sp - PL_stack_base)
2718 *(PL_stack_base + markix) = &PL_sv_undef;
2720 *(PL_stack_base + markix) = *PL_stack_sp;
2721 PL_stack_sp = PL_stack_base + markix;
2729 register I32 items = SP - MARK;
2730 AV* padlist = CvPADLIST(cv);
2731 SV** svp = AvARRAY(padlist);
2732 push_return(PL_op->op_next);
2733 PUSHBLOCK(cx, CXt_SUB, MARK);
2736 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2737 * that eval'' ops within this sub know the correct lexical space.
2738 * Owing the speed considerations, we choose to search for the cv
2739 * in doeval() instead.
2741 if (CvDEPTH(cv) < 2)
2742 (void)SvREFCNT_inc(cv);
2743 else { /* save temporaries on recursion? */
2744 PERL_STACK_OVERFLOW_CHECK();
2745 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2747 AV *newpad = newAV();
2748 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2749 I32 ix = AvFILLp((AV*)svp[1]);
2750 I32 names_fill = AvFILLp((AV*)svp[0]);
2751 svp = AvARRAY(svp[0]);
2752 for ( ;ix > 0; ix--) {
2753 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2754 char *name = SvPVX(svp[ix]);
2755 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2756 || *name == '&') /* anonymous code? */
2758 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2760 else { /* our own lexical */
2762 av_store(newpad, ix, sv = (SV*)newAV());
2763 else if (*name == '%')
2764 av_store(newpad, ix, sv = (SV*)newHV());
2766 av_store(newpad, ix, sv = NEWSV(0,0));
2770 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2771 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2774 av_store(newpad, ix, sv = NEWSV(0,0));
2778 av = newAV(); /* will be @_ */
2780 av_store(newpad, 0, (SV*)av);
2781 AvFLAGS(av) = AVf_REIFY;
2782 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2783 AvFILLp(padlist) = CvDEPTH(cv);
2784 svp = AvARRAY(padlist);
2789 AV* av = (AV*)PL_curpad[0];
2791 items = AvFILLp(av) + 1;
2793 /* Mark is at the end of the stack. */
2795 Copy(AvARRAY(av), SP + 1, items, SV*);
2800 #endif /* USE_THREADS */
2801 SAVEVPTR(PL_curpad);
2802 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2805 #endif /* USE_THREADS */
2811 DEBUG_S(PerlIO_printf(Perl_debug_log,
2812 "%p entersub preparing @_\n", thr));
2814 av = (AV*)PL_curpad[0];
2816 /* @_ is normally not REAL--this should only ever
2817 * happen when DB::sub() calls things that modify @_ */
2823 cx->blk_sub.savearray = GvAV(PL_defgv);
2824 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2825 #endif /* USE_THREADS */
2826 cx->blk_sub.oldcurpad = PL_curpad;
2827 cx->blk_sub.argarray = av;
2830 if (items > AvMAX(av) + 1) {
2832 if (AvARRAY(av) != ary) {
2833 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2834 SvPVX(av) = (char*)ary;
2836 if (items > AvMAX(av) + 1) {
2837 AvMAX(av) = items - 1;
2838 Renew(ary,items,SV*);
2840 SvPVX(av) = (char*)ary;
2843 Copy(MARK,AvARRAY(av),items,SV*);
2844 AvFILLp(av) = items - 1;
2852 /* warning must come *after* we fully set up the context
2853 * stuff so that __WARN__ handlers can safely dounwind()
2856 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2857 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2858 sub_crush_depth(cv);
2860 DEBUG_S(PerlIO_printf(Perl_debug_log,
2861 "%p entersub returning %p\n", thr, CvSTART(cv)));
2863 RETURNOP(CvSTART(cv));
2868 Perl_sub_crush_depth(pTHX_ CV *cv)
2871 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2873 SV* tmpstr = sv_newmortal();
2874 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2875 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2885 IV elem = SvIV(elemsv);
2887 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2888 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2891 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2892 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2894 elem -= PL_curcop->cop_arybase;
2895 if (SvTYPE(av) != SVt_PVAV)
2897 svp = av_fetch(av, elem, lval && !defer);
2899 if (!svp || *svp == &PL_sv_undef) {
2902 DIE(aTHX_ PL_no_aelem, elem);
2903 lv = sv_newmortal();
2904 sv_upgrade(lv, SVt_PVLV);
2906 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2907 LvTARG(lv) = SvREFCNT_inc(av);
2908 LvTARGOFF(lv) = elem;
2913 if (PL_op->op_private & OPpLVAL_INTRO)
2914 save_aelem(av, elem, svp);
2915 else if (PL_op->op_private & OPpDEREF)
2916 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2918 sv = (svp ? *svp : &PL_sv_undef);
2919 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2920 sv = sv_mortalcopy(sv);
2926 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2932 Perl_croak(aTHX_ PL_no_modify);
2933 if (SvTYPE(sv) < SVt_RV)
2934 sv_upgrade(sv, SVt_RV);
2935 else if (SvTYPE(sv) >= SVt_PV) {
2936 (void)SvOOK_off(sv);
2937 Safefree(SvPVX(sv));
2938 SvLEN(sv) = SvCUR(sv) = 0;
2942 SvRV(sv) = NEWSV(355,0);
2945 SvRV(sv) = (SV*)newAV();
2948 SvRV(sv) = (SV*)newHV();
2963 if (SvTYPE(rsv) == SVt_PVCV) {
2969 SETs(method_common(sv, Null(U32*)));
2976 SV* sv = cSVOP->op_sv;
2977 U32 hash = SvUVX(sv);
2979 XPUSHs(method_common(sv, &hash));
2984 S_method_common(pTHX_ SV* meth, U32* hashp)
2995 name = SvPV(meth, namelen);
2996 sv = *(PL_stack_base + TOPMARK + 1);
2999 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3008 /* this isn't a reference */
3011 !(packname = SvPV(sv, packlen)) ||
3012 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3013 !(ob=(SV*)GvIO(iogv)))
3015 /* this isn't the name of a filehandle either */
3017 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3018 ? !isIDFIRST_utf8((U8*)packname)
3019 : !isIDFIRST(*packname)
3022 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3023 SvOK(sv) ? "without a package or object reference"
3024 : "on an undefined value");
3026 /* assume it's a package name */
3027 stash = gv_stashpvn(packname, packlen, FALSE);
3030 /* it _is_ a filehandle name -- replace with a reference */
3031 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3034 /* if we got here, ob should be a reference or a glob */
3035 if (!ob || !(SvOBJECT(ob)
3036 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3039 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3043 stash = SvSTASH(ob);
3046 /* NOTE: stash may be null, hope hv_fetch_ent and
3047 gv_fetchmethod can cope (it seems they can) */
3049 /* shortcut for simple names */
3051 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3053 gv = (GV*)HeVAL(he);
3054 if (isGV(gv) && GvCV(gv) &&
3055 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3056 return (SV*)GvCV(gv);
3060 gv = gv_fetchmethod(stash, name);
3063 /* This code tries to figure out just what went wrong with
3064 gv_fetchmethod. It therefore needs to duplicate a lot of
3065 the internals of that function. We can't move it inside
3066 Perl_gv_fetchmethod_autoload(), however, since that would
3067 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3074 for (p = name; *p; p++) {
3076 sep = p, leaf = p + 1;
3077 else if (*p == ':' && *(p + 1) == ':')
3078 sep = p, leaf = p + 2;
3080 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3081 /* the method name is unqualified or starts with SUPER:: */
3082 packname = sep ? CopSTASHPV(PL_curcop) :
3083 stash ? HvNAME(stash) : packname;
3084 packlen = strlen(packname);
3087 /* the method name is qualified */
3089 packlen = sep - name;
3092 /* we're relying on gv_fetchmethod not autovivifying the stash */
3093 if (gv_stashpvn(packname, packlen, FALSE)) {
3095 "Can't locate object method \"%s\" via package \"%.*s\"",
3096 leaf, (int)packlen, packname);
3100 "Can't locate object method \"%s\" via package \"%.*s\""
3101 " (perhaps you forgot to load \"%.*s\"?)",
3102 leaf, (int)packlen, packname, (int)packlen, packname);
3105 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3110 unset_cvowner(pTHXo_ void *cvarg)
3112 register CV* cv = (CV *) cvarg;
3114 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3115 thr, cv, SvPEEK((SV*)cv))));
3116 MUTEX_LOCK(CvMUTEXP(cv));
3117 DEBUG_S(if (CvDEPTH(cv) != 0)
3118 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3120 assert(thr == CvOWNER(cv));
3122 MUTEX_UNLOCK(CvMUTEXP(cv));
3125 #endif /* USE_THREADS */