More bits and pieces of logging code

generic/tcl.decls

@@ -2385,6 +2385,29 @@ declare 644 {
 	    int type, int size)
 }
 
+# TIP #390
+declare 645 {
+    void Tcl_Log(Tcl_Interp *interp, Tcl_LogLevel level,
+	    const char *message, ...)
+}
+
+declare 646 {
+    void Tcl_SetLogLevel(Tcl_Interp *interp, Tcl_LogLevel level)
+}
+
+declare 647 {
+    Tcl_LogLevel Tcl_GetLogLevel(Tcl_Interp *interp)
+}
+
+declare 648 {
+    int Tcl_LogLevelEnabled(Tcl_Interp *interp, Tcl_LogLevel level)
+}
+
+declare 649 {
+    void Tcl_SetLogHandler(Tcl_Interp *interp,
+	    const Tcl_LogHandler *logHandler, ClientData clientData)
+}
+
 # ----- BASELINE -- FOR -- 8.7.0 ----- #
 
 ##############################################################################

generic/tcl.h

@@ -2338,6 +2338,34 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp,
 typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
 				int result);
 
+/*
+ *----------------------------------------------------------------------------
+ * Logging system declarations.
+ */
+
+typedef enum {
+    TCL_LOG_DEV,
+    TCL_LOG_DEBUG,
+    TCL_LOG_INFO,
+    TCL_LOG_NOTICE,
+    TCL_LOG_WARNING,
+    TCL_LOG_ERROR,
+    TCL_LOG_FATAL,
+    TCL_LOG_BUG
+} Tcl_LogLevel;
+
+typedef int (Tcl_LogProc)(ClientData clientData, Tcl_Interp *interp,
+			Tcl_LogLevel level, Tcl_Obj *message);
+typedef void (Tcl_SetLogLevelProc)(ClientData clientData, Tcl_Interp *interp,
+			Tcl_LogLevel level);
+typedef void (Tcl_FreeLogHandlerProc)(ClientData clientData);
+
+typedef struct Tcl_LogHandler {
+    Tcl_LogProc *logProc;
+    Tcl_SetLogLevelProc *setLevelProc;
+    Tcl_FreeLogHandlerProc *freeProc;
+} Tcl_LogHandler;
+
 /*
  *----------------------------------------------------------------------------
  * The following constant is used to test for older versions of Tcl in the

generic/tclBasic.c

@@ -874,6 +874,15 @@ Tcl_CreateInterp(void)
     iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
     iPtr->deferredCallbacks = NULL;
 
+    /*
+     * Set a basic logger.
+     */
+
+    iPtr->log.level = TCL_LOG_DEV;
+    iPtr->log.handler = NULL;
+    iPtr->log.clientData = NULL;
+    TclInstallStdoutLogger((Tcl_Interp *) iPtr);
+
     /*
      * Create the core commands. Do it here, rather than calling
      * Tcl_CreateCommand, because it's faster (there's no need to check for a

generic/tclDecls.h

@@ -1901,6 +1901,21 @@ EXTERN int		Tcl_IsShared(Tcl_Obj *objPtr);
 EXTERN int		Tcl_LinkArray(Tcl_Interp *interp,
 				const char *varName, void *addr, int type,
 				int size);
+/* 645 */
+EXTERN void		Tcl_Log(Tcl_Interp *interp, Tcl_LogLevel level,
+				const char *message, ...);
+/* 646 */
+EXTERN void		Tcl_SetLogLevel(Tcl_Interp *interp,
+				Tcl_LogLevel level);
+/* 647 */
+EXTERN Tcl_LogLevel	Tcl_GetLogLevel(Tcl_Interp *interp);
+/* 648 */
+EXTERN int		Tcl_LogLevelEnabled(Tcl_Interp *interp,
+				Tcl_LogLevel level);
+/* 649 */
+EXTERN void		Tcl_SetLogHandler(Tcl_Interp *interp,
+				const Tcl_LogHandler *logHandler,
+				ClientData clientData);
 
 typedef struct {
     const struct TclPlatStubs *tclPlatStubs;
@@ -2581,6 +2596,11 @@ typedef struct TclStubs {
     void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
     int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
     int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */
+    void (*tcl_Log) (Tcl_Interp *interp, Tcl_LogLevel level, const char *message, ...); /* 645 */
+    void (*tcl_SetLogLevel) (Tcl_Interp *interp, Tcl_LogLevel level); /* 646 */
+    Tcl_LogLevel (*tcl_GetLogLevel) (Tcl_Interp *interp); /* 647 */
+    int (*tcl_LogLevelEnabled) (Tcl_Interp *interp, Tcl_LogLevel level); /* 648 */
+    void (*tcl_SetLogHandler) (Tcl_Interp *interp, const Tcl_LogHandler *logHandler, ClientData clientData); /* 649 */
 } TclStubs;
 
 extern const TclStubs *tclStubsPtr;
@@ -3901,6 +3921,16 @@ extern const TclStubs *tclStubsPtr;
 	(tclStubsPtr->tcl_IsShared) /* 643 */
 #define Tcl_LinkArray \
 	(tclStubsPtr->tcl_LinkArray) /* 644 */
+#define Tcl_Log \
+	(tclStubsPtr->tcl_Log) /* 645 */
+#define Tcl_SetLogLevel \
+	(tclStubsPtr->tcl_SetLogLevel) /* 646 */
+#define Tcl_GetLogLevel \
+	(tclStubsPtr->tcl_GetLogLevel) /* 647 */
+#define Tcl_LogLevelEnabled \
+	(tclStubsPtr->tcl_LogLevelEnabled) /* 648 */
+#define Tcl_SetLogHandler \
+	(tclStubsPtr->tcl_SetLogHandler) /* 649 */
 
 #endif /* defined(USE_TCL_STUBS) */
 

generic/tclInt.h

@@ -2186,6 +2186,12 @@ typedef struct Interp {
     Tcl_Obj *innerContext;	/* cached list for fast reallocation */
     int resetErrorStack;        /* controls cleaning up of ::errorStack */
 
+    struct {
+	Tcl_LogLevel level;
+	const Tcl_LogHandler *handler;
+	ClientData clientData;
+    } log;
+
 #ifdef TCL_COMPILE_STATS
     /*
      * Statistical information about the bytecode compiler and interpreter's
@@ -2900,6 +2906,8 @@ struct Tcl_LoadHandle_ {
 
 MODULE_SCOPE void	TclAppendBytesToByteArray(Tcl_Obj *objPtr,
 			    const unsigned char *bytes, int len);
+MODULE_SCOPE void	TclAppendPrintfToObjVA(Tcl_Obj *objPtr,
+			    const char *format, va_list argList);
 MODULE_SCOPE int	TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
 			    int flags);
 MODULE_SCOPE void	TclAdvanceContinuations(int *line, int **next,
@@ -2952,6 +2960,11 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp,
 			    const char *name, Tcl_Namespace *nameNamespacePtr,
 			    Tcl_Namespace *ensembleNamespacePtr, int flags);
 MODULE_SCOPE void	TclDeleteNamespaceVars(Namespace *nsPtr);
+#if defined(__GNUC__) || defined(__clang__)
+__attribute__((format (printf, 3, 4)))
+#endif
+MODULE_SCOPE void	TclDoLog(Tcl_Interp *interp, Tcl_LogLevel level,
+			    const char *message, ...);
 MODULE_SCOPE int	TclFindDictElement(Tcl_Interp *interp,
 			    const char *dict, int dictLength,
 			    const char **elementPtr, const char **nextPtr,
@@ -3073,6 +3086,7 @@ MODULE_SCOPE void	TclInitNamespaceSubsystem(void);
 MODULE_SCOPE void	TclInitNotifier(void);
 MODULE_SCOPE void	TclInitObjSubsystem(void);
 MODULE_SCOPE void	TclInitSubsystems(void);
+MODULE_SCOPE void	TclInstallStdoutLogger(Tcl_Interp *interp);
 MODULE_SCOPE int	TclInterpReady(Tcl_Interp *interp);
 MODULE_SCOPE int	TclIsSpaceProc(int byte);
 MODULE_SCOPE int	TclIsBareword(int byte);
@@ -4956,6 +4970,19 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
 #define TCL_CT_ASSERT(e) \
     {enum { ct_assert_value = 1/(!!(e)) };}
 
+/*
+ * Inline logging check. Not great because we can't use varargs macros.
+ */
+
+#define TclLog(interp,levelValue,arguments) \
+    do {							\
+	TCL_CT_ASSERT(levelValue >= TCL_LOG_DEV);		\
+	TCL_CT_ASSERT(levelValue <= TCL_LOG_BUG);		\
+	if ((levelValue) >= ((Interp *) (interp))->log.level) { \
+	    TclDoLog arguments;					\
+	}							\
+    } while (0)
+
 /*
  *----------------------------------------------------------------
  * Allocator for small structs (<=sizeof(Tcl_Obj)) using the Tcl_Obj pool.

generic/tclLogging.c

@@ -0,0 +1,251 @@
+/*
+ * tclLogging.c --
+ *
+ *	Contains the logging facilities for TCL.
+ *
+ * Copyright (c) 2019 Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+
+static const char *levelNames[] = {
+    "DEV",
+    "DEBUG",
+    "INFO",
+    "NOTICE",
+    "WARNING",
+    "ERROR",
+    "FATAL",
+    "BUG"
+};
+
+Tcl_LogLevel
+Tcl_GetLogLevel(
+    Tcl_Interp *interp)
+{
+    Interp *iPtr = (Interp *) interp;
+    return iPtr->log.level;
+}
+
+void
+Tcl_SetLogLevel(
+    Tcl_Interp *interp,
+    Tcl_LogLevel level)
+{
+    Interp *iPtr = (Interp *) interp;
+
+    if (TCL_LOG_DEV > (int) level || TCL_LOG_BUG < (int) level) {
+	Tcl_Panic("bad log level: %d", level);
+    }
+    iPtr->log.level = level;
+    if (iPtr->log.handler && iPtr->log.handler->setLevelProc) {
+	iPtr->log.handler->setLevelProc(iPtr->log.clientData, interp, level);
+    }
+}
+
+int
+Tcl_LogLevelEnabled(
+    Tcl_Interp *interp,
+    Tcl_LogLevel level)
+{
+    Interp *iPtr = (Interp *) interp;
+    return level >= iPtr->log.level;
+}
+
+void
+Tcl_Log(
+    Tcl_Interp *interp,
+    Tcl_LogLevel level,
+    const char *message,
+    ...)
+{
+    Interp *iPtr = (Interp *) interp;
+    va_list argList;
+    Tcl_Obj *objPtr;
+
+    /*
+     * Check the logging level is legal.
+     */
+
+    if (TCL_LOG_DEV > (int) level || TCL_LOG_BUG < (int) level) {
+	Tcl_Panic("bad log level: %d", level);
+    }
+
+    /*
+     * Are we allowed to log this at the moment?
+     */
+
+    if (level < iPtr->log.level) {
+	return;
+    }
+
+    /*
+     * Is there a handler registered?
+     */
+
+    if (!iPtr->log.handler || !iPtr->log.handler->logProc) {
+	return;
+    }
+
+    /*
+     * Format the log detail message. The log handler itself may do more.
+     */
+
+    objPtr = Tcl_NewObj();
+    va_start(argList, message);
+    TclAppendPrintfToObjVA(objPtr, message, argList);
+    va_end(argList);
+
+    /*
+     * Dispatch to the log handler. Note that logging does not report errors
+     * directly.
+     */
+
+    Tcl_IncrRefCount(objPtr);
+    iPtr->log.handler->logProc(iPtr->log.clientData,
+	    interp, level, objPtr);
+    Tcl_DecrRefCount(objPtr);
+}
+
+void
+TclDoLog(
+    Tcl_Interp *interp,
+    Tcl_LogLevel level,
+    const char *message,
+    ...)
+{
+    Interp *iPtr = (Interp *) interp;
+    va_list argList;
+    Tcl_Obj *objPtr;
+
+    /*
+     * Are we allowed to log this at the moment?
+     */
+
+    if (level < iPtr->log.level) {
+	return;
+    }
+
+    /*
+     * Is there a handler registered?
+     */
+
+    if (!iPtr->log.handler || !iPtr->log.handler->logProc) {
+	return;
+    }
+
+    /*
+     * Format the log detail message. The log handler itself may do more.
+     */
+
+    objPtr = Tcl_NewObj();
+    va_start(argList, message);
+    TclAppendPrintfToObjVA(objPtr, message, argList);
+    va_end(argList);
+
+    /*
+     * Dispatch to the log handler. Note that logging does not report errors
+     * directly.
+     */
+
+    Tcl_IncrRefCount(objPtr);
+    iPtr->log.handler->logProc(iPtr->log.clientData,
+	    interp, level, objPtr);
+    Tcl_DecrRefCount(objPtr);
+}
+
+void
+Tcl_SetLogHandler(
+    Tcl_Interp *interp,
+    const Tcl_LogHandler *logHandler,
+    ClientData clientData)
+{
+    Interp *iPtr = (Interp *) interp;
+
+    /*
+     * Free any old handler.
+     */
+
+    if (iPtr->log.handler && iPtr->log.handler->freeProc) {
+	iPtr->log.handler->freeProc(iPtr->log.clientData);
+    }
+
+    /*
+     * Install the new log handler.
+     */
+
+    iPtr->log.handler = logHandler;
+    iPtr->log.clientData = clientData;
+
+    /*
+     * Inform the log handler what the current logging level is.
+     */
+
+    if (iPtr->log.handler->setLevelProc) {
+	iPtr->log.handler->setLevelProc(iPtr->log.clientData,
+		interp, iPtr->log.level);
+    }
+}
+
+static Tcl_LogProc LogToStdout;
+static Tcl_SetLogLevelProc StdoutLogLevelSet;
+static Tcl_FreeLogHandlerProc StdoutLogFree;
+
+static const Tcl_LogHandler simpleStdoutLog = {
+    LogToStdout,
+    StdoutLogLevelSet,
+    StdoutLogFree
+};
+
+struct StdoutLog {
+    Tcl_LogLevel level;
+};
+
+void
+TclInstallStdoutLogger(
+    Tcl_Interp *interp)
+{
+    struct StdoutLog *levelStore = ckalloc(sizeof(struct StdoutLog));
+    Tcl_SetLogHandler(interp, &simpleStdoutLog, levelStore);
+}
+
+static void
+StdoutLogLevelSet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_LogLevel level)
+{
+    struct StdoutLog *levelStore = clientData;
+    levelStore->level = level;
+}
+
+static void
+StdoutLogFree(
+    ClientData clientData)
+{
+    struct StdoutLog *levelStore = clientData;
+    ckfree(levelStore);
+}
+
+static int
+LogToStdout(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_LogLevel level,
+    Tcl_Obj *message)
+{
+    fprintf(stdout, "[%s] %s\n", levelNames[level], TclGetString(message));
+    return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */

generic/tclStringObj.c

@@ -2558,6 +2558,15 @@ Tcl_Format(
  *---------------------------------------------------------------------------
  */
 
+void
+TclAppendPrintfToObjVA(
+    Tcl_Obj *objPtr,
+    const char *format,
+    va_list argList)
+{
+    AppendPrintfToObjVA(objPtr, format, argList);
+}
+
 static void
 AppendPrintfToObjVA(
     Tcl_Obj *objPtr,

generic/tclStubInit.c

@@ -1631,6 +1631,11 @@ const TclStubs tclStubs = {
     Tcl_DecrRefCount, /* 642 */
     Tcl_IsShared, /* 643 */
     Tcl_LinkArray, /* 644 */
+    Tcl_Log, /* 645 */
+    Tcl_SetLogLevel, /* 646 */
+    Tcl_GetLogLevel, /* 647 */
+    Tcl_LogLevelEnabled, /* 648 */
+    Tcl_SetLogHandler, /* 649 */
 };
 
 /* !END!: Do not edit above this line. */

unix/Makefile.in

@@ -305,7 +305,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
 	tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
 	tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
 	tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \
-	tclLink.o tclListObj.o \
+	tclLink.o tclListObj.o tclLogging.o \
 	tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
 	tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
 	tclPkg.o tclPkgConfig.o tclPosixStr.o \
@@ -439,6 +439,7 @@ GENERIC_SRCS = \
 	$(GENERIC_DIR)/tclListObj.c \
 	$(GENERIC_DIR)/tclLiteral.c \
 	$(GENERIC_DIR)/tclLoad.c \
+	$(GENERIC_DIR)/tclLogging.c \
 	$(GENERIC_DIR)/tclMain.c \
 	$(GENERIC_DIR)/tclNamesp.c \
 	$(GENERIC_DIR)/tclNotify.c \
@@ -1270,6 +1271,9 @@ tclListObj.o: $(GENERIC_DIR)/tclListObj.c
 tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR)
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c
 
+tclLogging.o: $(GENERIC_DIR)/tclLogging.c
+	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLogging.c
+
 tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS)
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c