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);
161 /* $right = $right . $right; */
163 char *rpv = SvPV(right, rlen);
165 sv_catpvn(TARG, rpv, rlen);
167 else /* $right = $left . $right; */
168 sv_catsv(TARG, rcopy);
171 if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
173 /* $other = $left . $right; */
174 /* $left = $left . $right; */
175 sv_catsv(TARG, right);
178 #if defined(PERL_Y2KWARN)
179 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
181 char *s = SvPV(TARG,n);
182 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
183 && (n == 2 || !isDIGIT(s[n-3])))
185 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
186 "about to append an integer to '19'");
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 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1283 if ( (rx->reganch & ROPT_CHECK_ALL)
1285 && ((rx->reganch & ROPT_NOSCAN)
1286 || !((rx->reganch & RE_INTUIT_TAIL)
1287 && (r_flags & REXEC_SCREAM)))
1288 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1291 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1294 if (pm->op_pmflags & PMf_ONCE)
1295 pm->op_pmdynflags |= PMdf_USED;
1304 RX_MATCH_TAINTED_on(rx);
1305 TAINT_IF(RX_MATCH_TAINTED(rx));
1306 if (gimme == G_ARRAY) {
1307 I32 nparens, i, len;
1309 nparens = rx->nparens;
1310 if (global && !nparens)
1314 SPAGAIN; /* EVAL blocks could move the stack. */
1315 EXTEND(SP, nparens + i);
1316 EXTEND_MORTAL(nparens + i);
1317 for (i = !i; i <= nparens; i++) {
1318 PUSHs(sv_newmortal());
1320 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1321 len = rx->endp[i] - rx->startp[i];
1322 s = rx->startp[i] + truebase;
1323 sv_setpvn(*SP, s, len);
1329 had_zerolen = (rx->startp[0] != -1
1330 && rx->startp[0] == rx->endp[0]);
1331 PUTBACK; /* EVAL blocks may use stack */
1332 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1337 LEAVE_SCOPE(oldsave);
1343 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1344 mg = mg_find(TARG, 'g');
1346 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1347 mg = mg_find(TARG, 'g');
1349 if (rx->startp[0] != -1) {
1350 mg->mg_len = rx->endp[0];
1351 if (rx->startp[0] == rx->endp[0])
1352 mg->mg_flags |= MGf_MINMATCH;
1354 mg->mg_flags &= ~MGf_MINMATCH;
1357 LEAVE_SCOPE(oldsave);
1361 yup: /* Confirmed by INTUIT */
1363 RX_MATCH_TAINTED_on(rx);
1364 TAINT_IF(RX_MATCH_TAINTED(rx));
1366 if (pm->op_pmflags & PMf_ONCE)
1367 pm->op_pmdynflags |= PMdf_USED;
1368 if (RX_MATCH_COPIED(rx))
1369 Safefree(rx->subbeg);
1370 RX_MATCH_COPIED_off(rx);
1371 rx->subbeg = Nullch;
1373 rx->subbeg = truebase;
1374 rx->startp[0] = s - truebase;
1375 if (DO_UTF8(PL_reg_sv)) {
1376 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1377 rx->endp[0] = t - truebase;
1380 rx->endp[0] = s - truebase + rx->minlen;
1382 rx->sublen = strend - truebase;
1385 if (PL_sawampersand) {
1388 rx->subbeg = savepvn(t, strend - t);
1389 rx->sublen = strend - t;
1390 RX_MATCH_COPIED_on(rx);
1391 off = rx->startp[0] = s - t;
1392 rx->endp[0] = off + rx->minlen;
1394 else { /* startp/endp are used by @- @+. */
1395 rx->startp[0] = s - truebase;
1396 rx->endp[0] = s - truebase + rx->minlen;
1398 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
1399 LEAVE_SCOPE(oldsave);
1404 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1405 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1406 MAGIC* mg = mg_find(TARG, 'g');
1411 LEAVE_SCOPE(oldsave);
1412 if (gimme == G_ARRAY)
1418 Perl_do_readline(pTHX)
1420 dSP; dTARGETSTACKED;
1425 register IO *io = GvIO(PL_last_in_gv);
1426 register I32 type = PL_op->op_type;
1427 I32 gimme = GIMME_V;
1430 if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
1432 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1435 call_method("READLINE", gimme);
1438 if (gimme == G_SCALAR)
1439 SvSetMagicSV_nosteal(TARG, TOPs);
1446 if (IoFLAGS(io) & IOf_ARGV) {
1447 if (IoFLAGS(io) & IOf_START) {
1449 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1450 IoFLAGS(io) &= ~IOf_START;
1451 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1452 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1453 SvSETMAGIC(GvSV(PL_last_in_gv));
1458 fp = nextargv(PL_last_in_gv);
1459 if (!fp) { /* Note: fp != IoIFP(io) */
1460 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1463 else if (type == OP_GLOB)
1464 fp = Perl_start_glob(aTHX_ POPs, io);
1466 else if (type == OP_GLOB)
1468 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1469 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1473 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1474 && (!io || !(IoFLAGS(io) & IOf_START))) {
1475 if (type == OP_GLOB)
1476 Perl_warner(aTHX_ WARN_GLOB,
1477 "glob failed (can't start child: %s)",
1480 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1482 if (gimme == G_SCALAR) {
1483 (void)SvOK_off(TARG);
1489 if (gimme == G_SCALAR) {
1493 (void)SvUPGRADE(sv, SVt_PV);
1494 tmplen = SvLEN(sv); /* remember if already alloced */
1496 Sv_Grow(sv, 80); /* try short-buffering it */
1497 if (type == OP_RCATLINE)
1503 sv = sv_2mortal(NEWSV(57, 80));
1507 /* This should not be marked tainted if the fp is marked clean */
1508 #define MAYBE_TAINT_LINE(io, sv) \
1509 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1514 /* delay EOF state for a snarfed empty file */
1515 #define SNARF_EOF(gimme,rs,io,sv) \
1516 (gimme != G_SCALAR || SvCUR(sv) \
1517 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1521 if (!sv_gets(sv, fp, offset)
1522 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1524 PerlIO_clearerr(fp);
1525 if (IoFLAGS(io) & IOf_ARGV) {
1526 fp = nextargv(PL_last_in_gv);
1529 (void)do_close(PL_last_in_gv, FALSE);
1531 else if (type == OP_GLOB) {
1532 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1533 Perl_warner(aTHX_ WARN_GLOB,
1534 "glob failed (child exited with status %d%s)",
1535 (int)(STATUS_CURRENT >> 8),
1536 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1539 if (gimme == G_SCALAR) {
1540 (void)SvOK_off(TARG);
1544 MAYBE_TAINT_LINE(io, sv);
1547 MAYBE_TAINT_LINE(io, sv);
1549 IoFLAGS(io) |= IOf_NOLINE;
1553 if (type == OP_GLOB) {
1556 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1557 tmps = SvEND(sv) - 1;
1558 if (*tmps == *SvPVX(PL_rs)) {
1563 for (tmps = SvPVX(sv); *tmps; tmps++)
1564 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1565 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1567 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1568 (void)POPs; /* Unmatched wildcard? Chuck it... */
1572 if (gimme == G_ARRAY) {
1573 if (SvLEN(sv) - SvCUR(sv) > 20) {
1574 SvLEN_set(sv, SvCUR(sv)+1);
1575 Renew(SvPVX(sv), SvLEN(sv), char);
1577 sv = sv_2mortal(NEWSV(58, 80));
1580 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1581 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1585 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1586 Renew(SvPVX(sv), SvLEN(sv), char);
1595 register PERL_CONTEXT *cx;
1596 I32 gimme = OP_GIMME(PL_op, -1);
1599 if (cxstack_ix >= 0)
1600 gimme = cxstack[cxstack_ix].blk_gimme;
1608 PUSHBLOCK(cx, CXt_BLOCK, SP);
1620 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1621 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1623 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1626 if (SvTYPE(hv) == SVt_PVHV) {
1627 if (PL_op->op_private & OPpLVAL_INTRO)
1628 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1629 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1630 svp = he ? &HeVAL(he) : 0;
1632 else if (SvTYPE(hv) == SVt_PVAV) {
1633 if (PL_op->op_private & OPpLVAL_INTRO)
1634 DIE(aTHX_ "Can't localize pseudo-hash element");
1635 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1641 if (!svp || *svp == &PL_sv_undef) {
1646 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1648 lv = sv_newmortal();
1649 sv_upgrade(lv, SVt_PVLV);
1651 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1652 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1653 LvTARG(lv) = SvREFCNT_inc(hv);
1658 if (PL_op->op_private & OPpLVAL_INTRO) {
1659 if (HvNAME(hv) && isGV(*svp))
1660 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1664 char *key = SvPV(keysv, keylen);
1665 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1667 save_helem(hv, keysv, svp);
1670 else if (PL_op->op_private & OPpDEREF)
1671 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1673 sv = (svp ? *svp : &PL_sv_undef);
1674 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1675 * Pushing the magical RHS on to the stack is useless, since
1676 * that magic is soon destined to be misled by the local(),
1677 * and thus the later pp_sassign() will fail to mg_get() the
1678 * old value. This should also cure problems with delayed
1679 * mg_get()s. GSAR 98-07-03 */
1680 if (!lval && SvGMAGICAL(sv))
1681 sv = sv_mortalcopy(sv);
1689 register PERL_CONTEXT *cx;
1695 if (PL_op->op_flags & OPf_SPECIAL) {
1696 cx = &cxstack[cxstack_ix];
1697 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1702 gimme = OP_GIMME(PL_op, -1);
1704 if (cxstack_ix >= 0)
1705 gimme = cxstack[cxstack_ix].blk_gimme;
1711 if (gimme == G_VOID)
1713 else if (gimme == G_SCALAR) {
1716 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1719 *MARK = sv_mortalcopy(TOPs);
1722 *MARK = &PL_sv_undef;
1726 else if (gimme == G_ARRAY) {
1727 /* in case LEAVE wipes old return values */
1728 for (mark = newsp + 1; mark <= SP; mark++) {
1729 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1730 *mark = sv_mortalcopy(*mark);
1731 TAINT_NOT; /* Each item is independent */
1735 PL_curpm = newpm; /* Don't pop $1 et al till now */
1745 register PERL_CONTEXT *cx;
1751 cx = &cxstack[cxstack_ix];
1752 if (CxTYPE(cx) != CXt_LOOP)
1753 DIE(aTHX_ "panic: pp_iter");
1755 itersvp = CxITERVAR(cx);
1756 av = cx->blk_loop.iterary;
1757 if (SvTYPE(av) != SVt_PVAV) {
1758 /* iterate ($min .. $max) */
1759 if (cx->blk_loop.iterlval) {
1760 /* string increment */
1761 register SV* cur = cx->blk_loop.iterlval;
1763 char *max = SvPV((SV*)av, maxlen);
1764 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1765 #ifndef USE_THREADS /* don't risk potential race */
1766 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1767 /* safe to reuse old SV */
1768 sv_setsv(*itersvp, cur);
1773 /* we need a fresh SV every time so that loop body sees a
1774 * completely new SV for closures/references to work as
1776 SvREFCNT_dec(*itersvp);
1777 *itersvp = newSVsv(cur);
1779 if (strEQ(SvPVX(cur), max))
1780 sv_setiv(cur, 0); /* terminate next time */
1787 /* integer increment */
1788 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1791 #ifndef USE_THREADS /* don't risk potential race */
1792 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1793 /* safe to reuse old SV */
1794 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1799 /* we need a fresh SV every time so that loop body sees a
1800 * completely new SV for closures/references to work as they
1802 SvREFCNT_dec(*itersvp);
1803 *itersvp = newSViv(cx->blk_loop.iterix++);
1809 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1812 SvREFCNT_dec(*itersvp);
1814 if ((sv = SvMAGICAL(av)
1815 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1816 : AvARRAY(av)[++cx->blk_loop.iterix]))
1820 if (av != PL_curstack && SvIMMORTAL(sv)) {
1821 SV *lv = cx->blk_loop.iterlval;
1822 if (lv && SvREFCNT(lv) > 1) {
1827 SvREFCNT_dec(LvTARG(lv));
1829 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1830 sv_upgrade(lv, SVt_PVLV);
1832 sv_magic(lv, Nullsv, 'y', Nullch, 0);
1834 LvTARG(lv) = SvREFCNT_inc(av);
1835 LvTARGOFF(lv) = cx->blk_loop.iterix;
1836 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1840 *itersvp = SvREFCNT_inc(sv);
1847 register PMOP *pm = cPMOP;
1863 register REGEXP *rx = pm->op_pmregexp;
1865 int force_on_match = 0;
1866 I32 oldsave = PL_savestack_ix;
1870 /* known replacement string? */
1871 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1872 if (PL_op->op_flags & OPf_STACKED)
1879 do_utf8 = DO_UTF8(PL_reg_sv);
1880 if (SvFAKE(TARG) && SvREADONLY(TARG))
1881 sv_force_normal(TARG);
1882 if (SvREADONLY(TARG)
1883 || (SvTYPE(TARG) > SVt_PVLV
1884 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1885 DIE(aTHX_ PL_no_modify);
1888 s = SvPV(TARG, len);
1889 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1891 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1892 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1899 DIE(aTHX_ "panic: pp_subst");
1902 slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1903 maxiters = 2 * slen + 10; /* We can match twice at each
1904 position, once with zero-length,
1905 second time with non-zero. */
1907 if (!rx->prelen && PL_curpm) {
1909 rx = pm->op_pmregexp;
1911 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1912 ? REXEC_COPY_STR : 0;
1914 r_flags |= REXEC_SCREAM;
1915 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1916 SAVEINT(PL_multiline);
1917 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1920 if (rx->reganch & RE_USE_INTUIT) {
1921 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1925 /* How to do it in subst? */
1926 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1928 && ((rx->reganch & ROPT_NOSCAN)
1929 || !((rx->reganch & RE_INTUIT_TAIL)
1930 && (r_flags & REXEC_SCREAM))))
1935 /* only replace once? */
1936 once = !(rpm->op_pmflags & PMf_GLOBAL);
1938 /* known replacement string? */
1939 c = dstr ? SvPV(dstr, clen) : Nullch;
1941 /* can do inplace substitution? */
1942 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1943 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1944 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1945 r_flags | REXEC_CHECKED))
1949 LEAVE_SCOPE(oldsave);
1952 if (force_on_match) {
1954 s = SvPV_force(TARG, len);
1959 SvSCREAM_off(TARG); /* disable possible screamer */
1961 rxtainted |= RX_MATCH_TAINTED(rx);
1962 m = orig + rx->startp[0];
1963 d = orig + rx->endp[0];
1965 if (m - s > strend - d) { /* faster to shorten from end */
1967 Copy(c, m, clen, char);
1972 Move(d, m, i, char);
1976 SvCUR_set(TARG, m - s);
1979 else if ((i = m - s)) { /* faster from front */
1987 Copy(c, m, clen, char);
1992 Copy(c, d, clen, char);
1997 TAINT_IF(rxtainted & 1);
2003 if (iters++ > maxiters)
2004 DIE(aTHX_ "Substitution loop");
2005 rxtainted |= RX_MATCH_TAINTED(rx);
2006 m = rx->startp[0] + orig;
2010 Move(s, d, i, char);
2014 Copy(c, d, clen, char);
2017 s = rx->endp[0] + orig;
2018 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2020 /* don't match same null twice */
2021 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2024 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2025 Move(s, d, i+1, char); /* include the NUL */
2027 TAINT_IF(rxtainted & 1);
2029 PUSHs(sv_2mortal(newSViv((I32)iters)));
2031 (void)SvPOK_only_UTF8(TARG);
2032 TAINT_IF(rxtainted);
2033 if (SvSMAGICAL(TARG)) {
2039 LEAVE_SCOPE(oldsave);
2043 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2044 r_flags | REXEC_CHECKED))
2048 if (force_on_match) {
2050 s = SvPV_force(TARG, len);
2053 rxtainted |= RX_MATCH_TAINTED(rx);
2054 dstr = NEWSV(25, len);
2055 sv_setpvn(dstr, m, s-m);
2060 register PERL_CONTEXT *cx;
2063 RETURNOP(cPMOP->op_pmreplroot);
2065 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2067 if (iters++ > maxiters)
2068 DIE(aTHX_ "Substitution loop");
2069 rxtainted |= RX_MATCH_TAINTED(rx);
2070 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2075 strend = s + (strend - m);
2077 m = rx->startp[0] + orig;
2078 sv_catpvn(dstr, s, m-s);
2079 s = rx->endp[0] + orig;
2081 sv_catpvn(dstr, c, clen);
2084 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2085 TARG, NULL, r_flags));
2086 sv_catpvn(dstr, s, strend - s);
2088 (void)SvOOK_off(TARG);
2089 Safefree(SvPVX(TARG));
2090 SvPVX(TARG) = SvPVX(dstr);
2091 SvCUR_set(TARG, SvCUR(dstr));
2092 SvLEN_set(TARG, SvLEN(dstr));
2093 isutf8 = DO_UTF8(dstr);
2097 TAINT_IF(rxtainted & 1);
2099 PUSHs(sv_2mortal(newSViv((I32)iters)));
2101 (void)SvPOK_only(TARG);
2104 TAINT_IF(rxtainted);
2107 LEAVE_SCOPE(oldsave);
2116 LEAVE_SCOPE(oldsave);
2125 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2126 ++*PL_markstack_ptr;
2127 LEAVE; /* exit inner scope */
2130 if (PL_stack_base + *PL_markstack_ptr > SP) {
2132 I32 gimme = GIMME_V;
2134 LEAVE; /* exit outer scope */
2135 (void)POPMARK; /* pop src */
2136 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2137 (void)POPMARK; /* pop dst */
2138 SP = PL_stack_base + POPMARK; /* pop original mark */
2139 if (gimme == G_SCALAR) {
2143 else if (gimme == G_ARRAY)
2150 ENTER; /* enter inner scope */
2153 src = PL_stack_base[*PL_markstack_ptr];
2157 RETURNOP(cLOGOP->op_other);
2168 register PERL_CONTEXT *cx;
2174 if (gimme == G_SCALAR) {
2177 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2179 *MARK = SvREFCNT_inc(TOPs);
2184 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2186 *MARK = sv_mortalcopy(sv);
2191 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2195 *MARK = &PL_sv_undef;
2199 else if (gimme == G_ARRAY) {
2200 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2201 if (!SvTEMP(*MARK)) {
2202 *MARK = sv_mortalcopy(*MARK);
2203 TAINT_NOT; /* Each item is independent */
2209 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2210 PL_curpm = newpm; /* ... and pop $1 et al */
2214 return pop_return();
2217 /* This duplicates the above code because the above code must not
2218 * get any slower by more conditions */
2226 register PERL_CONTEXT *cx;
2233 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2234 /* We are an argument to a function or grep().
2235 * This kind of lvalueness was legal before lvalue
2236 * subroutines too, so be backward compatible:
2237 * cannot report errors. */
2239 /* Scalar context *is* possible, on the LHS of -> only,
2240 * as in f()->meth(). But this is not an lvalue. */
2241 if (gimme == G_SCALAR)
2243 if (gimme == G_ARRAY) {
2244 if (!CvLVALUE(cx->blk_sub.cv))
2245 goto temporise_array;
2246 EXTEND_MORTAL(SP - newsp);
2247 for (mark = newsp + 1; mark <= SP; mark++) {
2250 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2251 *mark = sv_mortalcopy(*mark);
2253 /* Can be a localized value subject to deletion. */
2254 PL_tmps_stack[++PL_tmps_ix] = *mark;
2255 (void)SvREFCNT_inc(*mark);
2260 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2261 /* Here we go for robustness, not for speed, so we change all
2262 * the refcounts so the caller gets a live guy. Cannot set
2263 * TEMP, so sv_2mortal is out of question. */
2264 if (!CvLVALUE(cx->blk_sub.cv)) {
2269 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2271 if (gimme == G_SCALAR) {
2275 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2280 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2281 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2283 else { /* Can be a localized value
2284 * subject to deletion. */
2285 PL_tmps_stack[++PL_tmps_ix] = *mark;
2286 (void)SvREFCNT_inc(*mark);
2289 else { /* Should not happen? */
2294 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2295 (MARK > SP ? "Empty array" : "Array"));
2299 else if (gimme == G_ARRAY) {
2300 EXTEND_MORTAL(SP - newsp);
2301 for (mark = newsp + 1; mark <= SP; mark++) {
2302 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2303 /* Might be flattened array after $#array = */
2309 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2310 (*mark != &PL_sv_undef)
2312 ? "a readonly value" : "a temporary")
2313 : "an uninitialized value");
2316 /* Can be a localized value subject to deletion. */
2317 PL_tmps_stack[++PL_tmps_ix] = *mark;
2318 (void)SvREFCNT_inc(*mark);
2324 if (gimme == G_SCALAR) {
2328 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2330 *MARK = SvREFCNT_inc(TOPs);
2335 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2337 *MARK = sv_mortalcopy(sv);
2342 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2346 *MARK = &PL_sv_undef;
2350 else if (gimme == G_ARRAY) {
2352 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2353 if (!SvTEMP(*MARK)) {
2354 *MARK = sv_mortalcopy(*MARK);
2355 TAINT_NOT; /* Each item is independent */
2362 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2363 PL_curpm = newpm; /* ... and pop $1 et al */
2367 return pop_return();
2372 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2374 SV *dbsv = GvSV(PL_DBsub);
2376 if (!PERLDB_SUB_NN) {
2380 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2381 || strEQ(GvNAME(gv), "END")
2382 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2383 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2384 && (gv = (GV*)*svp) ))) {
2385 /* Use GV from the stack as a fallback. */
2386 /* GV is potentially non-unique, or contain different CV. */
2387 SV *tmp = newRV((SV*)cv);
2388 sv_setsv(dbsv, tmp);
2392 gv_efullname3(dbsv, gv, Nullch);
2396 (void)SvUPGRADE(dbsv, SVt_PVIV);
2397 (void)SvIOK_on(dbsv);
2398 SAVEIV(SvIVX(dbsv));
2399 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
2403 PL_curcopdb = PL_curcop;
2404 cv = GvCV(PL_DBsub);
2414 register PERL_CONTEXT *cx;
2416 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2419 DIE(aTHX_ "Not a CODE reference");
2420 switch (SvTYPE(sv)) {
2426 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2428 SP = PL_stack_base + POPMARK;
2431 if (SvGMAGICAL(sv)) {
2433 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2436 sym = SvPV(sv, n_a);
2438 DIE(aTHX_ PL_no_usym, "a subroutine");
2439 if (PL_op->op_private & HINT_STRICT_REFS)
2440 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2441 cv = get_cv(sym, TRUE);
2445 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2446 tryAMAGICunDEREF(to_cv);
2449 if (SvTYPE(cv) == SVt_PVCV)
2454 DIE(aTHX_ "Not a CODE reference");
2459 if (!(cv = GvCVu((GV*)sv)))
2460 cv = sv_2cv(sv, &stash, &gv, FALSE);
2473 if (!CvROOT(cv) && !CvXSUB(cv)) {
2477 /* anonymous or undef'd function leaves us no recourse */
2478 if (CvANON(cv) || !(gv = CvGV(cv)))
2479 DIE(aTHX_ "Undefined subroutine called");
2481 /* autoloaded stub? */
2482 if (cv != GvCV(gv)) {
2485 /* should call AUTOLOAD now? */
2488 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2495 sub_name = sv_newmortal();
2496 gv_efullname3(sub_name, gv, Nullch);
2497 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2501 DIE(aTHX_ "Not a CODE reference");
2506 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2507 cv = get_db_sub(&sv, cv);
2509 DIE(aTHX_ "No DBsub routine");
2514 * First we need to check if the sub or method requires locking.
2515 * If so, we gain a lock on the CV, the first argument or the
2516 * stash (for static methods), as appropriate. This has to be
2517 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2518 * reschedule by returning a new op.
2520 MUTEX_LOCK(CvMUTEXP(cv));
2521 if (CvFLAGS(cv) & CVf_LOCKED) {
2523 if (CvFLAGS(cv) & CVf_METHOD) {
2524 if (SP > PL_stack_base + TOPMARK)
2525 sv = *(PL_stack_base + TOPMARK + 1);
2527 AV *av = (AV*)PL_curpad[0];
2528 if (hasargs || !av || AvFILLp(av) < 0
2529 || !(sv = AvARRAY(av)[0]))
2531 MUTEX_UNLOCK(CvMUTEXP(cv));
2532 DIE(aTHX_ "no argument for locked method call");
2539 char *stashname = SvPV(sv, len);
2540 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2546 MUTEX_UNLOCK(CvMUTEXP(cv));
2547 mg = condpair_magic(sv);
2548 MUTEX_LOCK(MgMUTEXP(mg));
2549 if (MgOWNER(mg) == thr)
2550 MUTEX_UNLOCK(MgMUTEXP(mg));
2553 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2555 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2557 MUTEX_UNLOCK(MgMUTEXP(mg));
2558 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2560 MUTEX_LOCK(CvMUTEXP(cv));
2563 * Now we have permission to enter the sub, we must distinguish
2564 * four cases. (0) It's an XSUB (in which case we don't care
2565 * about ownership); (1) it's ours already (and we're recursing);
2566 * (2) it's free (but we may already be using a cached clone);
2567 * (3) another thread owns it. Case (1) is easy: we just use it.
2568 * Case (2) means we look for a clone--if we have one, use it
2569 * otherwise grab ownership of cv. Case (3) means we look for a
2570 * clone (for non-XSUBs) and have to create one if we don't
2572 * Why look for a clone in case (2) when we could just grab
2573 * ownership of cv straight away? Well, we could be recursing,
2574 * i.e. we originally tried to enter cv while another thread
2575 * owned it (hence we used a clone) but it has been freed up
2576 * and we're now recursing into it. It may or may not be "better"
2577 * to use the clone but at least CvDEPTH can be trusted.
2579 if (CvOWNER(cv) == thr || CvXSUB(cv))
2580 MUTEX_UNLOCK(CvMUTEXP(cv));
2582 /* Case (2) or (3) */
2586 * XXX Might it be better to release CvMUTEXP(cv) while we
2587 * do the hv_fetch? We might find someone has pinched it
2588 * when we look again, in which case we would be in case
2589 * (3) instead of (2) so we'd have to clone. Would the fact
2590 * that we released the mutex more quickly make up for this?
2592 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2594 /* We already have a clone to use */
2595 MUTEX_UNLOCK(CvMUTEXP(cv));
2597 DEBUG_S(PerlIO_printf(Perl_debug_log,
2598 "entersub: %p already has clone %p:%s\n",
2599 thr, cv, SvPEEK((SV*)cv)));
2602 if (CvDEPTH(cv) == 0)
2603 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2606 /* (2) => grab ownership of cv. (3) => make clone */
2610 MUTEX_UNLOCK(CvMUTEXP(cv));
2611 DEBUG_S(PerlIO_printf(Perl_debug_log,
2612 "entersub: %p grabbing %p:%s in stash %s\n",
2613 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2614 HvNAME(CvSTASH(cv)) : "(none)"));
2617 /* Make a new clone. */
2619 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2620 MUTEX_UNLOCK(CvMUTEXP(cv));
2621 DEBUG_S((PerlIO_printf(Perl_debug_log,
2622 "entersub: %p cloning %p:%s\n",
2623 thr, cv, SvPEEK((SV*)cv))));
2625 * We're creating a new clone so there's no race
2626 * between the original MUTEX_UNLOCK and the
2627 * SvREFCNT_inc since no one will be trying to undef
2628 * it out from underneath us. At least, I don't think
2631 clonecv = cv_clone(cv);
2632 SvREFCNT_dec(cv); /* finished with this */
2633 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2634 CvOWNER(clonecv) = thr;
2638 DEBUG_S(if (CvDEPTH(cv) != 0)
2639 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2641 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2644 #endif /* USE_THREADS */
2647 #ifdef PERL_XSUB_OLDSTYLE
2648 if (CvOLDSTYLE(cv)) {
2649 I32 (*fp3)(int,int,int);
2651 register I32 items = SP - MARK;
2652 /* We dont worry to copy from @_. */
2657 PL_stack_sp = mark + 1;
2658 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2659 items = (*fp3)(CvXSUBANY(cv).any_i32,
2660 MARK - PL_stack_base + 1,
2662 PL_stack_sp = PL_stack_base + items;
2665 #endif /* PERL_XSUB_OLDSTYLE */
2667 I32 markix = TOPMARK;
2672 /* Need to copy @_ to stack. Alternative may be to
2673 * switch stack to @_, and copy return values
2674 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2678 av = (AV*)PL_curpad[0];
2680 av = GvAV(PL_defgv);
2681 #endif /* USE_THREADS */
2682 items = AvFILLp(av) + 1; /* @_ is not tieable */
2685 /* Mark is at the end of the stack. */
2687 Copy(AvARRAY(av), SP + 1, items, SV*);
2692 /* We assume first XSUB in &DB::sub is the called one. */
2694 SAVEVPTR(PL_curcop);
2695 PL_curcop = PL_curcopdb;
2698 /* Do we need to open block here? XXXX */
2699 (void)(*CvXSUB(cv))(aTHXo_ cv);
2701 /* Enforce some sanity in scalar context. */
2702 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2703 if (markix > PL_stack_sp - PL_stack_base)
2704 *(PL_stack_base + markix) = &PL_sv_undef;
2706 *(PL_stack_base + markix) = *PL_stack_sp;
2707 PL_stack_sp = PL_stack_base + markix;
2715 register I32 items = SP - MARK;
2716 AV* padlist = CvPADLIST(cv);
2717 SV** svp = AvARRAY(padlist);
2718 push_return(PL_op->op_next);
2719 PUSHBLOCK(cx, CXt_SUB, MARK);
2722 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2723 * that eval'' ops within this sub know the correct lexical space.
2724 * Owing the speed considerations, we choose to search for the cv
2725 * in doeval() instead.
2727 if (CvDEPTH(cv) < 2)
2728 (void)SvREFCNT_inc(cv);
2729 else { /* save temporaries on recursion? */
2730 PERL_STACK_OVERFLOW_CHECK();
2731 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2733 AV *newpad = newAV();
2734 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2735 I32 ix = AvFILLp((AV*)svp[1]);
2736 I32 names_fill = AvFILLp((AV*)svp[0]);
2737 svp = AvARRAY(svp[0]);
2738 for ( ;ix > 0; ix--) {
2739 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2740 char *name = SvPVX(svp[ix]);
2741 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2742 || *name == '&') /* anonymous code? */
2744 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2746 else { /* our own lexical */
2748 av_store(newpad, ix, sv = (SV*)newAV());
2749 else if (*name == '%')
2750 av_store(newpad, ix, sv = (SV*)newHV());
2752 av_store(newpad, ix, sv = NEWSV(0,0));
2756 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2757 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2760 av_store(newpad, ix, sv = NEWSV(0,0));
2764 av = newAV(); /* will be @_ */
2766 av_store(newpad, 0, (SV*)av);
2767 AvFLAGS(av) = AVf_REIFY;
2768 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2769 AvFILLp(padlist) = CvDEPTH(cv);
2770 svp = AvARRAY(padlist);
2775 AV* av = (AV*)PL_curpad[0];
2777 items = AvFILLp(av) + 1;
2779 /* Mark is at the end of the stack. */
2781 Copy(AvARRAY(av), SP + 1, items, SV*);
2786 #endif /* USE_THREADS */
2787 SAVEVPTR(PL_curpad);
2788 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2791 #endif /* USE_THREADS */
2797 DEBUG_S(PerlIO_printf(Perl_debug_log,
2798 "%p entersub preparing @_\n", thr));
2800 av = (AV*)PL_curpad[0];
2802 /* @_ is normally not REAL--this should only ever
2803 * happen when DB::sub() calls things that modify @_ */
2809 cx->blk_sub.savearray = GvAV(PL_defgv);
2810 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2811 #endif /* USE_THREADS */
2812 cx->blk_sub.oldcurpad = PL_curpad;
2813 cx->blk_sub.argarray = av;
2816 if (items > AvMAX(av) + 1) {
2818 if (AvARRAY(av) != ary) {
2819 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2820 SvPVX(av) = (char*)ary;
2822 if (items > AvMAX(av) + 1) {
2823 AvMAX(av) = items - 1;
2824 Renew(ary,items,SV*);
2826 SvPVX(av) = (char*)ary;
2829 Copy(MARK,AvARRAY(av),items,SV*);
2830 AvFILLp(av) = items - 1;
2838 /* warning must come *after* we fully set up the context
2839 * stuff so that __WARN__ handlers can safely dounwind()
2842 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2843 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2844 sub_crush_depth(cv);
2846 DEBUG_S(PerlIO_printf(Perl_debug_log,
2847 "%p entersub returning %p\n", thr, CvSTART(cv)));
2849 RETURNOP(CvSTART(cv));
2854 Perl_sub_crush_depth(pTHX_ CV *cv)
2857 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2859 SV* tmpstr = sv_newmortal();
2860 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2861 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2871 IV elem = SvIV(elemsv);
2873 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2874 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2877 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2878 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2880 elem -= PL_curcop->cop_arybase;
2881 if (SvTYPE(av) != SVt_PVAV)
2883 svp = av_fetch(av, elem, lval && !defer);
2885 if (!svp || *svp == &PL_sv_undef) {
2888 DIE(aTHX_ PL_no_aelem, elem);
2889 lv = sv_newmortal();
2890 sv_upgrade(lv, SVt_PVLV);
2892 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2893 LvTARG(lv) = SvREFCNT_inc(av);
2894 LvTARGOFF(lv) = elem;
2899 if (PL_op->op_private & OPpLVAL_INTRO)
2900 save_aelem(av, elem, svp);
2901 else if (PL_op->op_private & OPpDEREF)
2902 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2904 sv = (svp ? *svp : &PL_sv_undef);
2905 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2906 sv = sv_mortalcopy(sv);
2912 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2918 Perl_croak(aTHX_ PL_no_modify);
2919 if (SvTYPE(sv) < SVt_RV)
2920 sv_upgrade(sv, SVt_RV);
2921 else if (SvTYPE(sv) >= SVt_PV) {
2922 (void)SvOOK_off(sv);
2923 Safefree(SvPVX(sv));
2924 SvLEN(sv) = SvCUR(sv) = 0;
2928 SvRV(sv) = NEWSV(355,0);
2931 SvRV(sv) = (SV*)newAV();
2934 SvRV(sv) = (SV*)newHV();
2949 if (SvTYPE(rsv) == SVt_PVCV) {
2955 SETs(method_common(sv, Null(U32*)));
2962 SV* sv = cSVOP->op_sv;
2963 U32 hash = SvUVX(sv);
2965 XPUSHs(method_common(sv, &hash));
2970 S_method_common(pTHX_ SV* meth, U32* hashp)
2981 name = SvPV(meth, namelen);
2982 sv = *(PL_stack_base + TOPMARK + 1);
2985 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2996 !(packname = SvPV(sv, packlen)) ||
2997 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2998 !(ob=(SV*)GvIO(iogv)))
3001 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3002 ? !isIDFIRST_utf8((U8*)packname)
3003 : !isIDFIRST(*packname)
3006 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3007 SvOK(sv) ? "without a package or object reference"
3008 : "on an undefined value");
3010 stash = gv_stashpvn(packname, packlen, TRUE);
3013 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3016 if (!ob || !(SvOBJECT(ob)
3017 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3020 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3024 stash = SvSTASH(ob);
3027 /* shortcut for simple names */
3029 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3031 gv = (GV*)HeVAL(he);
3032 if (isGV(gv) && GvCV(gv) &&
3033 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3034 return (SV*)GvCV(gv);
3038 gv = gv_fetchmethod(stash, name);
3045 for (p = name; *p; p++) {
3047 sep = p, leaf = p + 1;
3048 else if (*p == ':' && *(p + 1) == ':')
3049 sep = p, leaf = p + 2;
3051 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3052 packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
3053 packlen = strlen(packname);
3057 packlen = sep - name;
3059 gv = gv_fetchpv(packname, 0, SVt_PVHV);
3060 if (gv && isGV(gv)) {
3062 "Can't locate object method \"%s\" via package \"%s\"",
3067 "Can't locate object method \"%s\" via package \"%s\""
3068 " (perhaps you forgot to load \"%s\"?)",
3069 leaf, packname, packname);
3072 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3077 unset_cvowner(pTHXo_ void *cvarg)
3079 register CV* cv = (CV *) cvarg;
3081 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3082 thr, cv, SvPEEK((SV*)cv))));
3083 MUTEX_LOCK(CvMUTEXP(cv));
3084 DEBUG_S(if (CvDEPTH(cv) != 0)
3085 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3087 assert(thr == CvOWNER(cv));
3089 MUTEX_UNLOCK(CvMUTEXP(cv));
3092 #endif /* USE_THREADS */