}
void
-Perl_write_to_stderr(pTHX_ const char* message, int msglen)
+Perl_write_to_stderr(pTHX_ SV* msv)
{
dVAR;
IO *io;
PUSHMARK(SP);
EXTEND(SP,2);
PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
- mPUSHp(message, msglen);
+ PUSHs(msv);
PUTBACK;
call_method("PRINT", G_SCALAR);
dSAVED_ERRNO;
#endif
PerlIO * const serr = Perl_error_log;
+ STRLEN msglen;
+ const char* message = SvPVx_const(msv, msglen);
PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
(void)PerlIO_flush(serr);
/* Common code used by vcroak, vdie, vwarn and vwarner */
STATIC bool
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
+S_vdie_common(pTHX_ SV *message, bool warn)
{
dVAR;
HV *stash;
*hook = NULL;
}
if (warn || message) {
- msg = newSVpvn_flags(message, msglen, utf8);
+ msg = newSVsv(message);
SvREADONLY_on(msg);
SAVEFREESV(msg);
}
return FALSE;
}
-STATIC const char *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
- I32* utf8)
+STATIC SV *
+S_vdie_croak_common(pTHX_ const char* pat, va_list* args)
{
dVAR;
- const char *message;
+ SV *message;
if (pat) {
SV * const msv = vmess(pat, args);
if (PL_errors && SvCUR(PL_errors)) {
sv_catsv(PL_errors, msv);
- message = SvPV_const(PL_errors, *msglen);
+ message = sv_mortalcopy(PL_errors);
SvCUR_set(PL_errors, 0);
}
else
- message = SvPV_const(msv,*msglen);
- *utf8 = SvUTF8(msv);
+ message = msv;
}
else {
message = NULL;
}
if (PL_diehook) {
- S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
+ S_vdie_common(aTHX_ message, FALSE);
}
return message;
}
S_vdie(pTHX_ const char* pat, va_list *args)
{
dVAR;
- const char *message;
- const int was_in_eval = PL_in_eval;
- STRLEN msglen;
- I32 utf8 = 0;
+ SV *message;
- message = vdie_croak_common(pat, args, &msglen, &utf8);
+ message = vdie_croak_common(pat, args);
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
- JMPENV_JUMP(3);
- return PL_restartop;
+ die_where(message);
+ /* NOTREACHED */
+ return NULL;
}
#if defined(PERL_IMPLICIT_CONTEXT)
Perl_vcroak(pTHX_ const char* pat, va_list *args)
{
dVAR;
- const char *message;
- STRLEN msglen;
- I32 utf8 = 0;
+ SV *msv;
- message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+ msv = S_vdie_croak_common(aTHX_ pat, args);
- if (PL_in_eval) {
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- JMPENV_JUMP(3);
- }
- else if (!message)
- message = SvPVx_const(ERRSV, msglen);
-
- write_to_stderr(message, msglen);
- my_failure_exit();
+ die_where(msv);
}
#if defined(PERL_IMPLICIT_CONTEXT)
Perl_vwarn(pTHX_ const char* pat, va_list *args)
{
dVAR;
- STRLEN msglen;
SV * const msv = vmess(pat, args);
- const I32 utf8 = SvUTF8(msv);
- const char * const message = SvPV_const(msv, msglen);
PERL_ARGS_ASSERT_VWARN;
if (PL_warnhook) {
- if (vdie_common(message, msglen, utf8, TRUE))
+ if (vdie_common(msv, TRUE))
return;
}
- write_to_stderr(message, msglen);
+ write_to_stderr(msv);
}
#if defined(PERL_IMPLICIT_CONTEXT)
PERL_ARGS_ASSERT_VWARNER;
if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
SV * const msv = vmess(pat, args);
- STRLEN msglen;
- const char * const message = SvPV_const(msv, msglen);
- const I32 utf8 = SvUTF8(msv);
if (PL_diehook) {
- assert(message);
- S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
+ assert(msv);
+ S_vdie_common(aTHX_ msv, FALSE);
}
- if (PL_in_eval) {
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- JMPENV_JUMP(3);
- }
- write_to_stderr(message, msglen);
- my_failure_exit();
+ die_where(msv);
}
else {
Perl_vwarn(aTHX_ pat, args);
Perl_ckwarn(pTHX_ U32 w)
{
dVAR;
- return isLEXWARN_on
- ? (PL_curcop->cop_warnings != pWARN_NONE
- && (
- PL_curcop->cop_warnings == pWARN_ALL
- || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
- || (unpackWARN2(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
- || (unpackWARN3(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
- || (unpackWARN4(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
- )
- )
- : (PL_dowarn & G_WARN_ON);
+ /* If lexical warnings have not been set, use $^W. */
+ if (isLEXWARN_off)
+ return PL_dowarn & G_WARN_ON;
+
+ return ckwarn_common(w);
}
/* implements the ckWARN?_d macro */
Perl_ckwarn_d(pTHX_ U32 w)
{
dVAR;
- return
- isLEXWARN_off
- || PL_curcop->cop_warnings == pWARN_ALL
- || (
- PL_curcop->cop_warnings != pWARN_NONE
- && (
- isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
- || (unpackWARN2(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
- || (unpackWARN3(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
- || (unpackWARN4(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
- )
- )
- ;
+ /* If lexical warnings have not been set then default classes warn. */
+ if (isLEXWARN_off)
+ return TRUE;
+
+ return ckwarn_common(w);
+}
+
+static bool
+S_ckwarn_common(pTHX_ U32 w)
+{
+ if (PL_curcop->cop_warnings == pWARN_ALL)
+ return TRUE;
+
+ if (PL_curcop->cop_warnings == pWARN_NONE)
+ return FALSE;
+
+ /* Check the assumption that at least the first slot is non-zero. */
+ assert(unpackWARN1(w));
+
+ /* Check the assumption that it is valid to stop as soon as a zero slot is
+ seen. */
+ if (!unpackWARN2(w)) {
+ assert(!unpackWARN3(w));
+ assert(!unpackWARN4(w));
+ } else if (!unpackWARN3(w)) {
+ assert(!unpackWARN4(w));
+ }
+
+ /* Right, dealt with all the special cases, which are implemented as non-
+ pointers, so there is a pointer to a real warnings mask. */
+ do {
+ if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
+ return TRUE;
+ } while (w >>= WARNshift);
+
+ return FALSE;
}
/* Set buffer=NULL to get a new one. */
* help. Sum in another random number that will
* fill in the low bits. */
myseed +=
- (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
+ (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
#endif /* RANDBITS < (UVSIZE * 8) */
if (myseed == 0) { /* Superparanoia. */
myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
REGEXP *
Perl_get_re_arg(pTHX_ SV *sv) {
- SV *tmpsv;
if (sv) {
if (SvMAGICAL(sv))
mg_get(sv);
- if (SvROK(sv) &&
- (tmpsv = MUTABLE_SV(SvRV(sv))) && /* assign deliberate */
- SvTYPE(tmpsv) == SVt_REGEXP)
- {
- return (REGEXP*) tmpsv;
- }
+ if (SvROK(sv))
+ sv = MUTABLE_SV(SvRV(sv));
+ if (SvTYPE(sv) == SVt_REGEXP)
+ return (REGEXP*) sv;
}
return NULL;
https://perl5.git.perl.org / perl5.git / blobdiff