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, 'q'))) {
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))) {
580 if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
582 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
583 report_evil_fh(gv, io, PL_op->op_type);
584 SETERRNO(EBADF,RMS$_IFI);
587 else if (!(fp = IoOFP(io))) {
588 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
590 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
591 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
592 report_evil_fh(gv, io, PL_op->op_type);
594 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
599 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
601 if (!do_print(*MARK, fp))
605 if (!do_print(PL_ofs_sv, fp)) { /* $, */
614 if (!do_print(*MARK, fp))
622 if (PL_ors_sv && SvOK(PL_ors_sv))
623 if (!do_print(PL_ors_sv, fp)) /* $\ */
626 if (IoFLAGS(io) & IOf_FLUSH)
627 if (PerlIO_flush(fp) == EOF)
648 tryAMAGICunDEREF(to_av);
651 if (SvTYPE(av) != SVt_PVAV)
652 DIE(aTHX_ "Not an ARRAY reference");
653 if (PL_op->op_flags & OPf_REF) {
658 if (GIMME == G_SCALAR)
659 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
665 if (SvTYPE(sv) == SVt_PVAV) {
667 if (PL_op->op_flags & OPf_REF) {
672 if (GIMME == G_SCALAR)
673 Perl_croak(aTHX_ "Can't return array to lvalue"
682 if (SvTYPE(sv) != SVt_PVGV) {
686 if (SvGMAGICAL(sv)) {
692 if (PL_op->op_flags & OPf_REF ||
693 PL_op->op_private & HINT_STRICT_REFS)
694 DIE(aTHX_ PL_no_usym, "an ARRAY");
695 if (ckWARN(WARN_UNINITIALIZED))
697 if (GIMME == G_ARRAY) {
704 if ((PL_op->op_flags & OPf_SPECIAL) &&
705 !(PL_op->op_flags & OPf_MOD))
707 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
709 && (!is_gv_magical(sym,len,0)
710 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
716 if (PL_op->op_private & HINT_STRICT_REFS)
717 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
718 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
725 if (PL_op->op_private & OPpLVAL_INTRO)
727 if (PL_op->op_flags & OPf_REF) {
732 if (GIMME == G_SCALAR)
733 Perl_croak(aTHX_ "Can't return array to lvalue"
741 if (GIMME == G_ARRAY) {
742 I32 maxarg = AvFILL(av) + 1;
743 (void)POPs; /* XXXX May be optimized away? */
745 if (SvRMAGICAL(av)) {
747 for (i=0; i < maxarg; i++) {
748 SV **svp = av_fetch(av, i, FALSE);
749 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
753 Copy(AvARRAY(av), SP+1, maxarg, SV*);
759 I32 maxarg = AvFILL(av) + 1;
772 tryAMAGICunDEREF(to_hv);
775 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
776 DIE(aTHX_ "Not a HASH reference");
777 if (PL_op->op_flags & OPf_REF) {
782 if (GIMME == G_SCALAR)
783 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
789 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
791 if (PL_op->op_flags & OPf_REF) {
796 if (GIMME == G_SCALAR)
797 Perl_croak(aTHX_ "Can't return hash to lvalue"
806 if (SvTYPE(sv) != SVt_PVGV) {
810 if (SvGMAGICAL(sv)) {
816 if (PL_op->op_flags & OPf_REF ||
817 PL_op->op_private & HINT_STRICT_REFS)
818 DIE(aTHX_ PL_no_usym, "a HASH");
819 if (ckWARN(WARN_UNINITIALIZED))
821 if (GIMME == G_ARRAY) {
828 if ((PL_op->op_flags & OPf_SPECIAL) &&
829 !(PL_op->op_flags & OPf_MOD))
831 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
833 && (!is_gv_magical(sym,len,0)
834 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
840 if (PL_op->op_private & HINT_STRICT_REFS)
841 DIE(aTHX_ PL_no_symref, sym, "a HASH");
842 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
849 if (PL_op->op_private & OPpLVAL_INTRO)
851 if (PL_op->op_flags & OPf_REF) {
856 if (GIMME == G_SCALAR)
857 Perl_croak(aTHX_ "Can't return hash to lvalue"
865 if (GIMME == G_ARRAY) { /* array wanted */
866 *PL_stack_sp = (SV*)hv;
871 if (SvTYPE(hv) == SVt_PVAV)
872 hv = avhv_keys((AV*)hv);
874 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
875 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
885 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
891 leftop = ((BINOP*)PL_op)->op_last;
893 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
894 leftop = ((LISTOP*)leftop)->op_first;
896 /* Skip PUSHMARK and each element already assigned to. */
897 for (i = lelem - firstlelem; i > 0; i--) {
898 leftop = leftop->op_sibling;
901 if (leftop->op_type != OP_RV2HV)
906 av_fill(ary, 0); /* clear all but the fields hash */
907 if (lastrelem >= relem) {
908 while (relem < lastrelem) { /* gobble up all the rest */
912 /* Avoid a memory leak when avhv_store_ent dies. */
913 tmpstr = sv_newmortal();
914 sv_setsv(tmpstr,relem[1]); /* value */
916 if (avhv_store_ent(ary,relem[0],tmpstr,0))
917 (void)SvREFCNT_inc(tmpstr);
918 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
924 if (relem == lastrelem)
930 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
934 if (ckWARN(WARN_MISC)) {
935 if (relem == firstrelem &&
937 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
938 SvTYPE(SvRV(*relem)) == SVt_PVHV))
940 Perl_warner(aTHX_ WARN_MISC,
941 "Reference found where even-sized list expected");
944 Perl_warner(aTHX_ WARN_MISC,
945 "Odd number of elements in hash assignment");
947 if (SvTYPE(hash) == SVt_PVAV) {
949 tmpstr = sv_newmortal();
950 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
951 (void)SvREFCNT_inc(tmpstr);
952 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
957 tmpstr = NEWSV(29,0);
958 didstore = hv_store_ent(hash,*relem,tmpstr,0);
959 if (SvMAGICAL(hash)) {
960 if (SvSMAGICAL(tmpstr))
973 SV **lastlelem = PL_stack_sp;
974 SV **lastrelem = PL_stack_base + POPMARK;
975 SV **firstrelem = PL_stack_base + POPMARK + 1;
976 SV **firstlelem = lastrelem + 1;
989 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
991 /* If there's a common identifier on both sides we have to take
992 * special care that assigning the identifier on the left doesn't
993 * clobber a value on the right that's used later in the list.
995 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
996 EXTEND_MORTAL(lastrelem - firstrelem + 1);
997 for (relem = firstrelem; relem <= lastrelem; relem++) {
1000 TAINT_NOT; /* Each item is independent */
1001 *relem = sv_mortalcopy(sv);
1011 while (lelem <= lastlelem) {
1012 TAINT_NOT; /* Each item stands on its own, taintwise. */
1014 switch (SvTYPE(sv)) {
1017 magic = SvMAGICAL(ary) != 0;
1018 if (PL_op->op_private & OPpASSIGN_HASH) {
1019 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1025 do_oddball((HV*)ary, relem, firstrelem);
1027 relem = lastrelem + 1;
1032 av_extend(ary, lastrelem - relem);
1034 while (relem <= lastrelem) { /* gobble up all the rest */
1038 sv_setsv(sv,*relem);
1040 didstore = av_store(ary,i++,sv);
1050 case SVt_PVHV: { /* normal hash */
1054 magic = SvMAGICAL(hash) != 0;
1057 while (relem < lastrelem) { /* gobble up all the rest */
1062 sv = &PL_sv_no, relem++;
1063 tmpstr = NEWSV(29,0);
1065 sv_setsv(tmpstr,*relem); /* value */
1066 *(relem++) = tmpstr;
1067 didstore = hv_store_ent(hash,sv,tmpstr,0);
1069 if (SvSMAGICAL(tmpstr))
1076 if (relem == lastrelem) {
1077 do_oddball(hash, relem, firstrelem);
1083 if (SvIMMORTAL(sv)) {
1084 if (relem <= lastrelem)
1088 if (relem <= lastrelem) {
1089 sv_setsv(sv, *relem);
1093 sv_setsv(sv, &PL_sv_undef);
1098 if (PL_delaymagic & ~DM_DELAY) {
1099 if (PL_delaymagic & DM_UID) {
1100 #ifdef HAS_SETRESUID
1101 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1103 # ifdef HAS_SETREUID
1104 (void)setreuid(PL_uid,PL_euid);
1107 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1108 (void)setruid(PL_uid);
1109 PL_delaymagic &= ~DM_RUID;
1111 # endif /* HAS_SETRUID */
1113 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1114 (void)seteuid(PL_uid);
1115 PL_delaymagic &= ~DM_EUID;
1117 # endif /* HAS_SETEUID */
1118 if (PL_delaymagic & DM_UID) {
1119 if (PL_uid != PL_euid)
1120 DIE(aTHX_ "No setreuid available");
1121 (void)PerlProc_setuid(PL_uid);
1123 # endif /* HAS_SETREUID */
1124 #endif /* HAS_SETRESUID */
1125 PL_uid = PerlProc_getuid();
1126 PL_euid = PerlProc_geteuid();
1128 if (PL_delaymagic & DM_GID) {
1129 #ifdef HAS_SETRESGID
1130 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1132 # ifdef HAS_SETREGID
1133 (void)setregid(PL_gid,PL_egid);
1136 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1137 (void)setrgid(PL_gid);
1138 PL_delaymagic &= ~DM_RGID;
1140 # endif /* HAS_SETRGID */
1142 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1143 (void)setegid(PL_gid);
1144 PL_delaymagic &= ~DM_EGID;
1146 # endif /* HAS_SETEGID */
1147 if (PL_delaymagic & DM_GID) {
1148 if (PL_gid != PL_egid)
1149 DIE(aTHX_ "No setregid available");
1150 (void)PerlProc_setgid(PL_gid);
1152 # endif /* HAS_SETREGID */
1153 #endif /* HAS_SETRESGID */
1154 PL_gid = PerlProc_getgid();
1155 PL_egid = PerlProc_getegid();
1157 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1162 if (gimme == G_VOID)
1163 SP = firstrelem - 1;
1164 else if (gimme == G_SCALAR) {
1167 SETi(lastrelem - firstrelem + 1);
1173 SP = firstrelem + (lastlelem - firstlelem);
1174 lelem = firstlelem + (relem - firstrelem);
1176 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1184 register PMOP *pm = cPMOP;
1185 SV *rv = sv_newmortal();
1186 SV *sv = newSVrv(rv, "Regexp");
1187 sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
1194 register PMOP *pm = cPMOP;
1199 I32 r_flags = REXEC_CHECKED;
1200 char *truebase; /* Start of string */
1201 register REGEXP *rx = pm->op_pmregexp;
1206 I32 oldsave = PL_savestack_ix;
1207 I32 update_minmatch = 1;
1208 I32 had_zerolen = 0;
1210 if (PL_op->op_flags & OPf_STACKED)
1217 PUTBACK; /* EVAL blocks need stack_sp. */
1218 s = SvPV(TARG, len);
1221 DIE(aTHX_ "panic: pp_match");
1222 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1223 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1226 if (pm->op_pmdynflags & PMdf_USED) {
1228 if (gimme == G_ARRAY)
1233 if (!rx->prelen && PL_curpm) {
1235 rx = pm->op_pmregexp;
1237 if (rx->minlen > len) goto failure;
1241 /* XXXX What part of this is needed with true \G-support? */
1242 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1244 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1245 MAGIC* mg = mg_find(TARG, 'g');
1246 if (mg && mg->mg_len >= 0) {
1247 if (!(rx->reganch & ROPT_GPOS_SEEN))
1248 rx->endp[0] = rx->startp[0] = mg->mg_len;
1249 else if (rx->reganch & ROPT_ANCH_GPOS) {
1250 r_flags |= REXEC_IGNOREPOS;
1251 rx->endp[0] = rx->startp[0] = mg->mg_len;
1253 minmatch = (mg->mg_flags & MGf_MINMATCH);
1254 update_minmatch = 0;
1258 if ((!global && rx->nparens)
1259 || SvTEMP(TARG) || PL_sawampersand)
1260 r_flags |= REXEC_COPY_STR;
1262 r_flags |= REXEC_SCREAM;
1264 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1265 SAVEINT(PL_multiline);
1266 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1270 if (global && rx->startp[0] != -1) {
1271 t = s = rx->endp[0] + truebase;
1272 if ((s + rx->minlen) > strend)
1274 if (update_minmatch++)
1275 minmatch = had_zerolen;
1277 if (rx->reganch & RE_USE_INTUIT &&
1278 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1279 PL_bostr = truebase;
1280 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1284 if ( (rx->reganch & ROPT_CHECK_ALL)
1286 && ((rx->reganch & ROPT_NOSCAN)
1287 || !((rx->reganch & RE_INTUIT_TAIL)
1288 && (r_flags & REXEC_SCREAM)))
1289 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1292 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1295 if (pm->op_pmflags & PMf_ONCE)
1296 pm->op_pmdynflags |= PMdf_USED;
1305 RX_MATCH_TAINTED_on(rx);
1306 TAINT_IF(RX_MATCH_TAINTED(rx));
1307 if (gimme == G_ARRAY) {
1308 I32 nparens, i, len;
1310 nparens = rx->nparens;
1311 if (global && !nparens)
1315 SPAGAIN; /* EVAL blocks could move the stack. */
1316 EXTEND(SP, nparens + i);
1317 EXTEND_MORTAL(nparens + i);
1318 for (i = !i; i <= nparens; i++) {
1319 PUSHs(sv_newmortal());
1321 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1322 len = rx->endp[i] - rx->startp[i];
1323 s = rx->startp[i] + truebase;
1324 sv_setpvn(*SP, s, len);
1330 had_zerolen = (rx->startp[0] != -1
1331 && rx->startp[0] == rx->endp[0]);
1332 PUTBACK; /* EVAL blocks may use stack */
1333 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1338 LEAVE_SCOPE(oldsave);
1344 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1345 mg = mg_find(TARG, 'g');
1347 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1348 mg = mg_find(TARG, 'g');
1350 if (rx->startp[0] != -1) {
1351 mg->mg_len = rx->endp[0];
1352 if (rx->startp[0] == rx->endp[0])
1353 mg->mg_flags |= MGf_MINMATCH;
1355 mg->mg_flags &= ~MGf_MINMATCH;
1358 LEAVE_SCOPE(oldsave);
1362 yup: /* Confirmed by INTUIT */
1364 RX_MATCH_TAINTED_on(rx);
1365 TAINT_IF(RX_MATCH_TAINTED(rx));
1367 if (pm->op_pmflags & PMf_ONCE)
1368 pm->op_pmdynflags |= PMdf_USED;
1369 if (RX_MATCH_COPIED(rx))
1370 Safefree(rx->subbeg);
1371 RX_MATCH_COPIED_off(rx);
1372 rx->subbeg = Nullch;
1374 rx->subbeg = truebase;
1375 rx->startp[0] = s - truebase;
1376 if (DO_UTF8(PL_reg_sv)) {
1377 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1378 rx->endp[0] = t - truebase;
1381 rx->endp[0] = s - truebase + rx->minlen;
1383 rx->sublen = strend - truebase;
1386 if (PL_sawampersand) {
1389 rx->subbeg = savepvn(t, strend - t);
1390 rx->sublen = strend - t;
1391 RX_MATCH_COPIED_on(rx);
1392 off = rx->startp[0] = s - t;
1393 rx->endp[0] = off + rx->minlen;
1395 else { /* startp/endp are used by @- @+. */
1396 rx->startp[0] = s - truebase;
1397 rx->endp[0] = s - truebase + rx->minlen;
1399 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1400 LEAVE_SCOPE(oldsave);
1405 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1406 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1407 MAGIC* mg = mg_find(TARG, 'g');
1412 LEAVE_SCOPE(oldsave);
1413 if (gimme == G_ARRAY)
1419 Perl_do_readline(pTHX)
1421 dSP; dTARGETSTACKED;
1426 register IO *io = GvIO(PL_last_in_gv);
1427 register I32 type = PL_op->op_type;
1428 I32 gimme = GIMME_V;
1431 if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
1433 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1436 call_method("READLINE", gimme);
1439 if (gimme == G_SCALAR)
1440 SvSetMagicSV_nosteal(TARG, TOPs);
1447 if (IoFLAGS(io) & IOf_ARGV) {
1448 if (IoFLAGS(io) & IOf_START) {
1450 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1451 IoFLAGS(io) &= ~IOf_START;
1452 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1453 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1454 SvSETMAGIC(GvSV(PL_last_in_gv));
1459 fp = nextargv(PL_last_in_gv);
1460 if (!fp) { /* Note: fp != IoIFP(io) */
1461 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1464 else if (type == OP_GLOB)
1465 fp = Perl_start_glob(aTHX_ POPs, io);
1467 else if (type == OP_GLOB)
1469 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1470 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1474 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1475 && (!io || !(IoFLAGS(io) & IOf_START))) {
1476 if (type == OP_GLOB)
1477 Perl_warner(aTHX_ WARN_GLOB,
1478 "glob failed (can't start child: %s)",
1481 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1483 if (gimme == G_SCALAR) {
1484 (void)SvOK_off(TARG);
1490 if (gimme == G_SCALAR) {
1494 (void)SvUPGRADE(sv, SVt_PV);
1495 tmplen = SvLEN(sv); /* remember if already alloced */
1497 Sv_Grow(sv, 80); /* try short-buffering it */
1498 if (type == OP_RCATLINE)
1504 sv = sv_2mortal(NEWSV(57, 80));
1508 /* This should not be marked tainted if the fp is marked clean */
1509 #define MAYBE_TAINT_LINE(io, sv) \
1510 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1515 /* delay EOF state for a snarfed empty file */
1516 #define SNARF_EOF(gimme,rs,io,sv) \
1517 (gimme != G_SCALAR || SvCUR(sv) \
1518 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1522 if (!sv_gets(sv, fp, offset)
1523 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1525 PerlIO_clearerr(fp);
1526 if (IoFLAGS(io) & IOf_ARGV) {
1527 fp = nextargv(PL_last_in_gv);
1530 (void)do_close(PL_last_in_gv, FALSE);
1532 else if (type == OP_GLOB) {
1533 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1534 Perl_warner(aTHX_ WARN_GLOB,
1535 "glob failed (child exited with status %d%s)",
1536 (int)(STATUS_CURRENT >> 8),
1537 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1540 if (gimme == G_SCALAR) {
1541 (void)SvOK_off(TARG);
1545 MAYBE_TAINT_LINE(io, sv);
1548 MAYBE_TAINT_LINE(io, sv);
1550 IoFLAGS(io) |= IOf_NOLINE;
1554 if (type == OP_GLOB) {
1557 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1558 tmps = SvEND(sv) - 1;
1559 if (*tmps == *SvPVX(PL_rs)) {
1564 for (tmps = SvPVX(sv); *tmps; tmps++)
1565 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1566 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1568 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1569 (void)POPs; /* Unmatched wildcard? Chuck it... */
1573 if (gimme == G_ARRAY) {
1574 if (SvLEN(sv) - SvCUR(sv) > 20) {
1575 SvLEN_set(sv, SvCUR(sv)+1);
1576 Renew(SvPVX(sv), SvLEN(sv), char);
1578 sv = sv_2mortal(NEWSV(58, 80));
1581 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1582 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1586 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1587 Renew(SvPVX(sv), SvLEN(sv), char);
1596 register PERL_CONTEXT *cx;
1597 I32 gimme = OP_GIMME(PL_op, -1);
1600 if (cxstack_ix >= 0)
1601 gimme = cxstack[cxstack_ix].blk_gimme;
1609 PUSHBLOCK(cx, CXt_BLOCK, SP);
1621 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1622 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1624 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1627 if (SvTYPE(hv) == SVt_PVHV) {
1628 if (PL_op->op_private & OPpLVAL_INTRO)
1629 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1630 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1631 svp = he ? &HeVAL(he) : 0;
1633 else if (SvTYPE(hv) == SVt_PVAV) {
1634 if (PL_op->op_private & OPpLVAL_INTRO)
1635 DIE(aTHX_ "Can't localize pseudo-hash element");
1636 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1642 if (!svp || *svp == &PL_sv_undef) {
1647 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1649 lv = sv_newmortal();
1650 sv_upgrade(lv, SVt_PVLV);
1652 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1653 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1654 LvTARG(lv) = SvREFCNT_inc(hv);
1659 if (PL_op->op_private & OPpLVAL_INTRO) {
1660 if (HvNAME(hv) && isGV(*svp))
1661 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1665 char *key = SvPV(keysv, keylen);
1666 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1668 save_helem(hv, keysv, svp);
1671 else if (PL_op->op_private & OPpDEREF)
1672 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1674 sv = (svp ? *svp : &PL_sv_undef);
1675 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1676 * Pushing the magical RHS on to the stack is useless, since
1677 * that magic is soon destined to be misled by the local(),
1678 * and thus the later pp_sassign() will fail to mg_get() the
1679 * old value. This should also cure problems with delayed
1680 * mg_get()s. GSAR 98-07-03 */
1681 if (!lval && SvGMAGICAL(sv))
1682 sv = sv_mortalcopy(sv);
1690 register PERL_CONTEXT *cx;
1696 if (PL_op->op_flags & OPf_SPECIAL) {
1697 cx = &cxstack[cxstack_ix];
1698 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1703 gimme = OP_GIMME(PL_op, -1);
1705 if (cxstack_ix >= 0)
1706 gimme = cxstack[cxstack_ix].blk_gimme;
1712 if (gimme == G_VOID)
1714 else if (gimme == G_SCALAR) {
1717 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1720 *MARK = sv_mortalcopy(TOPs);
1723 *MARK = &PL_sv_undef;
1727 else if (gimme == G_ARRAY) {
1728 /* in case LEAVE wipes old return values */
1729 for (mark = newsp + 1; mark <= SP; mark++) {
1730 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1731 *mark = sv_mortalcopy(*mark);
1732 TAINT_NOT; /* Each item is independent */
1736 PL_curpm = newpm; /* Don't pop $1 et al till now */
1746 register PERL_CONTEXT *cx;
1752 cx = &cxstack[cxstack_ix];
1753 if (CxTYPE(cx) != CXt_LOOP)
1754 DIE(aTHX_ "panic: pp_iter");
1756 itersvp = CxITERVAR(cx);
1757 av = cx->blk_loop.iterary;
1758 if (SvTYPE(av) != SVt_PVAV) {
1759 /* iterate ($min .. $max) */
1760 if (cx->blk_loop.iterlval) {
1761 /* string increment */
1762 register SV* cur = cx->blk_loop.iterlval;
1764 char *max = SvPV((SV*)av, maxlen);
1765 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1766 #ifndef USE_THREADS /* don't risk potential race */
1767 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1768 /* safe to reuse old SV */
1769 sv_setsv(*itersvp, cur);
1774 /* we need a fresh SV every time so that loop body sees a
1775 * completely new SV for closures/references to work as
1777 SvREFCNT_dec(*itersvp);
1778 *itersvp = newSVsv(cur);
1780 if (strEQ(SvPVX(cur), max))
1781 sv_setiv(cur, 0); /* terminate next time */
1788 /* integer increment */
1789 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1792 #ifndef USE_THREADS /* don't risk potential race */
1793 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1794 /* safe to reuse old SV */
1795 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1800 /* we need a fresh SV every time so that loop body sees a
1801 * completely new SV for closures/references to work as they
1803 SvREFCNT_dec(*itersvp);
1804 *itersvp = newSViv(cx->blk_loop.iterix++);
1810 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1813 SvREFCNT_dec(*itersvp);
1815 if ((sv = SvMAGICAL(av)
1816 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1817 : AvARRAY(av)[++cx->blk_loop.iterix]))
1821 if (av != PL_curstack && sv == &PL_sv_undef) {
1822 SV *lv = cx->blk_loop.iterlval;
1823 if (lv && SvREFCNT(lv) > 1) {
1828 SvREFCNT_dec(LvTARG(lv));
1830 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1831 sv_upgrade(lv, SVt_PVLV);
1833 sv_magic(lv, Nullsv, 'y', Nullch, 0);
1835 LvTARG(lv) = SvREFCNT_inc(av);
1836 LvTARGOFF(lv) = cx->blk_loop.iterix;
1837 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1841 *itersvp = SvREFCNT_inc(sv);
1848 register PMOP *pm = cPMOP;
1864 register REGEXP *rx = pm->op_pmregexp;
1866 int force_on_match = 0;
1867 I32 oldsave = PL_savestack_ix;
1871 /* known replacement string? */
1872 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1873 if (PL_op->op_flags & OPf_STACKED)
1880 do_utf8 = DO_UTF8(PL_reg_sv);
1881 if (SvFAKE(TARG) && SvREADONLY(TARG))
1882 sv_force_normal(TARG);
1883 if (SvREADONLY(TARG)
1884 || (SvTYPE(TARG) > SVt_PVLV
1885 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1886 DIE(aTHX_ PL_no_modify);
1889 s = SvPV(TARG, len);
1890 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1892 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1893 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1900 DIE(aTHX_ "panic: pp_subst");
1903 slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1904 maxiters = 2 * slen + 10; /* We can match twice at each
1905 position, once with zero-length,
1906 second time with non-zero. */
1908 if (!rx->prelen && PL_curpm) {
1910 rx = pm->op_pmregexp;
1912 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1913 ? REXEC_COPY_STR : 0;
1915 r_flags |= REXEC_SCREAM;
1916 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1917 SAVEINT(PL_multiline);
1918 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1921 if (rx->reganch & RE_USE_INTUIT) {
1923 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1927 /* How to do it in subst? */
1928 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1930 && ((rx->reganch & ROPT_NOSCAN)
1931 || !((rx->reganch & RE_INTUIT_TAIL)
1932 && (r_flags & REXEC_SCREAM))))
1937 /* only replace once? */
1938 once = !(rpm->op_pmflags & PMf_GLOBAL);
1940 /* known replacement string? */
1941 c = dstr ? SvPV(dstr, clen) : Nullch;
1943 /* can do inplace substitution? */
1944 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1945 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1946 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1947 r_flags | REXEC_CHECKED))
1951 LEAVE_SCOPE(oldsave);
1954 if (force_on_match) {
1956 s = SvPV_force(TARG, len);
1961 SvSCREAM_off(TARG); /* disable possible screamer */
1963 rxtainted |= RX_MATCH_TAINTED(rx);
1964 m = orig + rx->startp[0];
1965 d = orig + rx->endp[0];
1967 if (m - s > strend - d) { /* faster to shorten from end */
1969 Copy(c, m, clen, char);
1974 Move(d, m, i, char);
1978 SvCUR_set(TARG, m - s);
1981 else if ((i = m - s)) { /* faster from front */
1989 Copy(c, m, clen, char);
1994 Copy(c, d, clen, char);
1999 TAINT_IF(rxtainted & 1);
2005 if (iters++ > maxiters)
2006 DIE(aTHX_ "Substitution loop");
2007 rxtainted |= RX_MATCH_TAINTED(rx);
2008 m = rx->startp[0] + orig;
2012 Move(s, d, i, char);
2016 Copy(c, d, clen, char);
2019 s = rx->endp[0] + orig;
2020 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2022 /* don't match same null twice */
2023 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2026 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2027 Move(s, d, i+1, char); /* include the NUL */
2029 TAINT_IF(rxtainted & 1);
2031 PUSHs(sv_2mortal(newSViv((I32)iters)));
2033 (void)SvPOK_only_UTF8(TARG);
2034 TAINT_IF(rxtainted);
2035 if (SvSMAGICAL(TARG)) {
2041 LEAVE_SCOPE(oldsave);
2045 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2046 r_flags | REXEC_CHECKED))
2050 if (force_on_match) {
2052 s = SvPV_force(TARG, len);
2055 rxtainted |= RX_MATCH_TAINTED(rx);
2056 dstr = NEWSV(25, len);
2057 sv_setpvn(dstr, m, s-m);
2062 register PERL_CONTEXT *cx;
2065 RETURNOP(cPMOP->op_pmreplroot);
2067 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2069 if (iters++ > maxiters)
2070 DIE(aTHX_ "Substitution loop");
2071 rxtainted |= RX_MATCH_TAINTED(rx);
2072 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2077 strend = s + (strend - m);
2079 m = rx->startp[0] + orig;
2080 sv_catpvn(dstr, s, m-s);
2081 s = rx->endp[0] + orig;
2083 sv_catpvn(dstr, c, clen);
2086 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2087 TARG, NULL, r_flags));
2088 sv_catpvn(dstr, s, strend - s);
2090 (void)SvOOK_off(TARG);
2091 Safefree(SvPVX(TARG));
2092 SvPVX(TARG) = SvPVX(dstr);
2093 SvCUR_set(TARG, SvCUR(dstr));
2094 SvLEN_set(TARG, SvLEN(dstr));
2095 isutf8 = DO_UTF8(dstr);
2099 TAINT_IF(rxtainted & 1);
2101 PUSHs(sv_2mortal(newSViv((I32)iters)));
2103 (void)SvPOK_only(TARG);
2106 TAINT_IF(rxtainted);
2109 LEAVE_SCOPE(oldsave);
2118 LEAVE_SCOPE(oldsave);
2127 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2128 ++*PL_markstack_ptr;
2129 LEAVE; /* exit inner scope */
2132 if (PL_stack_base + *PL_markstack_ptr > SP) {
2134 I32 gimme = GIMME_V;
2136 LEAVE; /* exit outer scope */
2137 (void)POPMARK; /* pop src */
2138 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2139 (void)POPMARK; /* pop dst */
2140 SP = PL_stack_base + POPMARK; /* pop original mark */
2141 if (gimme == G_SCALAR) {
2145 else if (gimme == G_ARRAY)
2152 ENTER; /* enter inner scope */
2155 src = PL_stack_base[*PL_markstack_ptr];
2159 RETURNOP(cLOGOP->op_other);
2170 register PERL_CONTEXT *cx;
2176 if (gimme == G_SCALAR) {
2179 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2181 *MARK = SvREFCNT_inc(TOPs);
2186 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2188 *MARK = sv_mortalcopy(sv);
2193 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2197 *MARK = &PL_sv_undef;
2201 else if (gimme == G_ARRAY) {
2202 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2203 if (!SvTEMP(*MARK)) {
2204 *MARK = sv_mortalcopy(*MARK);
2205 TAINT_NOT; /* Each item is independent */
2211 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2212 PL_curpm = newpm; /* ... and pop $1 et al */
2216 return pop_return();
2219 /* This duplicates the above code because the above code must not
2220 * get any slower by more conditions */
2228 register PERL_CONTEXT *cx;
2235 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2236 /* We are an argument to a function or grep().
2237 * This kind of lvalueness was legal before lvalue
2238 * subroutines too, so be backward compatible:
2239 * cannot report errors. */
2241 /* Scalar context *is* possible, on the LHS of -> only,
2242 * as in f()->meth(). But this is not an lvalue. */
2243 if (gimme == G_SCALAR)
2245 if (gimme == G_ARRAY) {
2246 if (!CvLVALUE(cx->blk_sub.cv))
2247 goto temporise_array;
2248 EXTEND_MORTAL(SP - newsp);
2249 for (mark = newsp + 1; mark <= SP; mark++) {
2252 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2253 *mark = sv_mortalcopy(*mark);
2255 /* Can be a localized value subject to deletion. */
2256 PL_tmps_stack[++PL_tmps_ix] = *mark;
2257 (void)SvREFCNT_inc(*mark);
2262 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2263 /* Here we go for robustness, not for speed, so we change all
2264 * the refcounts so the caller gets a live guy. Cannot set
2265 * TEMP, so sv_2mortal is out of question. */
2266 if (!CvLVALUE(cx->blk_sub.cv)) {
2271 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2273 if (gimme == G_SCALAR) {
2277 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2282 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2283 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2285 else { /* Can be a localized value
2286 * subject to deletion. */
2287 PL_tmps_stack[++PL_tmps_ix] = *mark;
2288 (void)SvREFCNT_inc(*mark);
2291 else { /* Should not happen? */
2296 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2297 (MARK > SP ? "Empty array" : "Array"));
2301 else if (gimme == G_ARRAY) {
2302 EXTEND_MORTAL(SP - newsp);
2303 for (mark = newsp + 1; mark <= SP; mark++) {
2304 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2305 /* Might be flattened array after $#array = */
2311 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2312 (*mark != &PL_sv_undef)
2314 ? "a readonly value" : "a temporary")
2315 : "an uninitialized value");
2318 /* Can be a localized value subject to deletion. */
2319 PL_tmps_stack[++PL_tmps_ix] = *mark;
2320 (void)SvREFCNT_inc(*mark);
2326 if (gimme == G_SCALAR) {
2330 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2332 *MARK = SvREFCNT_inc(TOPs);
2337 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2339 *MARK = sv_mortalcopy(sv);
2344 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2348 *MARK = &PL_sv_undef;
2352 else if (gimme == G_ARRAY) {
2354 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2355 if (!SvTEMP(*MARK)) {
2356 *MARK = sv_mortalcopy(*MARK);
2357 TAINT_NOT; /* Each item is independent */
2364 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2365 PL_curpm = newpm; /* ... and pop $1 et al */
2369 return pop_return();
2374 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2376 SV *dbsv = GvSV(PL_DBsub);
2378 if (!PERLDB_SUB_NN) {
2382 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2383 || strEQ(GvNAME(gv), "END")
2384 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2385 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2386 && (gv = (GV*)*svp) ))) {
2387 /* Use GV from the stack as a fallback. */
2388 /* GV is potentially non-unique, or contain different CV. */
2389 SV *tmp = newRV((SV*)cv);
2390 sv_setsv(dbsv, tmp);
2394 gv_efullname3(dbsv, gv, Nullch);
2398 (void)SvUPGRADE(dbsv, SVt_PVIV);
2399 (void)SvIOK_on(dbsv);
2400 SAVEIV(SvIVX(dbsv));
2401 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2405 PL_curcopdb = PL_curcop;
2406 cv = GvCV(PL_DBsub);
2416 register PERL_CONTEXT *cx;
2418 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2421 DIE(aTHX_ "Not a CODE reference");
2422 switch (SvTYPE(sv)) {
2428 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2430 SP = PL_stack_base + POPMARK;
2433 if (SvGMAGICAL(sv)) {
2435 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2438 sym = SvPV(sv, n_a);
2440 DIE(aTHX_ PL_no_usym, "a subroutine");
2441 if (PL_op->op_private & HINT_STRICT_REFS)
2442 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2443 cv = get_cv(sym, TRUE);
2447 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2448 tryAMAGICunDEREF(to_cv);
2451 if (SvTYPE(cv) == SVt_PVCV)
2456 DIE(aTHX_ "Not a CODE reference");
2461 if (!(cv = GvCVu((GV*)sv)))
2462 cv = sv_2cv(sv, &stash, &gv, FALSE);
2475 if (!CvROOT(cv) && !CvXSUB(cv)) {
2479 /* anonymous or undef'd function leaves us no recourse */
2480 if (CvANON(cv) || !(gv = CvGV(cv)))
2481 DIE(aTHX_ "Undefined subroutine called");
2483 /* autoloaded stub? */
2484 if (cv != GvCV(gv)) {
2487 /* should call AUTOLOAD now? */
2490 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2497 sub_name = sv_newmortal();
2498 gv_efullname3(sub_name, gv, Nullch);
2499 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2503 DIE(aTHX_ "Not a CODE reference");
2508 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2509 cv = get_db_sub(&sv, cv);
2511 DIE(aTHX_ "No DBsub routine");
2516 * First we need to check if the sub or method requires locking.
2517 * If so, we gain a lock on the CV, the first argument or the
2518 * stash (for static methods), as appropriate. This has to be
2519 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2520 * reschedule by returning a new op.
2522 MUTEX_LOCK(CvMUTEXP(cv));
2523 if (CvFLAGS(cv) & CVf_LOCKED) {
2525 if (CvFLAGS(cv) & CVf_METHOD) {
2526 if (SP > PL_stack_base + TOPMARK)
2527 sv = *(PL_stack_base + TOPMARK + 1);
2529 AV *av = (AV*)PL_curpad[0];
2530 if (hasargs || !av || AvFILLp(av) < 0
2531 || !(sv = AvARRAY(av)[0]))
2533 MUTEX_UNLOCK(CvMUTEXP(cv));
2534 DIE(aTHX_ "no argument for locked method call");
2541 char *stashname = SvPV(sv, len);
2542 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2548 MUTEX_UNLOCK(CvMUTEXP(cv));
2549 mg = condpair_magic(sv);
2550 MUTEX_LOCK(MgMUTEXP(mg));
2551 if (MgOWNER(mg) == thr)
2552 MUTEX_UNLOCK(MgMUTEXP(mg));
2555 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2557 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2559 MUTEX_UNLOCK(MgMUTEXP(mg));
2560 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2562 MUTEX_LOCK(CvMUTEXP(cv));
2565 * Now we have permission to enter the sub, we must distinguish
2566 * four cases. (0) It's an XSUB (in which case we don't care
2567 * about ownership); (1) it's ours already (and we're recursing);
2568 * (2) it's free (but we may already be using a cached clone);
2569 * (3) another thread owns it. Case (1) is easy: we just use it.
2570 * Case (2) means we look for a clone--if we have one, use it
2571 * otherwise grab ownership of cv. Case (3) means we look for a
2572 * clone (for non-XSUBs) and have to create one if we don't
2574 * Why look for a clone in case (2) when we could just grab
2575 * ownership of cv straight away? Well, we could be recursing,
2576 * i.e. we originally tried to enter cv while another thread
2577 * owned it (hence we used a clone) but it has been freed up
2578 * and we're now recursing into it. It may or may not be "better"
2579 * to use the clone but at least CvDEPTH can be trusted.
2581 if (CvOWNER(cv) == thr || CvXSUB(cv))
2582 MUTEX_UNLOCK(CvMUTEXP(cv));
2584 /* Case (2) or (3) */
2588 * XXX Might it be better to release CvMUTEXP(cv) while we
2589 * do the hv_fetch? We might find someone has pinched it
2590 * when we look again, in which case we would be in case
2591 * (3) instead of (2) so we'd have to clone. Would the fact
2592 * that we released the mutex more quickly make up for this?
2594 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2596 /* We already have a clone to use */
2597 MUTEX_UNLOCK(CvMUTEXP(cv));
2599 DEBUG_S(PerlIO_printf(Perl_debug_log,
2600 "entersub: %p already has clone %p:%s\n",
2601 thr, cv, SvPEEK((SV*)cv)));
2604 if (CvDEPTH(cv) == 0)
2605 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2608 /* (2) => grab ownership of cv. (3) => make clone */
2612 MUTEX_UNLOCK(CvMUTEXP(cv));
2613 DEBUG_S(PerlIO_printf(Perl_debug_log,
2614 "entersub: %p grabbing %p:%s in stash %s\n",
2615 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2616 HvNAME(CvSTASH(cv)) : "(none)"));
2619 /* Make a new clone. */
2621 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2622 MUTEX_UNLOCK(CvMUTEXP(cv));
2623 DEBUG_S((PerlIO_printf(Perl_debug_log,
2624 "entersub: %p cloning %p:%s\n",
2625 thr, cv, SvPEEK((SV*)cv))));
2627 * We're creating a new clone so there's no race
2628 * between the original MUTEX_UNLOCK and the
2629 * SvREFCNT_inc since no one will be trying to undef
2630 * it out from underneath us. At least, I don't think
2633 clonecv = cv_clone(cv);
2634 SvREFCNT_dec(cv); /* finished with this */
2635 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2636 CvOWNER(clonecv) = thr;
2640 DEBUG_S(if (CvDEPTH(cv) != 0)
2641 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2643 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2646 #endif /* USE_THREADS */
2649 #ifdef PERL_XSUB_OLDSTYLE
2650 if (CvOLDSTYLE(cv)) {
2651 I32 (*fp3)(int,int,int);
2653 register I32 items = SP - MARK;
2654 /* We dont worry to copy from @_. */
2659 PL_stack_sp = mark + 1;
2660 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2661 items = (*fp3)(CvXSUBANY(cv).any_i32,
2662 MARK - PL_stack_base + 1,
2664 PL_stack_sp = PL_stack_base + items;
2667 #endif /* PERL_XSUB_OLDSTYLE */
2669 I32 markix = TOPMARK;
2674 /* Need to copy @_ to stack. Alternative may be to
2675 * switch stack to @_, and copy return values
2676 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2680 av = (AV*)PL_curpad[0];
2682 av = GvAV(PL_defgv);
2683 #endif /* USE_THREADS */
2684 items = AvFILLp(av) + 1; /* @_ is not tieable */
2687 /* Mark is at the end of the stack. */
2689 Copy(AvARRAY(av), SP + 1, items, SV*);
2694 /* We assume first XSUB in &DB::sub is the called one. */
2696 SAVEVPTR(PL_curcop);
2697 PL_curcop = PL_curcopdb;
2700 /* Do we need to open block here? XXXX */
2701 (void)(*CvXSUB(cv))(aTHXo_ cv);
2703 /* Enforce some sanity in scalar context. */
2704 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2705 if (markix > PL_stack_sp - PL_stack_base)
2706 *(PL_stack_base + markix) = &PL_sv_undef;
2708 *(PL_stack_base + markix) = *PL_stack_sp;
2709 PL_stack_sp = PL_stack_base + markix;
2717 register I32 items = SP - MARK;
2718 AV* padlist = CvPADLIST(cv);
2719 SV** svp = AvARRAY(padlist);
2720 push_return(PL_op->op_next);
2721 PUSHBLOCK(cx, CXt_SUB, MARK);
2724 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2725 * that eval'' ops within this sub know the correct lexical space.
2726 * Owing the speed considerations, we choose to search for the cv
2727 * in doeval() instead.
2729 if (CvDEPTH(cv) < 2)
2730 (void)SvREFCNT_inc(cv);
2731 else { /* save temporaries on recursion? */
2732 PERL_STACK_OVERFLOW_CHECK();
2733 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2735 AV *newpad = newAV();
2736 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2737 I32 ix = AvFILLp((AV*)svp[1]);
2738 I32 names_fill = AvFILLp((AV*)svp[0]);
2739 svp = AvARRAY(svp[0]);
2740 for ( ;ix > 0; ix--) {
2741 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2742 char *name = SvPVX(svp[ix]);
2743 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2744 || *name == '&') /* anonymous code? */
2746 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2748 else { /* our own lexical */
2750 av_store(newpad, ix, sv = (SV*)newAV());
2751 else if (*name == '%')
2752 av_store(newpad, ix, sv = (SV*)newHV());
2754 av_store(newpad, ix, sv = NEWSV(0,0));
2758 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2759 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2762 av_store(newpad, ix, sv = NEWSV(0,0));
2766 av = newAV(); /* will be @_ */
2768 av_store(newpad, 0, (SV*)av);
2769 AvFLAGS(av) = AVf_REIFY;
2770 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2771 AvFILLp(padlist) = CvDEPTH(cv);
2772 svp = AvARRAY(padlist);
2777 AV* av = (AV*)PL_curpad[0];
2779 items = AvFILLp(av) + 1;
2781 /* Mark is at the end of the stack. */
2783 Copy(AvARRAY(av), SP + 1, items, SV*);
2788 #endif /* USE_THREADS */
2789 SAVEVPTR(PL_curpad);
2790 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2793 #endif /* USE_THREADS */
2799 DEBUG_S(PerlIO_printf(Perl_debug_log,
2800 "%p entersub preparing @_\n", thr));
2802 av = (AV*)PL_curpad[0];
2804 /* @_ is normally not REAL--this should only ever
2805 * happen when DB::sub() calls things that modify @_ */
2811 cx->blk_sub.savearray = GvAV(PL_defgv);
2812 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2813 #endif /* USE_THREADS */
2814 cx->blk_sub.oldcurpad = PL_curpad;
2815 cx->blk_sub.argarray = av;
2818 if (items > AvMAX(av) + 1) {
2820 if (AvARRAY(av) != ary) {
2821 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2822 SvPVX(av) = (char*)ary;
2824 if (items > AvMAX(av) + 1) {
2825 AvMAX(av) = items - 1;
2826 Renew(ary,items,SV*);
2828 SvPVX(av) = (char*)ary;
2831 Copy(MARK,AvARRAY(av),items,SV*);
2832 AvFILLp(av) = items - 1;
2840 /* warning must come *after* we fully set up the context
2841 * stuff so that __WARN__ handlers can safely dounwind()
2844 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2845 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2846 sub_crush_depth(cv);
2848 DEBUG_S(PerlIO_printf(Perl_debug_log,
2849 "%p entersub returning %p\n", thr, CvSTART(cv)));
2851 RETURNOP(CvSTART(cv));
2856 Perl_sub_crush_depth(pTHX_ CV *cv)
2859 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2861 SV* tmpstr = sv_newmortal();
2862 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2863 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2873 IV elem = SvIV(elemsv);
2875 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2876 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2879 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2880 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2882 elem -= PL_curcop->cop_arybase;
2883 if (SvTYPE(av) != SVt_PVAV)
2885 svp = av_fetch(av, elem, lval && !defer);
2887 if (!svp || *svp == &PL_sv_undef) {
2890 DIE(aTHX_ PL_no_aelem, elem);
2891 lv = sv_newmortal();
2892 sv_upgrade(lv, SVt_PVLV);
2894 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2895 LvTARG(lv) = SvREFCNT_inc(av);
2896 LvTARGOFF(lv) = elem;
2901 if (PL_op->op_private & OPpLVAL_INTRO)
2902 save_aelem(av, elem, svp);
2903 else if (PL_op->op_private & OPpDEREF)
2904 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2906 sv = (svp ? *svp : &PL_sv_undef);
2907 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2908 sv = sv_mortalcopy(sv);
2914 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2920 Perl_croak(aTHX_ PL_no_modify);
2921 if (SvTYPE(sv) < SVt_RV)
2922 sv_upgrade(sv, SVt_RV);
2923 else if (SvTYPE(sv) >= SVt_PV) {
2924 (void)SvOOK_off(sv);
2925 Safefree(SvPVX(sv));
2926 SvLEN(sv) = SvCUR(sv) = 0;
2930 SvRV(sv) = NEWSV(355,0);
2933 SvRV(sv) = (SV*)newAV();
2936 SvRV(sv) = (SV*)newHV();
2951 if (SvTYPE(rsv) == SVt_PVCV) {
2957 SETs(method_common(sv, Null(U32*)));
2964 SV* sv = cSVOP->op_sv;
2965 U32 hash = SvUVX(sv);
2967 XPUSHs(method_common(sv, &hash));
2972 S_method_common(pTHX_ SV* meth, U32* hashp)
2983 name = SvPV(meth, namelen);
2984 sv = *(PL_stack_base + TOPMARK + 1);
2987 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2998 !(packname = SvPV(sv, packlen)) ||
2999 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3000 !(ob=(SV*)GvIO(iogv)))
3003 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3004 ? !isIDFIRST_utf8((U8*)packname)
3005 : !isIDFIRST(*packname)
3008 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3009 SvOK(sv) ? "without a package or object reference"
3010 : "on an undefined value");
3012 stash = gv_stashpvn(packname, packlen, TRUE);
3015 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3018 if (!ob || !(SvOBJECT(ob)
3019 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3022 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3026 stash = SvSTASH(ob);
3029 /* shortcut for simple names */
3031 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3033 gv = (GV*)HeVAL(he);
3034 if (isGV(gv) && GvCV(gv) &&
3035 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3036 return (SV*)GvCV(gv);
3040 gv = gv_fetchmethod(stash, name);
3047 for (p = name; *p; p++) {
3049 sep = p, leaf = p + 1;
3050 else if (*p == ':' && *(p + 1) == ':')
3051 sep = p, leaf = p + 2;
3053 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3054 packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
3055 packlen = strlen(packname);
3059 packlen = sep - name;
3061 gv = gv_fetchpv(packname, 0, SVt_PVHV);
3062 if (gv && isGV(gv)) {
3064 "Can't locate object method \"%s\" via package \"%s\"",
3069 "Can't locate object method \"%s\" via package \"%s\""
3070 " (perhaps you forgot to load \"%s\"?)",
3071 leaf, packname, packname);
3074 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3079 unset_cvowner(pTHXo_ void *cvarg)
3081 register CV* cv = (CV *) cvarg;
3083 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3084 thr, cv, SvPEEK((SV*)cv))));
3085 MUTEX_LOCK(CvMUTEXP(cv));
3086 DEBUG_S(if (CvDEPTH(cv) != 0)
3087 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3089 assert(thr == CvOWNER(cv));
3091 MUTEX_UNLOCK(CvMUTEXP(cv));
3094 #endif /* USE_THREADS */