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);
147 if (SvGMAGICAL(left))
149 if (TARG == right && SvGMAGICAL(right))
152 if (TARG == right && left != right)
153 /* Clone since otherwise we cannot prepend. */
154 rcopy = sv_2mortal(newSVsv(right));
157 sv_setsv(TARG, left);
159 #if defined(PERL_Y2KWARN)
160 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
162 char *s = SvPV(TARG,n);
163 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
164 && (n == 2 || !isDIGIT(s[n-3])))
166 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
167 "about to append an integer to '19'");
174 /* $right = $right . $right; */
176 char *rpv = SvPV(right, rlen);
178 sv_catpvn(TARG, rpv, rlen);
180 else /* $right = $left . $right; */
181 sv_catsv(TARG, rcopy);
184 if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
186 /* $other = $left . $right; */
187 /* $left = $left . $right; */
188 sv_catsv(TARG, right);
200 if (PL_op->op_flags & OPf_MOD) {
201 if (PL_op->op_private & OPpLVAL_INTRO)
202 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
203 else if (PL_op->op_private & OPpDEREF) {
205 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
214 tryAMAGICunTARGET(iter, 0);
215 PL_last_in_gv = (GV*)(*PL_stack_sp--);
216 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
217 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
218 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
221 XPUSHs((SV*)PL_last_in_gv);
224 PL_last_in_gv = (GV*)(*PL_stack_sp--);
227 return do_readline();
232 dSP; tryAMAGICbinSET(eq,0);
233 #ifndef NV_PRESERVES_UV
234 if (SvROK(TOPs) && SvROK(TOPm1s)) {
235 SETs(boolSV(SvRV(TOPs) == SvRV(TOPm1s)));
239 #ifdef PERL_PRESERVE_IVUV
242 /* Unless the left argument is integer in range we are going
243 to have to use NV maths. Hence only attempt to coerce the
244 right argument if we know the left is integer. */
247 bool auvok = SvUOK(TOPm1s);
248 bool buvok = SvUOK(TOPs);
250 if (!auvok && !buvok) { /* ## IV == IV ## */
251 IV aiv = SvIVX(TOPm1s);
252 IV biv = SvIVX(TOPs);
255 SETs(boolSV(aiv == biv));
258 if (auvok && buvok) { /* ## UV == UV ## */
259 UV auv = SvUVX(TOPm1s);
260 UV buv = SvUVX(TOPs);
263 SETs(boolSV(auv == buv));
266 { /* ## Mixed IV,UV ## */
270 /* == is commutative so swap if needed (save code) */
272 /* swap. top of stack (b) is the iv */
276 /* As (a) is a UV, it's >0, so it cannot be == */
285 /* As (b) is a UV, it's >0, so it cannot be == */
289 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
291 /* we know iv is >= 0 */
292 if (uv > (UV) IV_MAX) {
296 SETs(boolSV((UV)iv == uv));
304 SETs(boolSV(TOPn == value));
312 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
313 DIE(aTHX_ PL_no_modify);
314 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
315 SvIVX(TOPs) != IV_MAX)
318 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
320 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
333 RETURNOP(cLOGOP->op_other);
339 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
340 useleft = USE_LEFT(TOPm1s);
341 #ifdef PERL_PRESERVE_IVUV
342 /* We must see if we can perform the addition with integers if possible,
343 as the integer code detects overflow while the NV code doesn't.
344 If either argument hasn't had a numeric conversion yet attempt to get
345 the IV. It's important to do this now, rather than just assuming that
346 it's not IOK as a PV of "9223372036854775806" may not take well to NV
347 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
348 integer in case the second argument is IV=9223372036854775806
349 We can (now) rely on sv_2iv to do the right thing, only setting the
350 public IOK flag if the value in the NV (or PV) slot is truly integer.
352 A side effect is that this also aggressively prefers integer maths over
353 fp maths for integer values.
355 How to detect overflow?
357 C 99 section 6.2.6.1 says
359 The range of nonnegative values of a signed integer type is a subrange
360 of the corresponding unsigned integer type, and the representation of
361 the same value in each type is the same. A computation involving
362 unsigned operands can never overflow, because a result that cannot be
363 represented by the resulting unsigned integer type is reduced modulo
364 the number that is one greater than the largest value that can be
365 represented by the resulting type.
369 which I read as "unsigned ints wrap."
371 signed integer overflow seems to be classed as "exception condition"
373 If an exceptional condition occurs during the evaluation of an
374 expression (that is, if the result is not mathematically defined or not
375 in the range of representable values for its type), the behavior is
378 (6.5, the 5th paragraph)
380 I had assumed that on 2s complement machines signed arithmetic would
381 wrap, hence coded pp_add and pp_subtract on the assumption that
382 everything perl builds on would be happy. After much wailing and
383 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
384 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
385 unsigned code below is actually shorter than the old code. :-)
390 /* Unless the left argument is integer in range we are going to have to
391 use NV maths. Hence only attempt to coerce the right argument if
392 we know the left is integer. */
400 /* left operand is undef, treat as zero. + 0 is identity,
401 Could SETi or SETu right now, but space optimise by not adding
402 lots of code to speed up what is probably a rarish case. */
404 /* Left operand is defined, so is it IV? */
407 if ((auvok = SvUOK(TOPm1s)))
410 register IV aiv = SvIVX(TOPm1s);
413 auvok = 1; /* Now acting as a sign flag. */
414 } else { /* 2s complement assumption for IV_MIN */
422 bool result_good = 0;
425 bool buvok = SvUOK(TOPs);
430 register IV biv = SvIVX(TOPs);
437 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
438 else "IV" now, independant of how it came in.
439 if a, b represents positive, A, B negative, a maps to -A etc
444 all UV maths. negate result if A negative.
445 add if signs same, subtract if signs differ. */
451 /* Must get smaller */
457 /* result really should be -(auv-buv). as its negation
458 of true value, need to swap our result flag */
475 if (result <= (UV)IV_MIN)
478 /* result valid, but out of range for IV. */
483 } /* Overflow, drop through to NVs. */
490 /* left operand is undef, treat as zero. + 0.0 is identity. */
494 SETn( value + TOPn );
502 AV *av = GvAV(cGVOP_gv);
503 U32 lval = PL_op->op_flags & OPf_MOD;
504 SV** svp = av_fetch(av, PL_op->op_private, lval);
505 SV *sv = (svp ? *svp : &PL_sv_undef);
507 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
508 sv = sv_mortalcopy(sv);
517 do_join(TARG, *MARK, MARK, SP);
528 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
529 * will be enough to hold an OP*.
531 SV* sv = sv_newmortal();
532 sv_upgrade(sv, SVt_PVLV);
534 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
542 /* Oversized hot code. */
546 dSP; dMARK; dORIGMARK;
552 if (PL_op->op_flags & OPf_STACKED)
556 if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
558 if (MARK == ORIGMARK) {
559 /* If using default handle then we need to make space to
560 * pass object as 1st arg, so move other args up ...
564 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
568 *MARK = SvTIED_obj((SV*)gv, mg);
571 call_method("PRINT", G_SCALAR);
579 if (!(io = GvIO(gv))) {
581 && (mg = SvTIED_mg((SV*)GvEGV(gv), PERL_MAGIC_tiedscalar)))
583 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
584 report_evil_fh(gv, io, PL_op->op_type);
585 SETERRNO(EBADF,RMS$_IFI);
588 else if (!(fp = IoOFP(io))) {
589 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
591 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
592 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
593 report_evil_fh(gv, io, PL_op->op_type);
595 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
600 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
602 if (!do_print(*MARK, fp))
606 if (!do_print(PL_ofs_sv, fp)) { /* $, */
615 if (!do_print(*MARK, fp))
623 if (PL_ors_sv && SvOK(PL_ors_sv))
624 if (!do_print(PL_ors_sv, fp)) /* $\ */
627 if (IoFLAGS(io) & IOf_FLUSH)
628 if (PerlIO_flush(fp) == EOF)
649 tryAMAGICunDEREF(to_av);
652 if (SvTYPE(av) != SVt_PVAV)
653 DIE(aTHX_ "Not an ARRAY reference");
654 if (PL_op->op_flags & OPf_REF) {
659 if (GIMME == G_SCALAR)
660 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
666 if (SvTYPE(sv) == SVt_PVAV) {
668 if (PL_op->op_flags & OPf_REF) {
673 if (GIMME == G_SCALAR)
674 Perl_croak(aTHX_ "Can't return array to lvalue"
683 if (SvTYPE(sv) != SVt_PVGV) {
687 if (SvGMAGICAL(sv)) {
693 if (PL_op->op_flags & OPf_REF ||
694 PL_op->op_private & HINT_STRICT_REFS)
695 DIE(aTHX_ PL_no_usym, "an ARRAY");
696 if (ckWARN(WARN_UNINITIALIZED))
698 if (GIMME == G_ARRAY) {
705 if ((PL_op->op_flags & OPf_SPECIAL) &&
706 !(PL_op->op_flags & OPf_MOD))
708 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
710 && (!is_gv_magical(sym,len,0)
711 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
717 if (PL_op->op_private & HINT_STRICT_REFS)
718 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
719 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
726 if (PL_op->op_private & OPpLVAL_INTRO)
728 if (PL_op->op_flags & OPf_REF) {
733 if (GIMME == G_SCALAR)
734 Perl_croak(aTHX_ "Can't return array to lvalue"
742 if (GIMME == G_ARRAY) {
743 I32 maxarg = AvFILL(av) + 1;
744 (void)POPs; /* XXXX May be optimized away? */
746 if (SvRMAGICAL(av)) {
748 for (i=0; i < maxarg; i++) {
749 SV **svp = av_fetch(av, i, FALSE);
750 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
754 Copy(AvARRAY(av), SP+1, maxarg, SV*);
760 I32 maxarg = AvFILL(av) + 1;
773 tryAMAGICunDEREF(to_hv);
776 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
777 DIE(aTHX_ "Not a HASH reference");
778 if (PL_op->op_flags & OPf_REF) {
783 if (GIMME == G_SCALAR)
784 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
790 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
792 if (PL_op->op_flags & OPf_REF) {
797 if (GIMME == G_SCALAR)
798 Perl_croak(aTHX_ "Can't return hash to lvalue"
807 if (SvTYPE(sv) != SVt_PVGV) {
811 if (SvGMAGICAL(sv)) {
817 if (PL_op->op_flags & OPf_REF ||
818 PL_op->op_private & HINT_STRICT_REFS)
819 DIE(aTHX_ PL_no_usym, "a HASH");
820 if (ckWARN(WARN_UNINITIALIZED))
822 if (GIMME == G_ARRAY) {
829 if ((PL_op->op_flags & OPf_SPECIAL) &&
830 !(PL_op->op_flags & OPf_MOD))
832 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
834 && (!is_gv_magical(sym,len,0)
835 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
841 if (PL_op->op_private & HINT_STRICT_REFS)
842 DIE(aTHX_ PL_no_symref, sym, "a HASH");
843 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
850 if (PL_op->op_private & OPpLVAL_INTRO)
852 if (PL_op->op_flags & OPf_REF) {
857 if (GIMME == G_SCALAR)
858 Perl_croak(aTHX_ "Can't return hash to lvalue"
866 if (GIMME == G_ARRAY) { /* array wanted */
867 *PL_stack_sp = (SV*)hv;
872 if (SvTYPE(hv) == SVt_PVAV)
873 hv = avhv_keys((AV*)hv);
875 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
876 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
886 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
892 leftop = ((BINOP*)PL_op)->op_last;
894 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
895 leftop = ((LISTOP*)leftop)->op_first;
897 /* Skip PUSHMARK and each element already assigned to. */
898 for (i = lelem - firstlelem; i > 0; i--) {
899 leftop = leftop->op_sibling;
902 if (leftop->op_type != OP_RV2HV)
907 av_fill(ary, 0); /* clear all but the fields hash */
908 if (lastrelem >= relem) {
909 while (relem < lastrelem) { /* gobble up all the rest */
913 /* Avoid a memory leak when avhv_store_ent dies. */
914 tmpstr = sv_newmortal();
915 sv_setsv(tmpstr,relem[1]); /* value */
917 if (avhv_store_ent(ary,relem[0],tmpstr,0))
918 (void)SvREFCNT_inc(tmpstr);
919 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
925 if (relem == lastrelem)
931 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
935 if (ckWARN(WARN_MISC)) {
936 if (relem == firstrelem &&
938 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
939 SvTYPE(SvRV(*relem)) == SVt_PVHV))
941 Perl_warner(aTHX_ WARN_MISC,
942 "Reference found where even-sized list expected");
945 Perl_warner(aTHX_ WARN_MISC,
946 "Odd number of elements in hash assignment");
948 if (SvTYPE(hash) == SVt_PVAV) {
950 tmpstr = sv_newmortal();
951 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
952 (void)SvREFCNT_inc(tmpstr);
953 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
958 tmpstr = NEWSV(29,0);
959 didstore = hv_store_ent(hash,*relem,tmpstr,0);
960 if (SvMAGICAL(hash)) {
961 if (SvSMAGICAL(tmpstr))
974 SV **lastlelem = PL_stack_sp;
975 SV **lastrelem = PL_stack_base + POPMARK;
976 SV **firstrelem = PL_stack_base + POPMARK + 1;
977 SV **firstlelem = lastrelem + 1;
990 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
992 /* If there's a common identifier on both sides we have to take
993 * special care that assigning the identifier on the left doesn't
994 * clobber a value on the right that's used later in the list.
996 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
997 EXTEND_MORTAL(lastrelem - firstrelem + 1);
998 for (relem = firstrelem; relem <= lastrelem; relem++) {
1000 if ((sv = *relem)) {
1001 TAINT_NOT; /* Each item is independent */
1002 *relem = sv_mortalcopy(sv);
1012 while (lelem <= lastlelem) {
1013 TAINT_NOT; /* Each item stands on its own, taintwise. */
1015 switch (SvTYPE(sv)) {
1018 magic = SvMAGICAL(ary) != 0;
1019 if (PL_op->op_private & OPpASSIGN_HASH) {
1020 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1026 do_oddball((HV*)ary, relem, firstrelem);
1028 relem = lastrelem + 1;
1033 av_extend(ary, lastrelem - relem);
1035 while (relem <= lastrelem) { /* gobble up all the rest */
1039 sv_setsv(sv,*relem);
1041 didstore = av_store(ary,i++,sv);
1051 case SVt_PVHV: { /* normal hash */
1055 magic = SvMAGICAL(hash) != 0;
1058 while (relem < lastrelem) { /* gobble up all the rest */
1063 sv = &PL_sv_no, relem++;
1064 tmpstr = NEWSV(29,0);
1066 sv_setsv(tmpstr,*relem); /* value */
1067 *(relem++) = tmpstr;
1068 didstore = hv_store_ent(hash,sv,tmpstr,0);
1070 if (SvSMAGICAL(tmpstr))
1077 if (relem == lastrelem) {
1078 do_oddball(hash, relem, firstrelem);
1084 if (SvIMMORTAL(sv)) {
1085 if (relem <= lastrelem)
1089 if (relem <= lastrelem) {
1090 sv_setsv(sv, *relem);
1094 sv_setsv(sv, &PL_sv_undef);
1099 if (PL_delaymagic & ~DM_DELAY) {
1100 if (PL_delaymagic & DM_UID) {
1101 #ifdef HAS_SETRESUID
1102 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1104 # ifdef HAS_SETREUID
1105 (void)setreuid(PL_uid,PL_euid);
1108 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1109 (void)setruid(PL_uid);
1110 PL_delaymagic &= ~DM_RUID;
1112 # endif /* HAS_SETRUID */
1114 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1115 (void)seteuid(PL_uid);
1116 PL_delaymagic &= ~DM_EUID;
1118 # endif /* HAS_SETEUID */
1119 if (PL_delaymagic & DM_UID) {
1120 if (PL_uid != PL_euid)
1121 DIE(aTHX_ "No setreuid available");
1122 (void)PerlProc_setuid(PL_uid);
1124 # endif /* HAS_SETREUID */
1125 #endif /* HAS_SETRESUID */
1126 PL_uid = PerlProc_getuid();
1127 PL_euid = PerlProc_geteuid();
1129 if (PL_delaymagic & DM_GID) {
1130 #ifdef HAS_SETRESGID
1131 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1133 # ifdef HAS_SETREGID
1134 (void)setregid(PL_gid,PL_egid);
1137 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1138 (void)setrgid(PL_gid);
1139 PL_delaymagic &= ~DM_RGID;
1141 # endif /* HAS_SETRGID */
1143 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1144 (void)setegid(PL_gid);
1145 PL_delaymagic &= ~DM_EGID;
1147 # endif /* HAS_SETEGID */
1148 if (PL_delaymagic & DM_GID) {
1149 if (PL_gid != PL_egid)
1150 DIE(aTHX_ "No setregid available");
1151 (void)PerlProc_setgid(PL_gid);
1153 # endif /* HAS_SETREGID */
1154 #endif /* HAS_SETRESGID */
1155 PL_gid = PerlProc_getgid();
1156 PL_egid = PerlProc_getegid();
1158 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1163 if (gimme == G_VOID)
1164 SP = firstrelem - 1;
1165 else if (gimme == G_SCALAR) {
1168 SETi(lastrelem - firstrelem + 1);
1174 SP = firstrelem + (lastlelem - firstlelem);
1175 lelem = firstlelem + (relem - firstrelem);
1177 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1185 register PMOP *pm = cPMOP;
1186 SV *rv = sv_newmortal();
1187 SV *sv = newSVrv(rv, "Regexp");
1188 sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp), PERL_MAGIC_qr,0,0);
1195 register PMOP *pm = cPMOP;
1200 I32 r_flags = REXEC_CHECKED;
1201 char *truebase; /* Start of string */
1202 register REGEXP *rx = pm->op_pmregexp;
1207 I32 oldsave = PL_savestack_ix;
1208 I32 update_minmatch = 1;
1209 I32 had_zerolen = 0;
1211 if (PL_op->op_flags & OPf_STACKED)
1218 PUTBACK; /* EVAL blocks need stack_sp. */
1219 s = SvPV(TARG, len);
1222 DIE(aTHX_ "panic: pp_match");
1223 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1224 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1227 if (pm->op_pmdynflags & PMdf_USED) {
1229 if (gimme == G_ARRAY)
1234 if (!rx->prelen && PL_curpm) {
1236 rx = pm->op_pmregexp;
1238 if (rx->minlen > len) goto failure;
1242 /* XXXX What part of this is needed with true \G-support? */
1243 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1245 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1246 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1247 if (mg && mg->mg_len >= 0) {
1248 if (!(rx->reganch & ROPT_GPOS_SEEN))
1249 rx->endp[0] = rx->startp[0] = mg->mg_len;
1250 else if (rx->reganch & ROPT_ANCH_GPOS) {
1251 r_flags |= REXEC_IGNOREPOS;
1252 rx->endp[0] = rx->startp[0] = mg->mg_len;
1254 minmatch = (mg->mg_flags & MGf_MINMATCH);
1255 update_minmatch = 0;
1259 if ((!global && rx->nparens)
1260 || SvTEMP(TARG) || PL_sawampersand)
1261 r_flags |= REXEC_COPY_STR;
1263 r_flags |= REXEC_SCREAM;
1265 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1266 SAVEINT(PL_multiline);
1267 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1271 if (global && rx->startp[0] != -1) {
1272 t = s = rx->endp[0] + truebase;
1273 if ((s + rx->minlen) > strend)
1275 if (update_minmatch++)
1276 minmatch = had_zerolen;
1278 if (rx->reganch & RE_USE_INTUIT &&
1279 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1280 PL_bostr = truebase;
1281 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1285 if ( (rx->reganch & ROPT_CHECK_ALL)
1287 && ((rx->reganch & ROPT_NOSCAN)
1288 || !((rx->reganch & RE_INTUIT_TAIL)
1289 && (r_flags & REXEC_SCREAM)))
1290 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1293 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1296 if (pm->op_pmflags & PMf_ONCE)
1297 pm->op_pmdynflags |= PMdf_USED;
1306 RX_MATCH_TAINTED_on(rx);
1307 TAINT_IF(RX_MATCH_TAINTED(rx));
1308 if (gimme == G_ARRAY) {
1309 I32 nparens, i, len;
1311 nparens = rx->nparens;
1312 if (global && !nparens)
1316 SPAGAIN; /* EVAL blocks could move the stack. */
1317 EXTEND(SP, nparens + i);
1318 EXTEND_MORTAL(nparens + i);
1319 for (i = !i; i <= nparens; i++) {
1320 PUSHs(sv_newmortal());
1322 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1323 len = rx->endp[i] - rx->startp[i];
1324 s = rx->startp[i] + truebase;
1325 sv_setpvn(*SP, s, len);
1331 had_zerolen = (rx->startp[0] != -1
1332 && rx->startp[0] == rx->endp[0]);
1333 PUTBACK; /* EVAL blocks may use stack */
1334 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1339 LEAVE_SCOPE(oldsave);
1345 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1346 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1348 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1349 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1351 if (rx->startp[0] != -1) {
1352 mg->mg_len = rx->endp[0];
1353 if (rx->startp[0] == rx->endp[0])
1354 mg->mg_flags |= MGf_MINMATCH;
1356 mg->mg_flags &= ~MGf_MINMATCH;
1359 LEAVE_SCOPE(oldsave);
1363 yup: /* Confirmed by INTUIT */
1365 RX_MATCH_TAINTED_on(rx);
1366 TAINT_IF(RX_MATCH_TAINTED(rx));
1368 if (pm->op_pmflags & PMf_ONCE)
1369 pm->op_pmdynflags |= PMdf_USED;
1370 if (RX_MATCH_COPIED(rx))
1371 Safefree(rx->subbeg);
1372 RX_MATCH_COPIED_off(rx);
1373 rx->subbeg = Nullch;
1375 rx->subbeg = truebase;
1376 rx->startp[0] = s - truebase;
1377 if (DO_UTF8(PL_reg_sv)) {
1378 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1379 rx->endp[0] = t - truebase;
1382 rx->endp[0] = s - truebase + rx->minlen;
1384 rx->sublen = strend - truebase;
1387 if (PL_sawampersand) {
1390 rx->subbeg = savepvn(t, strend - t);
1391 rx->sublen = strend - t;
1392 RX_MATCH_COPIED_on(rx);
1393 off = rx->startp[0] = s - t;
1394 rx->endp[0] = off + rx->minlen;
1396 else { /* startp/endp are used by @- @+. */
1397 rx->startp[0] = s - truebase;
1398 rx->endp[0] = s - truebase + rx->minlen;
1400 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1401 LEAVE_SCOPE(oldsave);
1406 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1407 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1408 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1413 LEAVE_SCOPE(oldsave);
1414 if (gimme == G_ARRAY)
1420 Perl_do_readline(pTHX)
1422 dSP; dTARGETSTACKED;
1427 register IO *io = GvIO(PL_last_in_gv);
1428 register I32 type = PL_op->op_type;
1429 I32 gimme = GIMME_V;
1432 if ((mg = SvTIED_mg((SV*)PL_last_in_gv, PERL_MAGIC_tiedscalar))) {
1434 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1437 call_method("READLINE", gimme);
1440 if (gimme == G_SCALAR)
1441 SvSetMagicSV_nosteal(TARG, TOPs);
1448 if (IoFLAGS(io) & IOf_ARGV) {
1449 if (IoFLAGS(io) & IOf_START) {
1451 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1452 IoFLAGS(io) &= ~IOf_START;
1453 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1454 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1455 SvSETMAGIC(GvSV(PL_last_in_gv));
1460 fp = nextargv(PL_last_in_gv);
1461 if (!fp) { /* Note: fp != IoIFP(io) */
1462 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1465 else if (type == OP_GLOB)
1466 fp = Perl_start_glob(aTHX_ POPs, io);
1468 else if (type == OP_GLOB)
1470 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1471 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1475 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1476 && (!io || !(IoFLAGS(io) & IOf_START))) {
1477 if (type == OP_GLOB)
1478 Perl_warner(aTHX_ WARN_GLOB,
1479 "glob failed (can't start child: %s)",
1482 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1484 if (gimme == G_SCALAR) {
1485 (void)SvOK_off(TARG);
1491 if (gimme == G_SCALAR) {
1495 (void)SvUPGRADE(sv, SVt_PV);
1496 tmplen = SvLEN(sv); /* remember if already alloced */
1498 Sv_Grow(sv, 80); /* try short-buffering it */
1499 if (type == OP_RCATLINE)
1505 sv = sv_2mortal(NEWSV(57, 80));
1509 /* This should not be marked tainted if the fp is marked clean */
1510 #define MAYBE_TAINT_LINE(io, sv) \
1511 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1516 /* delay EOF state for a snarfed empty file */
1517 #define SNARF_EOF(gimme,rs,io,sv) \
1518 (gimme != G_SCALAR || SvCUR(sv) \
1519 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1523 if (!sv_gets(sv, fp, offset)
1524 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1526 PerlIO_clearerr(fp);
1527 if (IoFLAGS(io) & IOf_ARGV) {
1528 fp = nextargv(PL_last_in_gv);
1531 (void)do_close(PL_last_in_gv, FALSE);
1533 else if (type == OP_GLOB) {
1534 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1535 Perl_warner(aTHX_ WARN_GLOB,
1536 "glob failed (child exited with status %d%s)",
1537 (int)(STATUS_CURRENT >> 8),
1538 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1541 if (gimme == G_SCALAR) {
1542 (void)SvOK_off(TARG);
1546 MAYBE_TAINT_LINE(io, sv);
1549 MAYBE_TAINT_LINE(io, sv);
1551 IoFLAGS(io) |= IOf_NOLINE;
1555 if (type == OP_GLOB) {
1558 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1559 tmps = SvEND(sv) - 1;
1560 if (*tmps == *SvPVX(PL_rs)) {
1565 for (tmps = SvPVX(sv); *tmps; tmps++)
1566 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1567 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1569 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1570 (void)POPs; /* Unmatched wildcard? Chuck it... */
1574 if (gimme == G_ARRAY) {
1575 if (SvLEN(sv) - SvCUR(sv) > 20) {
1576 SvLEN_set(sv, SvCUR(sv)+1);
1577 Renew(SvPVX(sv), SvLEN(sv), char);
1579 sv = sv_2mortal(NEWSV(58, 80));
1582 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1583 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1587 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1588 Renew(SvPVX(sv), SvLEN(sv), char);
1597 register PERL_CONTEXT *cx;
1598 I32 gimme = OP_GIMME(PL_op, -1);
1601 if (cxstack_ix >= 0)
1602 gimme = cxstack[cxstack_ix].blk_gimme;
1610 PUSHBLOCK(cx, CXt_BLOCK, SP);
1622 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1623 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1625 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1628 if (SvTYPE(hv) == SVt_PVHV) {
1629 if (PL_op->op_private & OPpLVAL_INTRO)
1630 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1631 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1632 svp = he ? &HeVAL(he) : 0;
1634 else if (SvTYPE(hv) == SVt_PVAV) {
1635 if (PL_op->op_private & OPpLVAL_INTRO)
1636 DIE(aTHX_ "Can't localize pseudo-hash element");
1637 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1643 if (!svp || *svp == &PL_sv_undef) {
1648 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1650 lv = sv_newmortal();
1651 sv_upgrade(lv, SVt_PVLV);
1653 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1654 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1655 LvTARG(lv) = SvREFCNT_inc(hv);
1660 if (PL_op->op_private & OPpLVAL_INTRO) {
1661 if (HvNAME(hv) && isGV(*svp))
1662 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1666 char *key = SvPV(keysv, keylen);
1667 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1669 save_helem(hv, keysv, svp);
1672 else if (PL_op->op_private & OPpDEREF)
1673 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1675 sv = (svp ? *svp : &PL_sv_undef);
1676 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1677 * Pushing the magical RHS on to the stack is useless, since
1678 * that magic is soon destined to be misled by the local(),
1679 * and thus the later pp_sassign() will fail to mg_get() the
1680 * old value. This should also cure problems with delayed
1681 * mg_get()s. GSAR 98-07-03 */
1682 if (!lval && SvGMAGICAL(sv))
1683 sv = sv_mortalcopy(sv);
1691 register PERL_CONTEXT *cx;
1697 if (PL_op->op_flags & OPf_SPECIAL) {
1698 cx = &cxstack[cxstack_ix];
1699 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1704 gimme = OP_GIMME(PL_op, -1);
1706 if (cxstack_ix >= 0)
1707 gimme = cxstack[cxstack_ix].blk_gimme;
1713 if (gimme == G_VOID)
1715 else if (gimme == G_SCALAR) {
1718 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1721 *MARK = sv_mortalcopy(TOPs);
1724 *MARK = &PL_sv_undef;
1728 else if (gimme == G_ARRAY) {
1729 /* in case LEAVE wipes old return values */
1730 for (mark = newsp + 1; mark <= SP; mark++) {
1731 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1732 *mark = sv_mortalcopy(*mark);
1733 TAINT_NOT; /* Each item is independent */
1737 PL_curpm = newpm; /* Don't pop $1 et al till now */
1747 register PERL_CONTEXT *cx;
1753 cx = &cxstack[cxstack_ix];
1754 if (CxTYPE(cx) != CXt_LOOP)
1755 DIE(aTHX_ "panic: pp_iter");
1757 itersvp = CxITERVAR(cx);
1758 av = cx->blk_loop.iterary;
1759 if (SvTYPE(av) != SVt_PVAV) {
1760 /* iterate ($min .. $max) */
1761 if (cx->blk_loop.iterlval) {
1762 /* string increment */
1763 register SV* cur = cx->blk_loop.iterlval;
1765 char *max = SvPV((SV*)av, maxlen);
1766 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1767 #ifndef USE_THREADS /* don't risk potential race */
1768 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1769 /* safe to reuse old SV */
1770 sv_setsv(*itersvp, cur);
1775 /* we need a fresh SV every time so that loop body sees a
1776 * completely new SV for closures/references to work as
1778 SvREFCNT_dec(*itersvp);
1779 *itersvp = newSVsv(cur);
1781 if (strEQ(SvPVX(cur), max))
1782 sv_setiv(cur, 0); /* terminate next time */
1789 /* integer increment */
1790 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1793 #ifndef USE_THREADS /* don't risk potential race */
1794 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1795 /* safe to reuse old SV */
1796 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1801 /* we need a fresh SV every time so that loop body sees a
1802 * completely new SV for closures/references to work as they
1804 SvREFCNT_dec(*itersvp);
1805 *itersvp = newSViv(cx->blk_loop.iterix++);
1811 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1814 SvREFCNT_dec(*itersvp);
1816 if (SvMAGICAL(av) || AvREIFY(av)) {
1817 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1824 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1830 if (av != PL_curstack && sv == &PL_sv_undef) {
1831 SV *lv = cx->blk_loop.iterlval;
1832 if (lv && SvREFCNT(lv) > 1) {
1837 SvREFCNT_dec(LvTARG(lv));
1839 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1840 sv_upgrade(lv, SVt_PVLV);
1842 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1844 LvTARG(lv) = SvREFCNT_inc(av);
1845 LvTARGOFF(lv) = cx->blk_loop.iterix;
1846 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1850 *itersvp = SvREFCNT_inc(sv);
1857 register PMOP *pm = cPMOP;
1873 register REGEXP *rx = pm->op_pmregexp;
1875 int force_on_match = 0;
1876 I32 oldsave = PL_savestack_ix;
1880 /* known replacement string? */
1881 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1882 if (PL_op->op_flags & OPf_STACKED)
1889 do_utf8 = DO_UTF8(PL_reg_sv);
1890 if (SvFAKE(TARG) && SvREADONLY(TARG))
1891 sv_force_normal(TARG);
1892 if (SvREADONLY(TARG)
1893 || (SvTYPE(TARG) > SVt_PVLV
1894 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1895 DIE(aTHX_ PL_no_modify);
1898 s = SvPV(TARG, len);
1899 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1901 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1902 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1909 DIE(aTHX_ "panic: pp_subst");
1912 slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1913 maxiters = 2 * slen + 10; /* We can match twice at each
1914 position, once with zero-length,
1915 second time with non-zero. */
1917 if (!rx->prelen && PL_curpm) {
1919 rx = pm->op_pmregexp;
1921 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1922 ? REXEC_COPY_STR : 0;
1924 r_flags |= REXEC_SCREAM;
1925 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1926 SAVEINT(PL_multiline);
1927 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1930 if (rx->reganch & RE_USE_INTUIT) {
1932 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1936 /* How to do it in subst? */
1937 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1939 && ((rx->reganch & ROPT_NOSCAN)
1940 || !((rx->reganch & RE_INTUIT_TAIL)
1941 && (r_flags & REXEC_SCREAM))))
1946 /* only replace once? */
1947 once = !(rpm->op_pmflags & PMf_GLOBAL);
1949 /* known replacement string? */
1950 c = dstr ? SvPV(dstr, clen) : Nullch;
1952 /* can do inplace substitution? */
1953 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1954 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1955 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1956 r_flags | REXEC_CHECKED))
1960 LEAVE_SCOPE(oldsave);
1963 if (force_on_match) {
1965 s = SvPV_force(TARG, len);
1970 SvSCREAM_off(TARG); /* disable possible screamer */
1972 rxtainted |= RX_MATCH_TAINTED(rx);
1973 m = orig + rx->startp[0];
1974 d = orig + rx->endp[0];
1976 if (m - s > strend - d) { /* faster to shorten from end */
1978 Copy(c, m, clen, char);
1983 Move(d, m, i, char);
1987 SvCUR_set(TARG, m - s);
1990 else if ((i = m - s)) { /* faster from front */
1998 Copy(c, m, clen, char);
2003 Copy(c, d, clen, char);
2008 TAINT_IF(rxtainted & 1);
2014 if (iters++ > maxiters)
2015 DIE(aTHX_ "Substitution loop");
2016 rxtainted |= RX_MATCH_TAINTED(rx);
2017 m = rx->startp[0] + orig;
2021 Move(s, d, i, char);
2025 Copy(c, d, clen, char);
2028 s = rx->endp[0] + orig;
2029 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2031 /* don't match same null twice */
2032 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2035 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2036 Move(s, d, i+1, char); /* include the NUL */
2038 TAINT_IF(rxtainted & 1);
2040 PUSHs(sv_2mortal(newSViv((I32)iters)));
2042 (void)SvPOK_only_UTF8(TARG);
2043 TAINT_IF(rxtainted);
2044 if (SvSMAGICAL(TARG)) {
2050 LEAVE_SCOPE(oldsave);
2054 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2055 r_flags | REXEC_CHECKED))
2059 if (force_on_match) {
2061 s = SvPV_force(TARG, len);
2064 rxtainted |= RX_MATCH_TAINTED(rx);
2065 dstr = NEWSV(25, len);
2066 sv_setpvn(dstr, m, s-m);
2071 register PERL_CONTEXT *cx;
2074 RETURNOP(cPMOP->op_pmreplroot);
2076 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2078 if (iters++ > maxiters)
2079 DIE(aTHX_ "Substitution loop");
2080 rxtainted |= RX_MATCH_TAINTED(rx);
2081 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2086 strend = s + (strend - m);
2088 m = rx->startp[0] + orig;
2089 sv_catpvn(dstr, s, m-s);
2090 s = rx->endp[0] + orig;
2092 sv_catpvn(dstr, c, clen);
2095 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2096 TARG, NULL, r_flags));
2097 sv_catpvn(dstr, s, strend - s);
2099 (void)SvOOK_off(TARG);
2100 Safefree(SvPVX(TARG));
2101 SvPVX(TARG) = SvPVX(dstr);
2102 SvCUR_set(TARG, SvCUR(dstr));
2103 SvLEN_set(TARG, SvLEN(dstr));
2104 isutf8 = DO_UTF8(dstr);
2108 TAINT_IF(rxtainted & 1);
2110 PUSHs(sv_2mortal(newSViv((I32)iters)));
2112 (void)SvPOK_only(TARG);
2115 TAINT_IF(rxtainted);
2118 LEAVE_SCOPE(oldsave);
2127 LEAVE_SCOPE(oldsave);
2136 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2137 ++*PL_markstack_ptr;
2138 LEAVE; /* exit inner scope */
2141 if (PL_stack_base + *PL_markstack_ptr > SP) {
2143 I32 gimme = GIMME_V;
2145 LEAVE; /* exit outer scope */
2146 (void)POPMARK; /* pop src */
2147 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2148 (void)POPMARK; /* pop dst */
2149 SP = PL_stack_base + POPMARK; /* pop original mark */
2150 if (gimme == G_SCALAR) {
2154 else if (gimme == G_ARRAY)
2161 ENTER; /* enter inner scope */
2164 src = PL_stack_base[*PL_markstack_ptr];
2168 RETURNOP(cLOGOP->op_other);
2179 register PERL_CONTEXT *cx;
2185 if (gimme == G_SCALAR) {
2188 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2190 *MARK = SvREFCNT_inc(TOPs);
2195 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2197 *MARK = sv_mortalcopy(sv);
2202 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2206 *MARK = &PL_sv_undef;
2210 else if (gimme == G_ARRAY) {
2211 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2212 if (!SvTEMP(*MARK)) {
2213 *MARK = sv_mortalcopy(*MARK);
2214 TAINT_NOT; /* Each item is independent */
2220 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2221 PL_curpm = newpm; /* ... and pop $1 et al */
2225 return pop_return();
2228 /* This duplicates the above code because the above code must not
2229 * get any slower by more conditions */
2237 register PERL_CONTEXT *cx;
2244 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2245 /* We are an argument to a function or grep().
2246 * This kind of lvalueness was legal before lvalue
2247 * subroutines too, so be backward compatible:
2248 * cannot report errors. */
2250 /* Scalar context *is* possible, on the LHS of -> only,
2251 * as in f()->meth(). But this is not an lvalue. */
2252 if (gimme == G_SCALAR)
2254 if (gimme == G_ARRAY) {
2255 if (!CvLVALUE(cx->blk_sub.cv))
2256 goto temporise_array;
2257 EXTEND_MORTAL(SP - newsp);
2258 for (mark = newsp + 1; mark <= SP; mark++) {
2261 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2262 *mark = sv_mortalcopy(*mark);
2264 /* Can be a localized value subject to deletion. */
2265 PL_tmps_stack[++PL_tmps_ix] = *mark;
2266 (void)SvREFCNT_inc(*mark);
2271 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2272 /* Here we go for robustness, not for speed, so we change all
2273 * the refcounts so the caller gets a live guy. Cannot set
2274 * TEMP, so sv_2mortal is out of question. */
2275 if (!CvLVALUE(cx->blk_sub.cv)) {
2280 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2282 if (gimme == G_SCALAR) {
2286 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2291 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2292 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2294 else { /* Can be a localized value
2295 * subject to deletion. */
2296 PL_tmps_stack[++PL_tmps_ix] = *mark;
2297 (void)SvREFCNT_inc(*mark);
2300 else { /* Should not happen? */
2305 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2306 (MARK > SP ? "Empty array" : "Array"));
2310 else if (gimme == G_ARRAY) {
2311 EXTEND_MORTAL(SP - newsp);
2312 for (mark = newsp + 1; mark <= SP; mark++) {
2313 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2314 /* Might be flattened array after $#array = */
2320 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2321 (*mark != &PL_sv_undef)
2323 ? "a readonly value" : "a temporary")
2324 : "an uninitialized value");
2327 /* Can be a localized value subject to deletion. */
2328 PL_tmps_stack[++PL_tmps_ix] = *mark;
2329 (void)SvREFCNT_inc(*mark);
2335 if (gimme == G_SCALAR) {
2339 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2341 *MARK = SvREFCNT_inc(TOPs);
2346 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2348 *MARK = sv_mortalcopy(sv);
2353 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2357 *MARK = &PL_sv_undef;
2361 else if (gimme == G_ARRAY) {
2363 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2364 if (!SvTEMP(*MARK)) {
2365 *MARK = sv_mortalcopy(*MARK);
2366 TAINT_NOT; /* Each item is independent */
2373 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2374 PL_curpm = newpm; /* ... and pop $1 et al */
2378 return pop_return();
2383 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2385 SV *dbsv = GvSV(PL_DBsub);
2387 if (!PERLDB_SUB_NN) {
2391 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2392 || strEQ(GvNAME(gv), "END")
2393 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2394 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2395 && (gv = (GV*)*svp) ))) {
2396 /* Use GV from the stack as a fallback. */
2397 /* GV is potentially non-unique, or contain different CV. */
2398 SV *tmp = newRV((SV*)cv);
2399 sv_setsv(dbsv, tmp);
2403 gv_efullname3(dbsv, gv, Nullch);
2407 (void)SvUPGRADE(dbsv, SVt_PVIV);
2408 (void)SvIOK_on(dbsv);
2409 SAVEIV(SvIVX(dbsv));
2410 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2414 PL_curcopdb = PL_curcop;
2415 cv = GvCV(PL_DBsub);
2425 register PERL_CONTEXT *cx;
2427 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2430 DIE(aTHX_ "Not a CODE reference");
2431 switch (SvTYPE(sv)) {
2437 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2439 SP = PL_stack_base + POPMARK;
2442 if (SvGMAGICAL(sv)) {
2444 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2447 sym = SvPV(sv, n_a);
2449 DIE(aTHX_ PL_no_usym, "a subroutine");
2450 if (PL_op->op_private & HINT_STRICT_REFS)
2451 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2452 cv = get_cv(sym, TRUE);
2456 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2457 tryAMAGICunDEREF(to_cv);
2460 if (SvTYPE(cv) == SVt_PVCV)
2465 DIE(aTHX_ "Not a CODE reference");
2470 if (!(cv = GvCVu((GV*)sv)))
2471 cv = sv_2cv(sv, &stash, &gv, FALSE);
2484 if (!CvROOT(cv) && !CvXSUB(cv)) {
2488 /* anonymous or undef'd function leaves us no recourse */
2489 if (CvANON(cv) || !(gv = CvGV(cv)))
2490 DIE(aTHX_ "Undefined subroutine called");
2492 /* autoloaded stub? */
2493 if (cv != GvCV(gv)) {
2496 /* should call AUTOLOAD now? */
2499 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2506 sub_name = sv_newmortal();
2507 gv_efullname3(sub_name, gv, Nullch);
2508 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2512 DIE(aTHX_ "Not a CODE reference");
2517 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2518 cv = get_db_sub(&sv, cv);
2520 DIE(aTHX_ "No DBsub routine");
2525 * First we need to check if the sub or method requires locking.
2526 * If so, we gain a lock on the CV, the first argument or the
2527 * stash (for static methods), as appropriate. This has to be
2528 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2529 * reschedule by returning a new op.
2531 MUTEX_LOCK(CvMUTEXP(cv));
2532 if (CvFLAGS(cv) & CVf_LOCKED) {
2534 if (CvFLAGS(cv) & CVf_METHOD) {
2535 if (SP > PL_stack_base + TOPMARK)
2536 sv = *(PL_stack_base + TOPMARK + 1);
2538 AV *av = (AV*)PL_curpad[0];
2539 if (hasargs || !av || AvFILLp(av) < 0
2540 || !(sv = AvARRAY(av)[0]))
2542 MUTEX_UNLOCK(CvMUTEXP(cv));
2543 DIE(aTHX_ "no argument for locked method call");
2550 char *stashname = SvPV(sv, len);
2551 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2557 MUTEX_UNLOCK(CvMUTEXP(cv));
2558 mg = condpair_magic(sv);
2559 MUTEX_LOCK(MgMUTEXP(mg));
2560 if (MgOWNER(mg) == thr)
2561 MUTEX_UNLOCK(MgMUTEXP(mg));
2564 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2566 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2568 MUTEX_UNLOCK(MgMUTEXP(mg));
2569 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2571 MUTEX_LOCK(CvMUTEXP(cv));
2574 * Now we have permission to enter the sub, we must distinguish
2575 * four cases. (0) It's an XSUB (in which case we don't care
2576 * about ownership); (1) it's ours already (and we're recursing);
2577 * (2) it's free (but we may already be using a cached clone);
2578 * (3) another thread owns it. Case (1) is easy: we just use it.
2579 * Case (2) means we look for a clone--if we have one, use it
2580 * otherwise grab ownership of cv. Case (3) means we look for a
2581 * clone (for non-XSUBs) and have to create one if we don't
2583 * Why look for a clone in case (2) when we could just grab
2584 * ownership of cv straight away? Well, we could be recursing,
2585 * i.e. we originally tried to enter cv while another thread
2586 * owned it (hence we used a clone) but it has been freed up
2587 * and we're now recursing into it. It may or may not be "better"
2588 * to use the clone but at least CvDEPTH can be trusted.
2590 if (CvOWNER(cv) == thr || CvXSUB(cv))
2591 MUTEX_UNLOCK(CvMUTEXP(cv));
2593 /* Case (2) or (3) */
2597 * XXX Might it be better to release CvMUTEXP(cv) while we
2598 * do the hv_fetch? We might find someone has pinched it
2599 * when we look again, in which case we would be in case
2600 * (3) instead of (2) so we'd have to clone. Would the fact
2601 * that we released the mutex more quickly make up for this?
2603 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2605 /* We already have a clone to use */
2606 MUTEX_UNLOCK(CvMUTEXP(cv));
2608 DEBUG_S(PerlIO_printf(Perl_debug_log,
2609 "entersub: %p already has clone %p:%s\n",
2610 thr, cv, SvPEEK((SV*)cv)));
2613 if (CvDEPTH(cv) == 0)
2614 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2617 /* (2) => grab ownership of cv. (3) => make clone */
2621 MUTEX_UNLOCK(CvMUTEXP(cv));
2622 DEBUG_S(PerlIO_printf(Perl_debug_log,
2623 "entersub: %p grabbing %p:%s in stash %s\n",
2624 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2625 HvNAME(CvSTASH(cv)) : "(none)"));
2628 /* Make a new clone. */
2630 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2631 MUTEX_UNLOCK(CvMUTEXP(cv));
2632 DEBUG_S((PerlIO_printf(Perl_debug_log,
2633 "entersub: %p cloning %p:%s\n",
2634 thr, cv, SvPEEK((SV*)cv))));
2636 * We're creating a new clone so there's no race
2637 * between the original MUTEX_UNLOCK and the
2638 * SvREFCNT_inc since no one will be trying to undef
2639 * it out from underneath us. At least, I don't think
2642 clonecv = cv_clone(cv);
2643 SvREFCNT_dec(cv); /* finished with this */
2644 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2645 CvOWNER(clonecv) = thr;
2649 DEBUG_S(if (CvDEPTH(cv) != 0)
2650 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2652 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2655 #endif /* USE_THREADS */
2658 #ifdef PERL_XSUB_OLDSTYLE
2659 if (CvOLDSTYLE(cv)) {
2660 I32 (*fp3)(int,int,int);
2662 register I32 items = SP - MARK;
2663 /* We dont worry to copy from @_. */
2668 PL_stack_sp = mark + 1;
2669 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2670 items = (*fp3)(CvXSUBANY(cv).any_i32,
2671 MARK - PL_stack_base + 1,
2673 PL_stack_sp = PL_stack_base + items;
2676 #endif /* PERL_XSUB_OLDSTYLE */
2678 I32 markix = TOPMARK;
2683 /* Need to copy @_ to stack. Alternative may be to
2684 * switch stack to @_, and copy return values
2685 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2689 av = (AV*)PL_curpad[0];
2691 av = GvAV(PL_defgv);
2692 #endif /* USE_THREADS */
2693 items = AvFILLp(av) + 1; /* @_ is not tieable */
2696 /* Mark is at the end of the stack. */
2698 Copy(AvARRAY(av), SP + 1, items, SV*);
2703 /* We assume first XSUB in &DB::sub is the called one. */
2705 SAVEVPTR(PL_curcop);
2706 PL_curcop = PL_curcopdb;
2709 /* Do we need to open block here? XXXX */
2710 (void)(*CvXSUB(cv))(aTHXo_ cv);
2712 /* Enforce some sanity in scalar context. */
2713 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2714 if (markix > PL_stack_sp - PL_stack_base)
2715 *(PL_stack_base + markix) = &PL_sv_undef;
2717 *(PL_stack_base + markix) = *PL_stack_sp;
2718 PL_stack_sp = PL_stack_base + markix;
2726 register I32 items = SP - MARK;
2727 AV* padlist = CvPADLIST(cv);
2728 SV** svp = AvARRAY(padlist);
2729 push_return(PL_op->op_next);
2730 PUSHBLOCK(cx, CXt_SUB, MARK);
2733 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2734 * that eval'' ops within this sub know the correct lexical space.
2735 * Owing the speed considerations, we choose to search for the cv
2736 * in doeval() instead.
2738 if (CvDEPTH(cv) < 2)
2739 (void)SvREFCNT_inc(cv);
2740 else { /* save temporaries on recursion? */
2741 PERL_STACK_OVERFLOW_CHECK();
2742 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2744 AV *newpad = newAV();
2745 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2746 I32 ix = AvFILLp((AV*)svp[1]);
2747 I32 names_fill = AvFILLp((AV*)svp[0]);
2748 svp = AvARRAY(svp[0]);
2749 for ( ;ix > 0; ix--) {
2750 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2751 char *name = SvPVX(svp[ix]);
2752 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2753 || *name == '&') /* anonymous code? */
2755 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2757 else { /* our own lexical */
2759 av_store(newpad, ix, sv = (SV*)newAV());
2760 else if (*name == '%')
2761 av_store(newpad, ix, sv = (SV*)newHV());
2763 av_store(newpad, ix, sv = NEWSV(0,0));
2767 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2768 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2771 av_store(newpad, ix, sv = NEWSV(0,0));
2775 av = newAV(); /* will be @_ */
2777 av_store(newpad, 0, (SV*)av);
2778 AvFLAGS(av) = AVf_REIFY;
2779 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2780 AvFILLp(padlist) = CvDEPTH(cv);
2781 svp = AvARRAY(padlist);
2786 AV* av = (AV*)PL_curpad[0];
2788 items = AvFILLp(av) + 1;
2790 /* Mark is at the end of the stack. */
2792 Copy(AvARRAY(av), SP + 1, items, SV*);
2797 #endif /* USE_THREADS */
2798 SAVEVPTR(PL_curpad);
2799 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2802 #endif /* USE_THREADS */
2808 DEBUG_S(PerlIO_printf(Perl_debug_log,
2809 "%p entersub preparing @_\n", thr));
2811 av = (AV*)PL_curpad[0];
2813 /* @_ is normally not REAL--this should only ever
2814 * happen when DB::sub() calls things that modify @_ */
2820 cx->blk_sub.savearray = GvAV(PL_defgv);
2821 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2822 #endif /* USE_THREADS */
2823 cx->blk_sub.oldcurpad = PL_curpad;
2824 cx->blk_sub.argarray = av;
2827 if (items > AvMAX(av) + 1) {
2829 if (AvARRAY(av) != ary) {
2830 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2831 SvPVX(av) = (char*)ary;
2833 if (items > AvMAX(av) + 1) {
2834 AvMAX(av) = items - 1;
2835 Renew(ary,items,SV*);
2837 SvPVX(av) = (char*)ary;
2840 Copy(MARK,AvARRAY(av),items,SV*);
2841 AvFILLp(av) = items - 1;
2849 /* warning must come *after* we fully set up the context
2850 * stuff so that __WARN__ handlers can safely dounwind()
2853 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2854 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2855 sub_crush_depth(cv);
2857 DEBUG_S(PerlIO_printf(Perl_debug_log,
2858 "%p entersub returning %p\n", thr, CvSTART(cv)));
2860 RETURNOP(CvSTART(cv));
2865 Perl_sub_crush_depth(pTHX_ CV *cv)
2868 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2870 SV* tmpstr = sv_newmortal();
2871 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2872 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2882 IV elem = SvIV(elemsv);
2884 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2885 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2888 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2889 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2891 elem -= PL_curcop->cop_arybase;
2892 if (SvTYPE(av) != SVt_PVAV)
2894 svp = av_fetch(av, elem, lval && !defer);
2896 if (!svp || *svp == &PL_sv_undef) {
2899 DIE(aTHX_ PL_no_aelem, elem);
2900 lv = sv_newmortal();
2901 sv_upgrade(lv, SVt_PVLV);
2903 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2904 LvTARG(lv) = SvREFCNT_inc(av);
2905 LvTARGOFF(lv) = elem;
2910 if (PL_op->op_private & OPpLVAL_INTRO)
2911 save_aelem(av, elem, svp);
2912 else if (PL_op->op_private & OPpDEREF)
2913 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2915 sv = (svp ? *svp : &PL_sv_undef);
2916 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2917 sv = sv_mortalcopy(sv);
2923 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2929 Perl_croak(aTHX_ PL_no_modify);
2930 if (SvTYPE(sv) < SVt_RV)
2931 sv_upgrade(sv, SVt_RV);
2932 else if (SvTYPE(sv) >= SVt_PV) {
2933 (void)SvOOK_off(sv);
2934 Safefree(SvPVX(sv));
2935 SvLEN(sv) = SvCUR(sv) = 0;
2939 SvRV(sv) = NEWSV(355,0);
2942 SvRV(sv) = (SV*)newAV();
2945 SvRV(sv) = (SV*)newHV();
2960 if (SvTYPE(rsv) == SVt_PVCV) {
2966 SETs(method_common(sv, Null(U32*)));
2973 SV* sv = cSVOP->op_sv;
2974 U32 hash = SvUVX(sv);
2976 XPUSHs(method_common(sv, &hash));
2981 S_method_common(pTHX_ SV* meth, U32* hashp)
2992 name = SvPV(meth, namelen);
2993 sv = *(PL_stack_base + TOPMARK + 1);
2996 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3005 /* this isn't a reference */
3008 !(packname = SvPV(sv, packlen)) ||
3009 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3010 !(ob=(SV*)GvIO(iogv)))
3012 /* this isn't the name of a filehandle either */
3014 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3015 ? !isIDFIRST_utf8((U8*)packname)
3016 : !isIDFIRST(*packname)
3019 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3020 SvOK(sv) ? "without a package or object reference"
3021 : "on an undefined value");
3023 /* assume it's a package name */
3024 stash = gv_stashpvn(packname, packlen, FALSE);
3027 /* it _is_ a filehandle name -- replace with a reference */
3028 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3031 /* if we got here, ob should be a reference or a glob */
3032 if (!ob || !(SvOBJECT(ob)
3033 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3036 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3040 stash = SvSTASH(ob);
3043 /* NOTE: stash may be null, hope hv_fetch_ent and
3044 gv_fetchmethod can cope (it seems they can) */
3046 /* shortcut for simple names */
3048 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3050 gv = (GV*)HeVAL(he);
3051 if (isGV(gv) && GvCV(gv) &&
3052 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3053 return (SV*)GvCV(gv);
3057 gv = gv_fetchmethod(stash, name);
3060 /* This code tries to figure out just what went wrong with
3061 gv_fetchmethod. It therefore needs to duplicate a lot of
3062 the internals of that function. We can't move it inside
3063 Perl_gv_fetchmethod_autoload(), however, since that would
3064 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3071 for (p = name; *p; p++) {
3073 sep = p, leaf = p + 1;
3074 else if (*p == ':' && *(p + 1) == ':')
3075 sep = p, leaf = p + 2;
3077 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3078 /* the method name is unqualified or starts with SUPER:: */
3079 packname = sep ? CopSTASHPV(PL_curcop) :
3080 stash ? HvNAME(stash) : packname;
3081 packlen = strlen(packname);
3084 /* the method name is qualified */
3086 packlen = sep - name;
3089 /* we're relying on gv_fetchmethod not autovivifying the stash */
3090 if (gv_stashpvn(packname, packlen, FALSE)) {
3092 "Can't locate object method \"%s\" via package \"%.*s\"",
3093 leaf, (int)packlen, packname);
3097 "Can't locate object method \"%s\" via package \"%.*s\""
3098 " (perhaps you forgot to load \"%.*s\"?)",
3099 leaf, (int)packlen, packname, (int)packlen, packname);
3102 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3107 unset_cvowner(pTHXo_ void *cvarg)
3109 register CV* cv = (CV *) cvarg;
3111 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3112 thr, cv, SvPEEK((SV*)cv))));
3113 MUTEX_LOCK(CvMUTEXP(cv));
3114 DEBUG_S(if (CvDEPTH(cv) != 0)
3115 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3117 assert(thr == CvOWNER(cv));
3119 MUTEX_UNLOCK(CvMUTEXP(cv));
3122 #endif /* USE_THREADS */