NORETURN_FUNCTION_END;
}
+#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
+# define ALWAYS_NEED_THX
+#endif
+
/* paranoid version of system's malloc() */
Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
#ifdef HAS_64K_LIMIT
if (size > 0xffff) {
#endif
return ptr;
}
- else if (PL_nomemok)
- return NULL;
else {
- return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ else {
+ return write_no_mem();
+ }
}
/*NOTREACHED*/
}
Malloc_t
Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
Malloc_t PerlMem_realloc();
if (ptr != NULL) {
return ptr;
}
- else if (PL_nomemok)
- return NULL;
else {
- return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ else {
+ return write_no_mem();
+ }
}
/*NOTREACHED*/
}
Free_t
Perl_safesysfree(Malloc_t where)
{
-#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
+#ifdef ALWAYS_NEED_THX
dTHX;
#else
dVAR;
Malloc_t
Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
MEM_SIZE total_size = 0;
#endif
return ptr;
}
- else if (PL_nomemok)
- return NULL;
- return write_no_mem();
+ else {
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ return write_no_mem();
+ }
}
/* These must be defined when not using Perl's malloc for binary
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
+Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
{
register I32 tolen;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_DELIMCPY;
/* This routine was donated by Corey Satten. */
char *
-Perl_instr(pTHX_ register const char *big, register const char *little)
+Perl_instr(register const char *big, register const char *little)
{
register I32 first;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_INSTR;
/* same as instr but allow embedded nulls */
char *
-Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
+Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
{
PERL_ARGS_ASSERT_NINSTR;
- PERL_UNUSED_CONTEXT;
if (little >= lend)
return (char*)big;
{
/* reverse of the above--find last substring */
char *
-Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
+Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
{
register const char *bigbeg;
register const I32 first = *little;
register const char * const littleend = lend;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_RNINSTR;
return NULL;
}
+/*
+=for apidoc foldEQ
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
+match themselves and their opposite case counterparts. Non-cased and non-ASCII
+range bytes match only themselves.
+
+=cut
+*/
+
+
I32
-Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, register I32 len)
{
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
- PERL_UNUSED_CONTEXT;
- PERL_ARGS_ASSERT_IBCMP;
+ PERL_ARGS_ASSERT_FOLDEQ;
while (len--) {
if (*a != *b && *a != PL_fold[*b])
- return 1;
+ return 0;
a++,b++;
}
- return 0;
+ return 1;
}
+/*
+=for apidoc foldEQ_locale
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively in the current locale; false otherwise.
+
+=cut
+*/
+
I32
-Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
{
dVAR;
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
- PERL_UNUSED_CONTEXT;
- PERL_ARGS_ASSERT_IBCMP_LOCALE;
+ PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
while (len--) {
if (*a != *b && *a != PL_fold_locale[*b])
- return 1;
+ return 0;
a++,b++;
}
- return 0;
+ return 1;
}
/* copy a string to a safe spot */
return SvPVX(sv);
}
+/*
+=for apidoc Am|SV *|mess|const char *pat|...
+
+Take a sprintf-style format pattern and argument list. These are used to
+generate a string message. If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
#if defined(PERL_IMPLICIT_CONTEXT)
SV *
Perl_mess_nocontext(const char *pat, ...)
return NULL;
}
+/*
+=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
+
+Expands a message, intended for the user, to include an indication of
+the current location in the code, if the message does not already appear
+to be complete.
+
+C<basemsg> is the initial message or object. If it is a reference, it
+will be used as-is and will be the result of this function. Otherwise it
+is used as a string, and if it already ends with a newline, it is taken
+to be complete, and the result of this function will be the same string.
+If the message does not end with a newline, then a segment such as C<at
+foo.pl line 37> will be appended, and possibly other clauses indicating
+the current state of execution. The resulting message will end with a
+dot and a newline.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of this
+function. If C<consume> is true, then the function is permitted (but not
+required) to modify and return C<basemsg> instead of allocating a new SV.
+
+=cut
+*/
+
SV *
-Perl_vmess(pTHX_ const char *pat, va_list *args)
+Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
{
dVAR;
- SV * const sv = mess_alloc();
+ SV *sv;
- PERL_ARGS_ASSERT_VMESS;
+ PERL_ARGS_ASSERT_MESS_SV;
+
+ if (SvROK(basemsg)) {
+ if (consume) {
+ sv = basemsg;
+ }
+ else {
+ sv = mess_alloc();
+ sv_setsv(sv, basemsg);
+ }
+ return sv;
+ }
+
+ if (SvPOK(basemsg) && consume) {
+ sv = basemsg;
+ }
+ else {
+ sv = mess_alloc();
+ sv_copypv(sv, basemsg);
+ }
- sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
/*
* Try and find the file and line for PL_op. This will usually be
return sv;
}
+/*
+=for apidoc Am|SV *|vmess|const char *pat|va_list *args
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
+SV *
+Perl_vmess(pTHX_ const char *pat, va_list *args)
+{
+ dVAR;
+ SV * const sv = mess_alloc();
+
+ PERL_ARGS_ASSERT_VMESS;
+
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+ return mess_sv(sv, 1);
+}
+
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);
else {
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
- const int e = errno;
+ 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);
#ifdef USE_SFIO
- errno = e;
+ RESTORE_ERRNO;
#endif
}
}
-/* Common code used by vcroak, vdie, vwarn and vwarner */
+/*
+=head1 Warning and Dieing
+*/
+
+/* Common code used in dieing and warning */
+
+STATIC SV *
+S_with_queued_errors(pTHX_ SV *ex)
+{
+ PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
+ if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
+ sv_catsv(PL_errors, ex);
+ ex = sv_mortalcopy(PL_errors);
+ SvCUR_set(PL_errors, 0);
+ }
+ return ex;
+}
STATIC bool
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
+S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
{
dVAR;
HV *stash;
/* sv_2cv might call Perl_croak() or Perl_warner() */
SV * const oldhook = *hook;
- assert(oldhook);
+ if (!oldhook)
+ return FALSE;
ENTER;
SAVESPTR(*hook);
LEAVE;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
- SV *msg;
+ SV *exarg;
ENTER;
save_re_context();
SAVESPTR(*hook);
*hook = NULL;
}
- if (warn || message) {
- msg = newSVpvn_flags(message, msglen, utf8);
- SvREADONLY_on(msg);
- SAVEFREESV(msg);
- }
- else {
- msg = ERRSV;
- }
+ exarg = newSVsv(ex);
+ SvREADONLY_on(exarg);
+ SAVEFREESV(exarg);
PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
PUSHMARK(SP);
- XPUSHs(msg);
+ XPUSHs(exarg);
PUTBACK;
call_sv(MUTABLE_SV(cv), G_DISCARD);
POPSTACK;
return FALSE;
}
-STATIC const char *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
- I32* utf8)
-{
- dVAR;
- const char *message;
+/*
+=for apidoc Am|OP *|die_sv|SV *baseex
- 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);
- SvCUR_set(PL_errors, 0);
- }
- else
- message = SvPV_const(msv,*msglen);
- *utf8 = SvUTF8(msv);
- }
- else {
- message = NULL;
- }
+Behaves the same as L</croak_sv>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
- if (PL_diehook) {
- S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
- }
- return message;
-}
+=cut
+*/
-static OP *
-S_vdie(pTHX_ const char* pat, va_list *args)
+OP *
+Perl_die_sv(pTHX_ SV *baseex)
{
- dVAR;
- const char *message;
- const int was_in_eval = PL_in_eval;
- STRLEN msglen;
- I32 utf8 = 0;
+ PERL_ARGS_ASSERT_DIE_SV;
+ croak_sv(baseex);
+ /* NOTREACHED */
+ return NULL;
+}
- message = vdie_croak_common(pat, args, &msglen, &utf8);
+/*
+=for apidoc Am|OP *|die|const char *pat|...
- 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;
-}
+Behaves the same as L</croak>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
+
+=cut
+*/
#if defined(PERL_IMPLICIT_CONTEXT)
OP *
Perl_die_nocontext(const char* pat, ...)
{
dTHX;
- OP *o;
va_list args;
- PERL_ARGS_ASSERT_DIE_NOCONTEXT;
va_start(args, pat);
- o = vdie(pat, &args);
+ vcroak(pat, &args);
+ /* NOTREACHED */
va_end(args);
- return o;
+ return NULL;
}
#endif /* PERL_IMPLICIT_CONTEXT */
OP *
Perl_die(pTHX_ const char* pat, ...)
{
- OP *o;
va_list args;
va_start(args, pat);
- o = vdie(pat, &args);
+ vcroak(pat, &args);
+ /* NOTREACHED */
va_end(args);
- return o;
+ return NULL;
}
+/*
+=for apidoc Am|void|croak_sv|SV *baseex
+
+This is an XS interface to Perl's C<die> function.
+
+C<baseex> is the error message or object. If it is a reference, it
+will be used as-is. Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
+
+The error message or object will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
+function never returns normally.
+
+To die with a simple string message, the L</croak> function may be
+more convenient.
+
+=cut
+*/
+
void
-Perl_vcroak(pTHX_ const char* pat, va_list *args)
+Perl_croak_sv(pTHX_ SV *baseex)
{
- dVAR;
- const char *message;
- STRLEN msglen;
- I32 utf8 = 0;
+ SV *ex = with_queued_errors(mess_sv(baseex, 0));
+ PERL_ARGS_ASSERT_CROAK_SV;
+ invoke_exception_hook(ex, FALSE);
+ die_unwind(ex);
+}
- message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+/*
+=for apidoc Am|void|vcroak|const char *pat|va_list *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);
+This is an XS interface to Perl's C<die> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments. If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
- write_to_stderr(message, msglen);
- my_failure_exit();
+void
+Perl_vcroak(pTHX_ const char* pat, va_list *args)
+{
+ SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
+ invoke_exception_hook(ex, FALSE);
+ die_unwind(ex);
}
+/*
+=for apidoc Am|void|croak|const char *pat|...
+
+This is an XS interface to Perl's C<die> function.
+
+Take a sprintf-style format pattern and argument list. These are used to
+generate a string message. If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments. If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
+
#if defined(PERL_IMPLICIT_CONTEXT)
void
Perl_croak_nocontext(const char *pat, ...)
}
#endif /* PERL_IMPLICIT_CONTEXT */
+void
+Perl_croak(pTHX_ const char *pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ vcroak(pat, &args);
+ /* NOTREACHED */
+ va_end(args);
+}
+
/*
-=head1 Warning and Dieing
+=for apidoc Am|void|warn_sv|SV *baseex
-=for apidoc croak
+This is an XS interface to Perl's C<warn> function.
-This is the XSUB-writer's interface to Perl's C<die> function.
-Normally call this function the same way you call the C C<printf>
-function. Calling C<croak> returns control directly to Perl,
-sidestepping the normal C order of execution. See C<warn>.
+C<baseex> is the error message or object. If it is a reference, it
+will be used as-is. Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
-If you want to throw an exception object, assign the object to
-C<$@> and then pass C<NULL> to croak():
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
- errsv = get_sv("@", TRUE);
- sv_setsv(errsv, exception_object);
- croak(NULL);
+To warn with a simple string message, the L</warn> function may be
+more convenient.
=cut
*/
void
-Perl_croak(pTHX_ const char *pat, ...)
+Perl_warn_sv(pTHX_ SV *baseex)
{
- va_list args;
- va_start(args, pat);
- vcroak(pat, &args);
- /* NOTREACHED */
- va_end(args);
+ SV *ex = mess_sv(baseex, 0);
+ PERL_ARGS_ASSERT_WARN_SV;
+ if (!invoke_exception_hook(ex, TRUE))
+ write_to_stderr(ex);
}
+/*
+=for apidoc Am|void|vwarn|const char *pat|va_list *args
+
+This is an XS interface to Perl's C<warn> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</vcroak>, C<pat> is not permitted to be null.
+
+=cut
+*/
+
void
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);
-
+ SV *ex = vmess(pat, args);
PERL_ARGS_ASSERT_VWARN;
+ if (!invoke_exception_hook(ex, TRUE))
+ write_to_stderr(ex);
+}
- if (PL_warnhook) {
- if (vdie_common(message, msglen, utf8, TRUE))
- return;
- }
+/*
+=for apidoc Am|void|warn|const char *pat|...
- write_to_stderr(message, msglen);
-}
+This is an XS interface to Perl's C<warn> function.
+
+Take a sprintf-style format pattern and argument list. These are used to
+generate a string message. If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</croak>, C<pat> is not permitted to be null.
+
+=cut
+*/
#if defined(PERL_IMPLICIT_CONTEXT)
void
}
#endif /* PERL_IMPLICIT_CONTEXT */
-/*
-=for apidoc warn
-
-This is the XSUB-writer's interface to Perl's C<warn> function. Call this
-function the same way you call the C C<printf> function. See C<croak>.
-
-=cut
-*/
-
void
Perl_warn(pTHX_ const char *pat, ...)
{
#endif /* PERL_IMPLICIT_CONTEXT */
void
+Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
+{
+ PERL_ARGS_ASSERT_CK_WARNER_D;
+
+ if (Perl_ckwarn_d(aTHX_ err)) {
+ va_list args;
+ va_start(args, pat);
+ vwarner(err, pat, &args);
+ va_end(args);
+ }
+}
+
+void
+Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
+{
+ PERL_ARGS_ASSERT_CK_WARNER;
+
+ if (Perl_ckwarn(aTHX_ err)) {
+ va_list args;
+ va_start(args, pat);
+ vwarner(err, pat, &args);
+ va_end(args);
+ }
+}
+
+void
Perl_warner(pTHX_ U32 err, const char* pat,...)
{
va_list args;
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);
- }
- if (PL_in_eval) {
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- JMPENV_JUMP(3);
- }
- write_to_stderr(message, msglen);
- my_failure_exit();
+ invoke_exception_hook(msv, FALSE);
+ die_unwind(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)))
- )
- )
- ||
- (
- isLEXWARN_off && 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. */
PerlIO *
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
dVAR;
int p[2];
register I32 This, that;
}
return NULL;
}
+ Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
sleep(5);
}
if (pid == 0) {
else
PerlLIO_close(p[that]); /* close child's end of pipe */
- LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,p[This],TRUE);
- UNLOCK_FDPID_MUTEX;
SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, pid);
PL_forkprocess = pid;
}
/* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
PerlLIO_close(pp[1]);
}
if (!doexec)
- Perl_croak(aTHX_ "Can't fork");
+ Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
return NULL;
}
+ Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
sleep(5);
}
if (pid == 0) {
else
PerlLIO_close(p[that]);
- LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,p[This],TRUE);
- UNLOCK_FDPID_MUTEX;
SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, pid);
PL_forkprocess = pid;
#ifndef PERL_MICRO
#ifdef HAS_SIGACTION
-#ifdef MACOS_TRADITIONAL
-/* We don't want restart behavior on MacOS */
-#undef SA_RESTART
-#endif
-
Sighandler_t
Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
{
#endif /* !PERL_MICRO */
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
Pid_t pid;
Pid_t pid2;
bool close_failed;
- int saved_errno = 0;
-#ifdef WIN32
- int saved_win32_errno;
-#endif
+ dSAVEDERRNO;
- LOCK_FDPID_MUTEX;
svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
- UNLOCK_FDPID_MUTEX;
pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
SvREFCNT_dec(*svp);
*svp = &PL_sv_undef;
return my_syspclose(ptr);
}
#endif
- if ((close_failed = (PerlIO_close(ptr) == EOF))) {
- saved_errno = errno;
-#ifdef WIN32
- saved_win32_errno = GetLastError();
-#endif
- }
+ close_failed = (PerlIO_close(ptr) == EOF);
+ SAVE_ERRNO;
#ifdef UTS
if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
rsignal_restore(SIGQUIT, &qstat);
#endif
if (close_failed) {
- SETERRNO(saved_errno, 0);
+ RESTORE_ERRNO;
return -1;
}
return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
#endif
#endif /* !DOSISH */
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
}
#endif
+#define PERL_REPEATCPY_LINEAR 4
void
-Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
{
- register I32 todo;
- register const char * const frombase = from;
- PERL_UNUSED_CONTEXT;
-
PERL_ARGS_ASSERT_REPEATCPY;
- if (len == 1) {
- register const char c = *from;
- while (count-- > 0)
- *to++ = c;
- return;
- }
- while (count-- > 0) {
- for (todo = len; todo > 0; todo--) {
- *to++ = *from++;
+ if (len == 1)
+ memset(to, *from, count);
+ else if (count) {
+ register char *p = to;
+ I32 items, linear, half;
+
+ linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
+ for (items = 0; items < linear; ++items) {
+ register const char *q = from;
+ I32 todo;
+ for (todo = len; todo > 0; todo--)
+ *p++ = *q++;
+ }
+
+ half = count / 2;
+ while (items <= half) {
+ I32 size = items * len;
+ memcpy(p, to, size);
+ p += size;
+ items *= 2;
}
- from = frombase;
+
+ if (count > items)
+ memcpy(p, to, (count - items) * len);
}
}
}
#endif
-#ifdef MACOS_TRADITIONAL
- if (dosearch && !strchr(scriptname, ':') &&
- (s = PerlEnv_getenv("Commands")))
-#else
if (dosearch && !strchr(scriptname, '/')
#ifdef DOSISH
&& !strchr(scriptname, '\\')
#endif
&& (s = PerlEnv_getenv("PATH")))
-#endif
{
bool seen_dot = 0;
bufend = s + strlen(s);
while (s < bufend) {
-#ifdef MACOS_TRADITIONAL
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
- ',',
- &len);
-#else
#if defined(atarist) || defined(DOSISH)
for (len = 0; *s
# ifdef atarist
':',
&len);
#endif /* ! (atarist || DOSISH) */
-#endif /* MACOS_TRADITIONAL */
if (s < bufend)
s++;
if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
continue; /* don't search dir with too-long name */
-#ifdef MACOS_TRADITIONAL
- if (len && tmpbuf[len - 1] != ':')
- tmpbuf[len++] = ':';
-#else
if (len
-# if defined(atarist) || defined(__MINT__) || defined(DOSISH)
+# if defined(atarist) || defined(DOSISH)
&& tmpbuf[len - 1] != '/'
&& tmpbuf[len - 1] != '\\'
# endif
tmpbuf[len++] = '/';
if (len == 2 && tmpbuf[0] == '.')
seen_dot = 1;
-#endif
(void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
#endif /* !VMS */
continue;
if (S_ISREG(PL_statbuf.st_mode)
&& cando(S_IRUSR,TRUE,&PL_statbuf)
-#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
+#if !defined(DOSISH)
&& cando(S_IXUSR,TRUE,&PL_statbuf)
#endif
)
}
}
-#ifdef EBCDIC
-/* in ASCII order, not that it matters */
-static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
+/* XXX Add documentation after final interface and behavior is decided */
+/* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
+ U8 source = *current;
-int
-Perl_ebcdic_control(pTHX_ int ch)
+ May want to add eg, WARN_REGEX
+*/
+
+char
+Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
{
- if (ch > 'a') {
- const char *ctlp;
+
+ U8 result;
- if (islower(ch))
- ch = toupper(ch);
+ if (! isASCII(source)) {
+ Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
+ }
- if ((ctlp = strchr(controllablechars, ch)) == 0) {
- Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
+ result = toCTRL(source);
+ if (! isCNTRL(result)) {
+ if (source == '{') {
+ Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\". If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
}
+ else if (output_warning) {
+ U8 clearer[3];
+ U8 i = 0;
+ if (! isALNUM(result)) {
+ clearer[i++] = '\\';
+ }
+ clearer[i++] = result;
+ clearer[i++] = '\0';
- if (ctlp == controllablechars)
- return('\177'); /* DEL */
- else
- return((unsigned char)(ctlp - controllablechars - 1));
- } else { /* Want uncontrol */
- if (ch == '\177' || ch == -1)
- return('?');
- else if (ch == '\157')
- return('\177');
- else if (ch == '\174')
- return('\000');
- else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
- return('\036');
- else if (ch == '\155')
- return('\037');
- else if (0 < ch && ch < (sizeof(controllablechars) - 1))
- return(controllablechars[ch+1]);
- else
- Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "\"\\c%c\" more clearly written simply as \"%s\"",
+ source,
+ clearer);
+ }
}
+
+ return result;
}
-#endif
/* To workaround core dumps from the uninitialised tm_zone we get the
* system to give us a reasonable struct to copy. This fix means that
for (;;) {
DIR *dir;
+ int namelen;
odev = cdev;
oino = cino;
while ((dp = PerlDir_read(dir)) != NULL) {
#ifdef DIRNAMLEN
- const int namelen = dp->d_namlen;
+ namelen = dp->d_namlen;
#else
- const int namelen = strlen(dp->d_name);
+ namelen = strlen(dp->d_name);
#endif
/* skip . and .. */
if (SV_CWD_ISDOT(dp)) {
}
#define VERSION_MAX 0x7FFFFFFF
+
+/*
+=for apidoc prescan_version
+
+=cut
+*/
+const char *
+Perl_prescan_version(pTHX_ const char *s, bool strict,
+ const char **errstr,
+ bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
+ bool qv = (sqv ? *sqv : FALSE);
+ int width = 3;
+ int saw_decimal = 0;
+ bool alpha = FALSE;
+ const char *d = s;
+
+ PERL_ARGS_ASSERT_PRESCAN_VERSION;
+
+ if (qv && isDIGIT(*d))
+ goto dotted_decimal_version;
+
+ if (*d == 'v') { /* explicit v-string */
+ d++;
+ if (isDIGIT(*d)) {
+ qv = TRUE;
+ }
+ else { /* degenerate v-string */
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+
+dotted_decimal_version:
+ if (strict && d[0] == '0' && isDIGIT(d[1])) {
+ /* no leading zeros allowed */
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+
+ while (isDIGIT(*d)) /* integer part */
+ d++;
+
+ if (*d == '.')
+ {
+ saw_decimal++;
+ d++; /* decimal point */
+ }
+ else
+ {
+ if (strict) {
+ /* require v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ else {
+ goto version_prescan_finish;
+ }
+ }
+
+ {
+ int i = 0;
+ int j = 0;
+ while (isDIGIT(*d)) { /* just keep reading */
+ i++;
+ while (isDIGIT(*d)) {
+ d++; j++;
+ /* maximum 3 digits between decimal */
+ if (strict && j > 3) {
+ BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
+ }
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ d++;
+ alpha = TRUE;
+ }
+ else if (*d == '.') {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ saw_decimal++;
+ d++;
+ }
+ else if (!isDIGIT(*d)) {
+ break;
+ }
+ j = 0;
+ }
+
+ if (strict && i < 2) {
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ }
+ } /* end if dotted-decimal */
+ else
+ { /* decimal versions */
+ /* special strict case for leading '.' or '0' */
+ if (strict) {
+ if (*d == '.') {
+ BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
+ }
+ if (*d == '0' && isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+ }
+
+ /* consume all of the integer part */
+ while (isDIGIT(*d))
+ d++;
+
+ /* look for a fractional part */
+ if (*d == '.') {
+ /* we found it, so consume it */
+ saw_decimal++;
+ d++;
+ }
+ else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
+ if ( d == s ) {
+ /* found nothing */
+ BADVERSION(s,errstr,"Invalid version format (version required)");
+ }
+ /* found just an integer */
+ goto version_prescan_finish;
+ }
+ else if ( d == s ) {
+ /* didn't find either integer or period */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+ else if (*d == '_') {
+ /* underscore can't come after integer part */
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ else if (isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
+ }
+ else {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ }
+ else {
+ /* anything else after integer part is just invalid data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ /* scan the fractional part after the decimal point*/
+
+ if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
+ /* strict or lax-but-not-the-end */
+ BADVERSION(s,errstr,"Invalid version format (fractional part required)");
+ }
+
+ while (isDIGIT(*d)) {
+ d++;
+ if (*d == '.' && isDIGIT(d[-1])) {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+ }
+ d = (char *)s; /* start all over again */
+ qv = TRUE;
+ goto dotted_decimal_version;
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ if ( ! isDIGIT(d[1]) ) {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ d++;
+ alpha = TRUE;
+ }
+ }
+ }
+
+version_prescan_finish:
+ while (isSPACE(*d))
+ d++;
+
+ if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
+ /* trailing non-numeric data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ if (sqv)
+ *sqv = qv;
+ if (swidth)
+ *swidth = width;
+ if (ssaw_decimal)
+ *ssaw_decimal = saw_decimal;
+ if (salpha)
+ *salpha = alpha;
+ return d;
+}
+
/*
=for apidoc scan_version
const char *start;
const char *pos;
const char *last;
- int saw_period = 0;
- int alpha = 0;
+ const char *errstr = NULL;
+ int saw_decimal = 0;
int width = 3;
+ bool alpha = FALSE;
bool vinf = FALSE;
AV * const av = newAV();
SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+#endif
+
while (isSPACE(*s)) /* leading whitespace is OK */
s++;
- start = last = s;
-
- if (*s == 'v') {
- s++; /* get past 'v' */
- qv = 1; /* force quoted version processing */
- }
-
- pos = s;
-
- /* pre-scan the input string to check for decimals/underbars */
- while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
- {
- if ( *pos == '.' )
- {
- if ( alpha )
- Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
- saw_period++ ;
- last = pos;
+ last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
+ if (errstr) {
+ /* "undef" is a special case and not an error */
+ if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+ Perl_croak(aTHX_ "%s", errstr);
}
- else if ( *pos == '_' )
- {
- if ( alpha )
- Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
- alpha = 1;
- width = pos - last - 1; /* natural width of sub-version */
- }
- pos++;
}
- if ( alpha && !saw_period )
- Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
-
- if ( alpha && saw_period && width == 0 )
- Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
-
- if ( saw_period > 1 )
- qv = 1; /* force quoted version processing */
-
- last = pos;
+ start = s;
+ if (*s == 'v')
+ s++;
pos = s;
if ( qv )
* point of a version originally created with a bare
* floating point number, i.e. not quoted in any way
*/
- if ( !qv && s > start && saw_period == 1 ) {
+ if ( !qv && s > start && saw_decimal == 1 ) {
mult *= 100;
while ( s < end ) {
orev = rev;
mult /= 10;
if ( (PERL_ABS(orev) > PERL_ABS(rev))
|| (PERL_ABS(rev) > VERSION_MAX )) {
- if(ckWARN(WARN_OVERFLOW))
- Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "Integer overflow in version %d",VERSION_MAX);
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version %d",VERSION_MAX);
s = end - 1;
rev = VERSION_MAX;
vinf = 1;
mult *= 10;
if ( (PERL_ABS(orev) > PERL_ABS(rev))
|| (PERL_ABS(rev) > VERSION_MAX )) {
- if(ckWARN(WARN_OVERFLOW))
- Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "Integer overflow in version");
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version");
end = s - 1;
rev = VERSION_MAX;
vinf = 1;
s = ++pos;
else if ( *pos == '_' && isDIGIT(pos[1]) )
s = ++pos;
+ else if ( *pos == ',' && isDIGIT(pos[1]) )
+ s = ++pos;
else if ( isDIGIT(*pos) )
s = pos;
else {
}
else if ( s > start ) {
SV * orig = newSVpvn(start,s-start);
- if ( qv && saw_period == 1 && *start != 'v' ) {
+ if ( qv && saw_decimal == 1 && *start != 'v' ) {
/* need to insert a v to be consistent */
sv_insert(orig, 0, 0, "v", 1);
}
/* This will get reblessed later if a derived class*/
SV * const hv = newSVrv(rv, "version");
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+#endif
if ( SvROK(ver) )
ver = SvRV(ver);
char * const version = savepvn( (const char*)mg->mg_ptr, len);
sv_setpvn(rv,version,len);
/* this is for consistency with the pure Perl class */
- if ( *version != 'v' )
+ if ( isDIGIT(*version) )
sv_insert(rv, 0, 0, "v", 1);
Safefree(version);
}
#ifdef SvVOK
else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
- qv = 1;
+ qv = TRUE;
}
#endif
else /* must be a string or something like a string */
#ifndef SvVOK
# if PERL_VERSION > 5
/* This will only be executed for 5.6.0 - 5.8.0 inclusive */
- if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
+ if ( len >= 3 && !instr(version,".") && !instr(version,"_")
+ && !(*version == 'u' && strEQ(version, "undef"))
+ && (*version < '0' || *version > '9') ) {
/* may be a v-string */
SV * const nsv = sv_newmortal();
const char *nver;
const char *pos;
- int saw_period = 0;
+ int saw_decimal = 0;
sv_setpvf(nsv,"v%vd",ver);
pos = nver = savepv(SvPV_nolen(nsv));
pos++; /* skip the leading 'v' */
while ( *pos == '.' || isDIGIT(*pos) ) {
if ( *pos == '.' )
- saw_period++ ;
+ saw_decimal++ ;
pos++;
}
/* is definitely a v-string */
- if ( saw_period == 2 ) {
+ if ( saw_decimal >= 2 ) {
Safefree(version);
version = nver;
}
s = scan_version(version, ver, qv);
if ( *s != '\0' )
- if(ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Version string '%s' contains invalid data; "
- "ignoring: '%s'", version, s);
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Version string '%s' contains invalid data; "
+ "ignoring: '%s'", version, s);
Safefree(version);
return ver;
}
I32 i, len, digit;
int width;
bool alpha = FALSE;
- SV * const sv = newSV(0);
+ SV *sv;
AV *av;
PERL_ARGS_ASSERT_VNUMIFY;
/* attempt to retrieve the version array */
if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
- sv_catpvs(sv,"0");
- return sv;
+ return newSVpvs("0");
}
len = av_len(av);
if ( len == -1 )
{
- sv_catpvs(sv,"0");
- return sv;
+ return newSVpvs("0");
}
digit = SvIV(*av_fetch(av, 0, 0));
- Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
+ sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
for ( i = 1 ; i < len ; i++ )
{
digit = SvIV(*av_fetch(av, i, 0));
{
I32 i, len, digit;
bool alpha = FALSE;
- SV * const sv = newSV(0);
+ SV *sv;
AV *av;
PERL_ARGS_ASSERT_VNORMAL;
len = av_len(av);
if ( len == -1 )
{
- sv_catpvs(sv,"");
- return sv;
+ return newSVpvs("");
}
digit = SvIV(*av_fetch(av, 0, 0));
- Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
+ sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
for ( i = 1 ; i < len ; i++ ) {
digit = SvIV(*av_fetch(av, i, 0));
Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
errno = ECONNABORTED;
tidy_up_and_fail:
{
- const int save_errno = errno;
+ dSAVE_ERRNO;
if (sockets[0] != -1)
PerlLIO_close(sockets[0]);
if (sockets[1] != -1)
PerlLIO_close(sockets[1]);
- errno = save_errno;
+ RESTORE_ERRNO;
return -1;
}
}
#endif
tidy_up_and_fail:
{
- const int save_errno = errno;
+ dSAVE_ERRNO;
if (listener != -1)
PerlLIO_close(listener);
if (connector != -1)
PerlLIO_close(connector);
if (acceptor != -1)
PerlLIO_close(acceptor);
- errno = save_errno;
+ RESTORE_ERRNO;
return -1;
}
}
* 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. */
#ifdef PERL_MEM_LOG
-/*
- * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
+/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
+ * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
+ * given, and you supply your own implementation.
+ *
+ * The default implementation reads a single env var, PERL_MEM_LOG,
+ * expecting one or more of the following:
*
- * PERL_MEM_LOG_ENV: if defined, during run time the environment
- * variables PERL_MEM_LOG and PERL_SV_LOG will be consulted, and
- * if the integer value of that is true, the logging will happen.
- * (The default is to always log if the PERL_MEM_LOG define was
- * in effect.)
+ * \d+ - fd fd to write to : must be 1st (atoi)
+ * 'm' - memlog was PERL_MEM_LOG=1
+ * 's' - svlog was PERL_SV_LOG=1
+ * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
*
- * PERL_MEM_LOG_TIMESTAMP: if defined, a timestamp will be logged
- * before every memory logging entry. This can be turned off at run
- * time by setting the environment variable PERL_MEM_LOG_TIMESTAMP
- * to zero.
+ * This makes the logger controllable enough that it can reasonably be
+ * added to the system perl.
*/
-/*
- * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
+/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
* the Perl_mem_log_...() will use (either via sprintf or snprintf).
*/
#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
-/*
- * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
- * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD,
- * in which case the environment variable PERL_MEM_LOG_FD will be
- * consulted for the file descriptor number to use.
+/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
+ * writes to. In the default logger, this is settable at runtime.
*/
#ifndef PERL_MEM_LOG_FD
# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
#endif
-#ifdef PERL_MEM_LOG_STDERR
+#ifndef PERL_MEM_LOG_NOIMPL
# ifdef DEBUG_LEAKING_SCALARS
# define SV_LOG_SERIAL_FMT " [%lu]"
# endif
static void
-S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const char *type_name, const SV *sv, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+S_mem_log_common(enum mem_log_type mlt, const UV n,
+ const UV typesize, const char *type_name, const SV *sv,
+ Malloc_t oldalloc, Malloc_t newalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
{
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
- const char *s;
-# endif
+ const char *pmlenv;
PERL_ARGS_ASSERT_MEM_LOG_COMMON;
-# ifdef PERL_MEM_LOG_ENV
- s = PerlEnv_getenv(mlt < MLT_NEW_SV ? "PERL_MEM_LOG" : "PERL_SV_LOG");
- if (s ? atoi(s) : 0)
-# endif
+ pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
+ if (!pmlenv)
+ return;
+ if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
{
/* We can't use SVs or PerlIO for obvious reasons,
* so we'll use stdio and low-level IO instead. */
char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-# ifdef PERL_MEM_LOG_TIMESTAMP
+
# ifdef HAS_GETTIMEOFDAY
# define MEM_LOG_TIME_FMT "%10d.%06d: "
# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
(void)time(&when);
# endif
/* If there are other OS specific ways of hires time than
- * gettimeofday() (see ext/Time/HiRes), the easiest way is
+ * gettimeofday() (see ext/Time-HiRes), the easiest way is
* probably that they would be used to fill in the struct
* timeval. */
-# endif
{
- int fd = PERL_MEM_LOG_FD;
STRLEN len;
+ int fd = atoi(pmlenv);
+ if (!fd)
+ fd = PERL_MEM_LOG_FD;
-# ifdef PERL_MEM_LOG_ENV_FD
- if ((s = PerlEnv_getenv("PERL_MEM_LOG_FD"))) {
- fd = atoi(s);
- }
-# endif
-# ifdef PERL_MEM_LOG_TIMESTAMP
- s = PerlEnv_getenv("PERL_MEM_LOG_TIMESTAMP");
- if (!s || atoi(s)) {
+ if (strchr(pmlenv, 't')) {
len = my_snprintf(buf, sizeof(buf),
MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
PerlLIO_write(fd, buf, len);
}
-# endif
switch (mlt) {
case MLT_ALLOC:
len = my_snprintf(buf, sizeof(buf),
filename, linenumber, funcname,
PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
break;
+ default:
+ len = 0;
}
PerlLIO_write(fd, buf, len);
}
}
}
+#endif /* !PERL_MEM_LOG_NOIMPL */
+
+#ifndef PERL_MEM_LOG_NOIMPL
+# define \
+ mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
+ mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
+#else
+/* this is suboptimal, but bug compatible. User is providing their
+ own implemenation, but is getting these functions anyway, and they
+ do nothing. But _NOIMPL users should be able to cope or fix */
+# define \
+ mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
+ /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
#endif
Malloc_t
-Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
-{
-#ifdef PERL_MEM_LOG_STDERR
- mem_log_common(MLT_ALLOC, n, typesize, type_name, NULL, NULL, newalloc, filename, linenumber, funcname);
-#endif
+Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
+ Malloc_t newalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
+{
+ mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
+ NULL, NULL, newalloc,
+ filename, linenumber, funcname);
return newalloc;
}
Malloc_t
-Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
-{
-#ifdef PERL_MEM_LOG_STDERR
- mem_log_common(MLT_REALLOC, n, typesize, type_name, NULL, oldalloc, newalloc, filename, linenumber, funcname);
-#endif
+Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
+ Malloc_t oldalloc, Malloc_t newalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
+{
+ mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
+ NULL, oldalloc, newalloc,
+ filename, linenumber, funcname);
return newalloc;
}
Malloc_t
-Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_free(Malloc_t oldalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
{
-#ifdef PERL_MEM_LOG_STDERR
- mem_log_common(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname);
-#endif
+ mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
+ filename, linenumber, funcname);
return oldalloc;
}
void
-Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_new_sv(const SV *sv,
+ const char *filename, const int linenumber,
+ const char *funcname)
{
-#ifdef PERL_MEM_LOG_STDERR
- mem_log_common(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname);
-#endif
+ mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
+ filename, linenumber, funcname);
}
void
-Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_del_sv(const SV *sv,
+ const char *filename, const int linenumber,
+ const char *funcname)
{
-#ifdef PERL_MEM_LOG_STDERR
- mem_log_common(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname);
-#endif
+ mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
+ filename, linenumber, funcname);
}
#endif /* PERL_MEM_LOG */
PERL_ARGS_ASSERT_MY_CXT_INIT;
if (*index == -1) {
/* this module hasn't been allocated an index yet */
+#if defined(USE_ITHREADS)
MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
*index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
}
/* make sure the array is big enough */
index = Perl_my_cxt_index(aTHX_ my_cxt_key);
if (index == -1) {
/* this module hasn't been allocated an index yet */
+#if defined(USE_ITHREADS)
MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
}
/* make sure the array is big enough */
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;