#ifdef I_UNISTD
#include <unistd.h>
#endif
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+
+#define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off))
/* Hot code. */
dTHR;
#endif /* DEBUGGING */
- DEBUG_L((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
+ DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
thr, cv, SvPEEK((SV*)cv))));
MUTEX_LOCK(CvMUTEXP(cv));
- DEBUG_L(if (CvDEPTH(cv) != 0)
+ DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
CvDEPTH(cv)););
assert(thr == CvOWNER(cv));
PP(pp_readline)
{
+ tryAMAGICunTARGET(iter, 0);
PL_last_in_gv = (GV*)(*PL_stack_sp--);
+ if (PL_op->op_flags & OPf_SPECIAL) { /* Are called as <$var> */
+ if (SvROK(PL_last_in_gv)) {
+ if (SvTYPE(SvRV(PL_last_in_gv)) != SVt_PVGV)
+ goto hard_way;
+ PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
+ } else if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
+ hard_way: {
+ dSP;
+ XPUSHs((SV*)PL_last_in_gv);
+ PUTBACK;
+ pp_rv2gv(ARGS);
+ PL_last_in_gv = (GV*)(*PL_stack_sp--);
+ }
+ }
+ }
return do_readline();
}
{
djSP;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- croak(no_modify);
+ croak(PL_no_modify);
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MAX)
{
Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
XPUSHs(sv);
#else
- XPUSHs((SV*)op);
+ XPUSHs((SV*)PL_op);
#endif
RETURN;
}
gv = (GV*)*++MARK;
else
gv = PL_defoutgv;
- if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+ if (mg = SvTIED_mg((SV*)gv, 'q')) {
if (MARK == ORIGMARK) {
/* If using default handle then we need to make space to
* pass object as 1st arg, so move other args up ...
++SP;
}
PUSHMARK(MARK - 1);
- *MARK = mg->mg_obj;
+ *MARK = SvTIED_obj((SV*)gv, mg);
PUTBACK;
ENTER;
perl_call_method("PRINT", G_SCALAR);
RETURN;
}
if (!(io = GvIO(gv))) {
- if (PL_dowarn) {
+ if (ckWARN(WARN_UNOPENED)) {
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
- warn("Filehandle %s never opened", SvPV(sv,PL_na));
+ warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,PL_na));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
- if (PL_dowarn) {
+ if (ckWARN2(WARN_CLOSED, WARN_IO)) {
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
- warn("Filehandle %s opened only for input", SvPV(sv,PL_na));
- else
- warn("print on closed filehandle %s", SvPV(sv,PL_na));
+ warner(WARN_IO, "Filehandle %s opened only for input",
+ SvPV(sv,PL_na));
+ else if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "print on closed filehandle %s",
+ SvPV(sv,PL_na));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
PP(pp_rv2av)
{
- djSP; dPOPss;
+ djSP; dTOPss;
AV *av;
if (SvROK(sv)) {
wasref:
+ tryAMAGICunDEREF(to_av);
+
av = (AV*)SvRV(sv);
if (SvTYPE(av) != SVt_PVAV)
DIE("Not an ARRAY reference");
if (PL_op->op_flags & OPf_REF) {
- PUSHs((SV*)av);
+ SETs((SV*)av);
RETURN;
}
}
if (SvTYPE(sv) == SVt_PVAV) {
av = (AV*)sv;
if (PL_op->op_flags & OPf_REF) {
- PUSHs((SV*)av);
+ SETs((SV*)av);
RETURN;
}
}
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_usym, "an ARRAY");
- if (PL_dowarn)
- warn(warn_uninit);
- if (GIMME == G_ARRAY)
+ DIE(PL_no_usym, "an ARRAY");
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ if (GIMME == G_ARRAY) {
+ POPs;
RETURN;
- RETPUSHUNDEF;
+ }
+ RETSETUNDEF;
}
sym = SvPV(sv,PL_na);
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "an ARRAY");
+ DIE(PL_no_symref, sym, "an ARRAY");
gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
} else {
gv = (GV*)sv;
if (PL_op->op_private & OPpLVAL_INTRO)
av = save_ary(gv);
if (PL_op->op_flags & OPf_REF) {
- PUSHs((SV*)av);
+ SETs((SV*)av);
RETURN;
}
}
if (GIMME == G_ARRAY) {
I32 maxarg = AvFILL(av) + 1;
+ POPs; /* XXXX May be optimized away? */
EXTEND(SP, maxarg);
if (SvRMAGICAL(av)) {
U32 i;
else {
dTARGET;
I32 maxarg = AvFILL(av) + 1;
- PUSHi(maxarg);
+ SETi(maxarg);
}
RETURN;
}
if (SvROK(sv)) {
wasref:
+ tryAMAGICunDEREF(to_hv);
+
hv = (HV*)SvRV(sv);
if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
DIE("Not a HASH reference");
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_usym, "a HASH");
- if (PL_dowarn)
- warn(warn_uninit);
+ DIE(PL_no_usym, "a HASH");
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
if (GIMME == G_ARRAY) {
SP--;
RETURN;
}
sym = SvPV(sv,PL_na);
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "a HASH");
+ DIE(PL_no_symref, sym, "a HASH");
gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
} else {
gv = (GV*)sv;
* clobber a value on the right that's used later in the list.
*/
if (PL_op->op_private & OPpASSIGN_COMMON) {
+ EXTEND_MORTAL(lastrelem - firstrelem + 1);
for (relem = firstrelem; relem <= lastrelem; relem++) {
/*SUPPRESS 560*/
if (sv = *relem) {
if (relem == lastrelem) {
if (*relem) {
HE *didstore;
- if (PL_dowarn) {
+ if (ckWARN(WARN_UNSAFE)) {
if (relem == firstrelem &&
SvROK(*relem) &&
( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
- warn("Reference found where even-sized list expected");
+ warner(WARN_UNSAFE, "Reference found where even-sized list expected");
else
- warn("Odd number of elements in hash assignment");
+ warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
}
tmpstr = NEWSV(29,0);
didstore = hv_store_ent(hash,*relem,tmpstr,0);
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv) && PL_curcop != &PL_compiling) {
if (!SvIMMORTAL(sv))
- DIE(no_modify);
+ DIE(PL_no_modify);
if (relem <= lastrelem)
relem++;
break;
if (PL_delaymagic & ~DM_DELAY) {
if (PL_delaymagic & DM_UID) {
#ifdef HAS_SETRESUID
- (void)setresuid(uid,euid,(Uid_t)-1);
+ (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
#else
# ifdef HAS_SETREUID
(void)setreuid(PL_uid,PL_euid);
# else
# ifdef HAS_SETRUID
- if ((delaymagic & DM_UID) == DM_RUID) {
- (void)setruid(uid);
- delaymagic &= ~DM_RUID;
+ if ((PL_delaymagic & DM_UID) == DM_RUID) {
+ (void)setruid(PL_uid);
+ PL_delaymagic &= ~DM_RUID;
}
# endif /* HAS_SETRUID */
# ifdef HAS_SETEUID
- if ((delaymagic & DM_UID) == DM_EUID) {
- (void)seteuid(uid);
- delaymagic &= ~DM_EUID;
+ if ((PL_delaymagic & DM_UID) == DM_EUID) {
+ (void)seteuid(PL_uid);
+ PL_delaymagic &= ~DM_EUID;
}
# endif /* HAS_SETEUID */
- if (delaymagic & DM_UID) {
- if (uid != euid)
+ if (PL_delaymagic & DM_UID) {
+ if (PL_uid != PL_euid)
DIE("No setreuid available");
- (void)PerlProc_setuid(uid);
+ (void)PerlProc_setuid(PL_uid);
}
# endif /* HAS_SETREUID */
#endif /* HAS_SETRESUID */
}
if (PL_delaymagic & DM_GID) {
#ifdef HAS_SETRESGID
- (void)setresgid(gid,egid,(Gid_t)-1);
+ (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
#else
# ifdef HAS_SETREGID
(void)setregid(PL_gid,PL_egid);
# else
# ifdef HAS_SETRGID
- if ((delaymagic & DM_GID) == DM_RGID) {
- (void)setrgid(gid);
- delaymagic &= ~DM_RGID;
+ if ((PL_delaymagic & DM_GID) == DM_RGID) {
+ (void)setrgid(PL_gid);
+ PL_delaymagic &= ~DM_RGID;
}
# endif /* HAS_SETRGID */
# ifdef HAS_SETEGID
- if ((delaymagic & DM_GID) == DM_EGID) {
- (void)setegid(gid);
- delaymagic &= ~DM_EGID;
+ if ((PL_delaymagic & DM_GID) == DM_EGID) {
+ (void)setegid(PL_gid);
+ PL_delaymagic &= ~DM_EGID;
}
# endif /* HAS_SETEGID */
- if (delaymagic & DM_GID) {
- if (gid != egid)
+ if (PL_delaymagic & DM_GID) {
+ if (PL_gid != PL_egid)
DIE("No setregid available");
- (void)PerlProc_setgid(gid);
+ (void)PerlProc_setgid(PL_gid);
}
# endif /* HAS_SETREGID */
#endif /* HAS_SETRESGID */
}
}
}
- if (!rx->nparens && !global)
- gimme = G_SCALAR; /* accidental array context? */
- safebase = (((gimme == G_ARRAY) || global || !rx->nparens)
- && !PL_sawampersand);
- safebase = safebase ? 0 : REXEC_COPY_STR ;
+ safebase = ((gimme != G_ARRAY && !global && rx->nparens)
+ || SvTEMP(TARG) || PL_sawampersand)
+ ? REXEC_COPY_STR : 0;
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
SAVEINT(PL_multiline);
PL_multiline = pm->op_pmflags & PMf_MULTILINE;
if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */
if ( screamer ) {
I32 p = -1;
+ char *b;
if (PL_screamfirst[BmRARE(rx->check_substr)] < 0)
goto nope;
- else if (!(s = screaminstr(TARG, rx->check_substr,
- rx->check_offset_min, 0, &p, 0)))
+
+ b = (char*)HOP((U8*)s, rx->check_offset_min);
+ if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0)))
goto nope;
- else if ((rx->reganch & ROPT_CHECK_ALL)
+
+ if ((rx->reganch & ROPT_CHECK_ALL)
&& !PL_sawampersand && !SvTAIL(rx->check_substr))
goto yup;
}
- else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min,
+ else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min),
(unsigned char*)strend,
rx->check_substr, 0)))
goto nope;
goto yup;
if (s && rx->check_offset_max < s - t) {
++BmUSEFUL(rx->check_substr);
- s -= rx->check_offset_max;
+ s = (char*)HOP((U8*)s, -rx->check_offset_max);
}
else
s = t;
beginning of match, and the match is anchored at s. */
else if (!PL_multiline) { /* Anchored near beginning of string. */
I32 slen;
- if (*SvPVX(rx->check_substr) != s[rx->check_offset_min]
+ char *b = (char*)HOP((U8*)s, rx->check_offset_min);
+ if (*SvPVX(rx->check_substr) != *b
|| ((slen = SvCUR(rx->check_substr)) > 1
- && memNE(SvPVX(rx->check_substr),
- s + rx->check_offset_min, slen)))
+ && memNE(SvPVX(rx->check_substr), b, slen)))
goto nope;
}
- if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0
+ if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0
&& rx->check_substr == rx->float_substr) {
SvREFCNT_dec(rx->check_substr);
rx->check_substr = Nullsv; /* opt is being useless */
PUTBACK; /* EVAL blocks may use stack */
goto play_it_again;
}
+ else if (!iters)
+ XPUSHs(&PL_sv_yes);
LEAVE_SCOPE(oldsave);
RETURN;
}
I32 gimme = GIMME_V;
MAGIC *mg;
- if (SvRMAGICAL(PL_last_in_gv) && (mg = mg_find((SV*)PL_last_in_gv, 'q'))) {
+ if (mg = SvTIED_mg((SV*)PL_last_in_gv, 'q')) {
PUSHMARK(SP);
- XPUSHs(mg->mg_obj);
+ XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
PUTBACK;
ENTER;
perl_call_method("READLINE", gimme);
IoFLAGS(io) &= ~IOf_START;
IoLINES(io) = 0;
if (av_len(GvAVn(PL_last_in_gv)) < 0) {
- do_open(PL_last_in_gv,"-",1,FALSE,0,0,Nullfp);
+ do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
SvSETMAGIC(GvSV(PL_last_in_gv));
fp = IoIFP(io);
#endif /* !CSH */
#endif /* !DOSISH */
(void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
- FALSE, 0, 0, Nullfp);
+ FALSE, O_RDONLY, 0, Nullfp);
fp = IoIFP(io);
#endif /* !VMS */
LEAVE;
SP--;
}
if (!fp) {
- if (PL_dowarn && io && !(IoFLAGS(io) & IOf_START))
- warn("Read on closed filehandle <%s>", GvENAME(PL_last_in_gv));
+ if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START))
+ warner(WARN_CLOSED,
+ "Read on closed filehandle <%s>", GvENAME(PL_last_in_gv));
if (gimme == G_SCALAR) {
(void)SvOK_off(TARG);
PUSHTARG;
IoFLAGS(io) |= IOf_START;
}
else if (type == OP_GLOB) {
- if (do_close(PL_last_in_gv, FALSE) & ~0xFF)
- warn("internal error: glob failed");
+ if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) {
+ warner(WARN_CLOSED,
+ "glob failed (child exited with status %d%s)",
+ STATUS_CURRENT >> 8,
+ (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
+ }
}
if (gimme == G_SCALAR) {
(void)SvOK_off(TARG);
svp = he ? &HeVAL(he) : 0;
}
else if (SvTYPE(hv) == SVt_PVAV) {
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ DIE("Can't localize pseudo-hash element");
svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
}
else {
SV* lv;
SV* key2;
if (!defer)
- DIE(no_helem, SvPV(keysv, PL_na));
+ DIE(PL_no_helem, SvPV(keysv, PL_na));
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
EXTEND(SP, 1);
cx = &cxstack[cxstack_ix];
- if (cx->cx_type != CXt_LOOP)
+ if (CxTYPE(cx) != CXt_LOOP)
DIE("panic: pp_iter");
av = cx->blk_loop.iterary;
char *max = SvPV((SV*)av, maxlen);
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
#ifndef USE_THREADS /* don't risk potential race */
- if (SvREFCNT(*cx->blk_loop.itervar) == 1) {
+ if (SvREFCNT(*cx->blk_loop.itervar) == 1
+ && !SvMAGICAL(*cx->blk_loop.itervar))
+ {
/* safe to reuse old SV */
sv_setsv(*cx->blk_loop.itervar, cur);
}
RETPUSHNO;
#ifndef USE_THREADS /* don't risk potential race */
- if (SvREFCNT(*cx->blk_loop.itervar) == 1) {
+ if (SvREFCNT(*cx->blk_loop.itervar) == 1
+ && !SvMAGICAL(*cx->blk_loop.itervar))
+ {
/* safe to reuse old SV */
sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++);
}
if (SvREADONLY(TARG)
|| (SvTYPE(TARG) > SVt_PVLV
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
- croak(no_modify);
+ croak(PL_no_modify);
PUTBACK;
s = SvPV(TARG, len);
DIE("panic: do_subst");
strend = s + len;
- maxiters = (strend - s) + 10;
+ maxiters = 2*(strend - s) + 10; /* We can match twice at each
+ position, once with zero-length,
+ second time with non-zero. */
if (!rx->prelen && PL_curpm) {
pm = PL_curpm;
&& SvTYPE(rx->check_substr) == SVt_PVBM
&& SvVALID(rx->check_substr))
? TARG : Nullsv);
- safebase = (!rx->nparens && !PL_sawampersand) ? 0 : REXEC_COPY_STR;
+ safebase = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
+ ? REXEC_COPY_STR : 0;
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
SAVEINT(PL_multiline);
PL_multiline = pm->op_pmflags & PMf_MULTILINE;
if (!(rx->reganch & ROPT_NOSCAN)) { /* It floats. */
if (screamer) {
I32 p = -1;
+ char *b;
if (PL_screamfirst[BmRARE(rx->check_substr)] < 0)
goto nope;
- else if (!(s = screaminstr(TARG, rx->check_substr, rx->check_offset_min, 0, &p, 0)))
+
+ b = (char*)HOP((U8*)s, rx->check_offset_min);
+ if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0)))
goto nope;
}
- else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min,
+ else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min),
(unsigned char*)strend,
rx->check_substr, 0)))
goto nope;
if (s && rx->check_offset_max < s - m) {
++BmUSEFUL(rx->check_substr);
- s -= rx->check_offset_max;
+ s = (char*)HOP((U8*)s, -rx->check_offset_max);
}
else
s = m;
beginning of match, and the match is anchored at s. */
else if (!PL_multiline) { /* Anchored at beginning of string. */
I32 slen;
- if (*SvPVX(rx->check_substr) != s[rx->check_offset_min]
+ char *b = (char*)HOP((U8*)s, rx->check_offset_min);
+ if (*SvPVX(rx->check_substr) != *b
|| ((slen = SvCUR(rx->check_substr)) > 1
- && memNE(SvPVX(rx->check_substr),
- s + rx->check_offset_min, slen)))
+ && memNE(SvPVX(rx->check_substr), b, slen)))
goto nope;
}
- if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0
+ if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0
&& rx->check_substr == rx->float_substr) {
SvREFCNT_dec(rx->check_substr);
rx->check_substr = Nullsv; /* opt is being useless */
else
sym = SvPV(sv, PL_na);
if (!sym)
- DIE(no_usym, "a subroutine");
+ DIE(PL_no_usym, "a subroutine");
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "a subroutine");
+ DIE(PL_no_symref, sym, "a subroutine");
cv = perl_get_cv(sym, TRUE);
break;
}
+ {
+ SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
+ tryAMAGICunDEREF(to_cv);
+ }
cv = (CV*)SvRV(sv);
if (SvTYPE(cv) == SVt_PVCV)
break;
while (MgOWNER(mg))
COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
MgOWNER(mg) = thr;
- DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
thr, sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
- SvREFCNT_inc(sv); /* Keep alive until magic_mutexfree */
save_destructor(unlock_condpair, sv);
}
MUTEX_LOCK(CvMUTEXP(cv));
/* We already have a clone to use */
MUTEX_UNLOCK(CvMUTEXP(cv));
cv = *(CV**)svp;
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"entersub: %p already has clone %p:%s\n",
thr, cv, SvPEEK((SV*)cv)));
CvOWNER(cv) = thr;
CvOWNER(cv) = thr;
SvREFCNT_inc(cv);
MUTEX_UNLOCK(CvMUTEXP(cv));
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"entersub: %p grabbing %p:%s in stash %s\n",
thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
HvNAME(CvSTASH(cv)) : "(none)"));
CV *clonecv;
SvREFCNT_inc(cv); /* don't let it vanish from under us */
MUTEX_UNLOCK(CvMUTEXP(cv));
- DEBUG_L((PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S((PerlIO_printf(PerlIO_stderr(),
"entersub: %p cloning %p:%s\n",
thr, cv, SvPEEK((SV*)cv))));
/*
cv = clonecv;
SvREFCNT_inc(cv);
}
- DEBUG_L(if (CvDEPTH(cv) != 0)
+ DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
CvDEPTH(cv)););
SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
CvDEPTH(cv)++;
+ /* XXX This would be a natural place to set C<PL_compcv = cv> so
+ * that eval'' ops within this sub know the correct lexical space.
+ * Owing the speed considerations, we choose to search for the cv
+ * in doeval() instead.
+ */
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
- if (CvDEPTH(cv) == 100 && PL_dowarn
- && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
- sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILLp(padlist)) {
AV *av;
AV *newpad = newAV();
SV** ary;
#if 0
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"%p entersub preparing @_\n", thr));
#endif
av = (AV*)PL_curpad[0];
MARK++;
}
}
+ /* warning must come *after* we fully set up the context
+ * stuff so that __WARN__ handlers can safely dounwind()
+ * if they want to
+ */
+ if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
+ && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
+ sub_crush_depth(cv);
#if 0
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"%p entersub returning %p\n", thr, CvSTART(cv)));
#endif
RETURNOP(CvSTART(cv));
sub_crush_depth(CV *cv)
{
if (CvANON(cv))
- warn("Deep recursion on anonymous subroutine");
+ warner(WARN_RECURSION, "Deep recursion on anonymous subroutine");
else {
SV* tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), Nullch);
- warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr));
+ warner(WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
+ SvPVX(tmpstr));
}
}
if (!svp || *svp == &PL_sv_undef) {
SV* lv;
if (!defer)
- DIE(no_aelem, elem);
+ DIE(PL_no_aelem, elem);
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
mg_get(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
- croak(no_modify);
+ croak(PL_no_modify);
if (SvTYPE(sv) < SVt_RV)
sv_upgrade(sv, SVt_RV);
else if (SvTYPE(sv) >= SVt_PV) {
!(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
- if (!packname || !isIDFIRST(*packname))
+ if (!packname ||
+ ((*(U8*)packname >= 0xc0 && IN_UTF8)
+ ? !isIDFIRST_utf8((U8*)packname)
+ : !isIDFIRST(*packname)
+ ))
+ {
DIE("Can't call method \"%s\" %s", name,
SvOK(sv)? "without a package or object reference"
: "on an undefined value");
+ }
stash = gv_stashpvn(packname, packlen, TRUE);
goto fetch;
}
https://perl5.git.perl.org / perl5.git / blobdiff