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);
1331 if (DO_UTF8(TARG) && is_utf8_string((U8*)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)) {
2449 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2452 sym = SvPV(sv, n_a);
2454 DIE(aTHX_ PL_no_usym, "a subroutine");
2455 if (PL_op->op_private & HINT_STRICT_REFS)
2456 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2457 cv = get_cv(sym, TRUE);
2462 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2463 tryAMAGICunDEREF(to_cv);
2466 if (SvTYPE(cv) == SVt_PVCV)
2471 DIE(aTHX_ "Not a CODE reference");
2476 if (!(cv = GvCVu((GV*)sv)))
2477 cv = sv_2cv(sv, &stash, &gv, FALSE);
2490 if (!CvROOT(cv) && !CvXSUB(cv)) {
2494 /* anonymous or undef'd function leaves us no recourse */
2495 if (CvANON(cv) || !(gv = CvGV(cv)))
2496 DIE(aTHX_ "Undefined subroutine called");
2498 /* autoloaded stub? */
2499 if (cv != GvCV(gv)) {
2502 /* should call AUTOLOAD now? */
2505 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2512 sub_name = sv_newmortal();
2513 gv_efullname3(sub_name, gv, Nullch);
2514 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2518 DIE(aTHX_ "Not a CODE reference");
2523 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2524 cv = get_db_sub(&sv, cv);
2526 DIE(aTHX_ "No DBsub routine");
2531 * First we need to check if the sub or method requires locking.
2532 * If so, we gain a lock on the CV, the first argument or the
2533 * stash (for static methods), as appropriate. This has to be
2534 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2535 * reschedule by returning a new op.
2537 MUTEX_LOCK(CvMUTEXP(cv));
2538 if (CvFLAGS(cv) & CVf_LOCKED) {
2540 if (CvFLAGS(cv) & CVf_METHOD) {
2541 if (SP > PL_stack_base + TOPMARK)
2542 sv = *(PL_stack_base + TOPMARK + 1);
2544 AV *av = (AV*)PL_curpad[0];
2545 if (hasargs || !av || AvFILLp(av) < 0
2546 || !(sv = AvARRAY(av)[0]))
2548 MUTEX_UNLOCK(CvMUTEXP(cv));
2549 DIE(aTHX_ "no argument for locked method call");
2556 char *stashname = SvPV(sv, len);
2557 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2563 MUTEX_UNLOCK(CvMUTEXP(cv));
2564 mg = condpair_magic(sv);
2565 MUTEX_LOCK(MgMUTEXP(mg));
2566 if (MgOWNER(mg) == thr)
2567 MUTEX_UNLOCK(MgMUTEXP(mg));
2570 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2572 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2574 MUTEX_UNLOCK(MgMUTEXP(mg));
2575 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2577 MUTEX_LOCK(CvMUTEXP(cv));
2580 * Now we have permission to enter the sub, we must distinguish
2581 * four cases. (0) It's an XSUB (in which case we don't care
2582 * about ownership); (1) it's ours already (and we're recursing);
2583 * (2) it's free (but we may already be using a cached clone);
2584 * (3) another thread owns it. Case (1) is easy: we just use it.
2585 * Case (2) means we look for a clone--if we have one, use it
2586 * otherwise grab ownership of cv. Case (3) means we look for a
2587 * clone (for non-XSUBs) and have to create one if we don't
2589 * Why look for a clone in case (2) when we could just grab
2590 * ownership of cv straight away? Well, we could be recursing,
2591 * i.e. we originally tried to enter cv while another thread
2592 * owned it (hence we used a clone) but it has been freed up
2593 * and we're now recursing into it. It may or may not be "better"
2594 * to use the clone but at least CvDEPTH can be trusted.
2596 if (CvOWNER(cv) == thr || CvXSUB(cv))
2597 MUTEX_UNLOCK(CvMUTEXP(cv));
2599 /* Case (2) or (3) */
2603 * XXX Might it be better to release CvMUTEXP(cv) while we
2604 * do the hv_fetch? We might find someone has pinched it
2605 * when we look again, in which case we would be in case
2606 * (3) instead of (2) so we'd have to clone. Would the fact
2607 * that we released the mutex more quickly make up for this?
2609 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2611 /* We already have a clone to use */
2612 MUTEX_UNLOCK(CvMUTEXP(cv));
2614 DEBUG_S(PerlIO_printf(Perl_debug_log,
2615 "entersub: %p already has clone %p:%s\n",
2616 thr, cv, SvPEEK((SV*)cv)));
2619 if (CvDEPTH(cv) == 0)
2620 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2623 /* (2) => grab ownership of cv. (3) => make clone */
2627 MUTEX_UNLOCK(CvMUTEXP(cv));
2628 DEBUG_S(PerlIO_printf(Perl_debug_log,
2629 "entersub: %p grabbing %p:%s in stash %s\n",
2630 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2631 HvNAME(CvSTASH(cv)) : "(none)"));
2634 /* Make a new clone. */
2636 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2637 MUTEX_UNLOCK(CvMUTEXP(cv));
2638 DEBUG_S((PerlIO_printf(Perl_debug_log,
2639 "entersub: %p cloning %p:%s\n",
2640 thr, cv, SvPEEK((SV*)cv))));
2642 * We're creating a new clone so there's no race
2643 * between the original MUTEX_UNLOCK and the
2644 * SvREFCNT_inc since no one will be trying to undef
2645 * it out from underneath us. At least, I don't think
2648 clonecv = cv_clone(cv);
2649 SvREFCNT_dec(cv); /* finished with this */
2650 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2651 CvOWNER(clonecv) = thr;
2655 DEBUG_S(if (CvDEPTH(cv) != 0)
2656 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2658 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2661 #endif /* USE_THREADS */
2664 #ifdef PERL_XSUB_OLDSTYLE
2665 if (CvOLDSTYLE(cv)) {
2666 I32 (*fp3)(int,int,int);
2668 register I32 items = SP - MARK;
2669 /* We dont worry to copy from @_. */
2674 PL_stack_sp = mark + 1;
2675 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2676 items = (*fp3)(CvXSUBANY(cv).any_i32,
2677 MARK - PL_stack_base + 1,
2679 PL_stack_sp = PL_stack_base + items;
2682 #endif /* PERL_XSUB_OLDSTYLE */
2684 I32 markix = TOPMARK;
2689 /* Need to copy @_ to stack. Alternative may be to
2690 * switch stack to @_, and copy return values
2691 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2695 av = (AV*)PL_curpad[0];
2697 av = GvAV(PL_defgv);
2698 #endif /* USE_THREADS */
2699 items = AvFILLp(av) + 1; /* @_ is not tieable */
2702 /* Mark is at the end of the stack. */
2704 Copy(AvARRAY(av), SP + 1, items, SV*);
2709 /* We assume first XSUB in &DB::sub is the called one. */
2711 SAVEVPTR(PL_curcop);
2712 PL_curcop = PL_curcopdb;
2715 /* Do we need to open block here? XXXX */
2716 (void)(*CvXSUB(cv))(aTHXo_ cv);
2718 /* Enforce some sanity in scalar context. */
2719 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2720 if (markix > PL_stack_sp - PL_stack_base)
2721 *(PL_stack_base + markix) = &PL_sv_undef;
2723 *(PL_stack_base + markix) = *PL_stack_sp;
2724 PL_stack_sp = PL_stack_base + markix;
2732 register I32 items = SP - MARK;
2733 AV* padlist = CvPADLIST(cv);
2734 SV** svp = AvARRAY(padlist);
2735 push_return(PL_op->op_next);
2736 PUSHBLOCK(cx, CXt_SUB, MARK);
2739 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2740 * that eval'' ops within this sub know the correct lexical space.
2741 * Owing the speed considerations, we choose to search for the cv
2742 * in doeval() instead.
2744 if (CvDEPTH(cv) < 2)
2745 (void)SvREFCNT_inc(cv);
2746 else { /* save temporaries on recursion? */
2747 PERL_STACK_OVERFLOW_CHECK();
2748 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2750 AV *newpad = newAV();
2751 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2752 I32 ix = AvFILLp((AV*)svp[1]);
2753 I32 names_fill = AvFILLp((AV*)svp[0]);
2754 svp = AvARRAY(svp[0]);
2755 for ( ;ix > 0; ix--) {
2756 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2757 char *name = SvPVX(svp[ix]);
2758 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2759 || *name == '&') /* anonymous code? */
2761 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2763 else { /* our own lexical */
2765 av_store(newpad, ix, sv = (SV*)newAV());
2766 else if (*name == '%')
2767 av_store(newpad, ix, sv = (SV*)newHV());
2769 av_store(newpad, ix, sv = NEWSV(0,0));
2773 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2774 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2777 av_store(newpad, ix, sv = NEWSV(0,0));
2781 av = newAV(); /* will be @_ */
2783 av_store(newpad, 0, (SV*)av);
2784 AvFLAGS(av) = AVf_REIFY;
2785 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2786 AvFILLp(padlist) = CvDEPTH(cv);
2787 svp = AvARRAY(padlist);
2792 AV* av = (AV*)PL_curpad[0];
2794 items = AvFILLp(av) + 1;
2796 /* Mark is at the end of the stack. */
2798 Copy(AvARRAY(av), SP + 1, items, SV*);
2803 #endif /* USE_THREADS */
2804 SAVEVPTR(PL_curpad);
2805 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2808 #endif /* USE_THREADS */
2814 DEBUG_S(PerlIO_printf(Perl_debug_log,
2815 "%p entersub preparing @_\n", thr));
2817 av = (AV*)PL_curpad[0];
2819 /* @_ is normally not REAL--this should only ever
2820 * happen when DB::sub() calls things that modify @_ */
2826 cx->blk_sub.savearray = GvAV(PL_defgv);
2827 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2828 #endif /* USE_THREADS */
2829 cx->blk_sub.oldcurpad = PL_curpad;
2830 cx->blk_sub.argarray = av;
2833 if (items > AvMAX(av) + 1) {
2835 if (AvARRAY(av) != ary) {
2836 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2837 SvPVX(av) = (char*)ary;
2839 if (items > AvMAX(av) + 1) {
2840 AvMAX(av) = items - 1;
2841 Renew(ary,items,SV*);
2843 SvPVX(av) = (char*)ary;
2846 Copy(MARK,AvARRAY(av),items,SV*);
2847 AvFILLp(av) = items - 1;
2855 /* warning must come *after* we fully set up the context
2856 * stuff so that __WARN__ handlers can safely dounwind()
2859 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2860 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2861 sub_crush_depth(cv);
2863 DEBUG_S(PerlIO_printf(Perl_debug_log,
2864 "%p entersub returning %p\n", thr, CvSTART(cv)));
2866 RETURNOP(CvSTART(cv));
2871 Perl_sub_crush_depth(pTHX_ CV *cv)
2874 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2876 SV* tmpstr = sv_newmortal();
2877 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2878 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2888 IV elem = SvIV(elemsv);
2890 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2891 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2894 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2895 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2897 elem -= PL_curcop->cop_arybase;
2898 if (SvTYPE(av) != SVt_PVAV)
2900 svp = av_fetch(av, elem, lval && !defer);
2902 if (!svp || *svp == &PL_sv_undef) {
2905 DIE(aTHX_ PL_no_aelem, elem);
2906 lv = sv_newmortal();
2907 sv_upgrade(lv, SVt_PVLV);
2909 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2910 LvTARG(lv) = SvREFCNT_inc(av);
2911 LvTARGOFF(lv) = elem;
2916 if (PL_op->op_private & OPpLVAL_INTRO)
2917 save_aelem(av, elem, svp);
2918 else if (PL_op->op_private & OPpDEREF)
2919 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2921 sv = (svp ? *svp : &PL_sv_undef);
2922 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2923 sv = sv_mortalcopy(sv);
2929 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2935 Perl_croak(aTHX_ PL_no_modify);
2936 if (SvTYPE(sv) < SVt_RV)
2937 sv_upgrade(sv, SVt_RV);
2938 else if (SvTYPE(sv) >= SVt_PV) {
2939 (void)SvOOK_off(sv);
2940 Safefree(SvPVX(sv));
2941 SvLEN(sv) = SvCUR(sv) = 0;
2945 SvRV(sv) = NEWSV(355,0);
2948 SvRV(sv) = (SV*)newAV();
2951 SvRV(sv) = (SV*)newHV();
2966 if (SvTYPE(rsv) == SVt_PVCV) {
2972 SETs(method_common(sv, Null(U32*)));
2979 SV* sv = cSVOP->op_sv;
2980 U32 hash = SvUVX(sv);
2982 XPUSHs(method_common(sv, &hash));
2987 S_method_common(pTHX_ SV* meth, U32* hashp)
2998 name = SvPV(meth, namelen);
2999 sv = *(PL_stack_base + TOPMARK + 1);
3002 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3011 /* this isn't a reference */
3014 !(packname = SvPV(sv, packlen)) ||
3015 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3016 !(ob=(SV*)GvIO(iogv)))
3018 /* this isn't the name of a filehandle either */
3020 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3021 ? !isIDFIRST_utf8((U8*)packname)
3022 : !isIDFIRST(*packname)
3025 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3026 SvOK(sv) ? "without a package or object reference"
3027 : "on an undefined value");
3029 /* assume it's a package name */
3030 stash = gv_stashpvn(packname, packlen, FALSE);
3033 /* it _is_ a filehandle name -- replace with a reference */
3034 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3037 /* if we got here, ob should be a reference or a glob */
3038 if (!ob || !(SvOBJECT(ob)
3039 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3042 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3046 stash = SvSTASH(ob);
3049 /* NOTE: stash may be null, hope hv_fetch_ent and
3050 gv_fetchmethod can cope (it seems they can) */
3052 /* shortcut for simple names */
3054 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3056 gv = (GV*)HeVAL(he);
3057 if (isGV(gv) && GvCV(gv) &&
3058 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3059 return (SV*)GvCV(gv);
3063 gv = gv_fetchmethod(stash, name);
3066 /* This code tries to figure out just what went wrong with
3067 gv_fetchmethod. It therefore needs to duplicate a lot of
3068 the internals of that function. We can't move it inside
3069 Perl_gv_fetchmethod_autoload(), however, since that would
3070 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3077 for (p = name; *p; p++) {
3079 sep = p, leaf = p + 1;
3080 else if (*p == ':' && *(p + 1) == ':')
3081 sep = p, leaf = p + 2;
3083 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3084 /* the method name is unqualified or starts with SUPER:: */
3085 packname = sep ? CopSTASHPV(PL_curcop) :
3086 stash ? HvNAME(stash) : packname;
3087 packlen = strlen(packname);
3090 /* the method name is qualified */
3092 packlen = sep - name;
3095 /* we're relying on gv_fetchmethod not autovivifying the stash */
3096 if (gv_stashpvn(packname, packlen, FALSE)) {
3098 "Can't locate object method \"%s\" via package \"%.*s\"",
3099 leaf, (int)packlen, packname);
3103 "Can't locate object method \"%s\" via package \"%.*s\""
3104 " (perhaps you forgot to load \"%.*s\"?)",
3105 leaf, (int)packlen, packname, (int)packlen, packname);
3108 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3113 unset_cvowner(pTHXo_ void *cvarg)
3115 register CV* cv = (CV *) cvarg;
3117 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3118 thr, cv, SvPEEK((SV*)cv))));
3119 MUTEX_LOCK(CvMUTEXP(cv));
3120 DEBUG_S(if (CvDEPTH(cv) != 0)
3121 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3123 assert(thr == CvOWNER(cv));
3125 MUTEX_UNLOCK(CvMUTEXP(cv));
3128 #endif /* USE_THREADS */