route glib logging to Racket logging

collects/racket/draw/unsafe/glib.rkt

@@ -31,3 +31,7 @@
 (define-ffi-definer define-glib glib-lib)
 (define-ffi-definer define-gmodule gmodule-lib)
 (define-ffi-definer define-gobj gobj-lib)
+
+;; Route glib logging to Racket logging:
+(define-glib g_log_set_default_handler (_fun _fpointer _pointer -> _fpointer))
+(void (g_log_set_default_handler (get-ffi-obj 'scheme_glib_log_message #f _fpointer) #f))

src/racket/include/mzwin.def

@@ -100,6 +100,7 @@ EXPORTS
  scheme_log_message
  scheme_log_abort
  scheme_log_warning
+ scheme_glib_log_message
  scheme_out_of_memory_abort
  scheme_wrong_count
  scheme_wrong_count_m

src/racket/include/mzwin3m.def

@@ -100,6 +100,7 @@ EXPORTS
  scheme_log_message
  scheme_log_abort
  scheme_log_warning
+ scheme_glib_log_message
  scheme_out_of_memory_abort
  scheme_wrong_count
  scheme_wrong_count_m

src/racket/include/racket.exp

@@ -98,6 +98,7 @@ scheme_log
 scheme_log_message
 scheme_log_abort
 scheme_log_warning
+scheme_glib_log_message
 scheme_out_of_memory_abort
 scheme_wrong_count
 scheme_wrong_count_m

src/racket/include/racket3m.exp

@@ -98,6 +98,7 @@ scheme_log
 scheme_log_message
 scheme_log_abort
 scheme_log_warning
+scheme_glib_log_message
 scheme_out_of_memory_abort
 scheme_wrong_count
 scheme_wrong_count_m

src/racket/src/error.c

@@ -2882,6 +2882,49 @@ void scheme_log_warning(char *buffer)
   scheme_log_message(scheme_main_logger, SCHEME_LOG_WARNING, buffer, strlen(buffer), scheme_false);
 }
 
+void scheme_glib_log_message(const char *log_domain,
+                             int log_level,
+                             const char *message,
+                             void *user_data)
+/* This handler is suitable for use as a glib logging handler.
+   Although a handler can be implemented with the FFI,
+   we build one into Racket to avoid potential problems of
+   handlers getting GCed or retaining a namespace. */
+{
+#define mzG_LOG_LEVEL_ERROR    (1 << 2)
+#define mzG_LOG_LEVEL_CRITICAL (1 << 3)
+#define mzG_LOG_LEVEL_WARNING  (1 << 4)
+#define mzG_LOG_LEVEL_MESSAGE  (1 << 5)
+#define mzG_LOG_LEVEL_INFO     (1 << 6)
+#define mzG_LOG_LEVEL_DEBUG    (1 << 7)
+  int level, len1, len2;
+  char *together;
+
+  if (log_level & (mzG_LOG_LEVEL_ERROR))
+    level = SCHEME_LOG_FATAL;
+  if (log_level & (mzG_LOG_LEVEL_CRITICAL))
+    level = SCHEME_LOG_ERROR;
+  if (log_level & (mzG_LOG_LEVEL_WARNING | mzG_LOG_LEVEL_MESSAGE))
+    level = SCHEME_LOG_WARNING;
+  if (log_level & (mzG_LOG_LEVEL_INFO))
+    level = SCHEME_LOG_INFO;
+  if (log_level & (mzG_LOG_LEVEL_DEBUG))
+    level = SCHEME_LOG_DEBUG;
+
+  len2 = strlen(message);
+  if (log_domain) {
+    len1 = strlen(log_domain);
+    together = (char *)scheme_malloc_atomic(len1 + len2 + 3);
+    memcpy(together, log_domain, len1);
+    memcpy(together + len1, ": ", 2);
+    memcpy(together + len1 + 2 + 1, message, len2);
+    len2 += len1 + 2;
+  } else
+    together = (char *)message;
+  
+  scheme_log_message(scheme_main_logger, level, together, len2, scheme_false);
+}
+
 static int extract_level(const char *who, int which, int argc, Scheme_Object **argv)
 {
   Scheme_Object *v;

src/racket/src/schemef.h

@@ -205,6 +205,7 @@ MZ_EXTERN void scheme_log(Scheme_Logger *logger, int level, int flags,
 MZ_EXTERN void scheme_log_message(Scheme_Logger *logger, int level, char *buffer, intptr_t len, Scheme_Object *data);
 MZ_EXTERN void scheme_log_abort(char *buffer);
 MZ_EXTERN void scheme_log_warning(char *buffer);
+MZ_EXTERN void scheme_glib_log_message(const char *log_domain, int log_level, const char *message, void *user_data);
 MZ_EXTERN void scheme_out_of_memory_abort();
 
 MZ_EXTERN void scheme_wrong_count(const char *name, int minc, int maxc,

src/racket/src/schemex.h

@@ -162,6 +162,7 @@ void (*scheme_log)(Scheme_Logger *logger, int level, int flags,
 void (*scheme_log_message)(Scheme_Logger *logger, int level, char *buffer, intptr_t len, Scheme_Object *data);
 void (*scheme_log_abort)(char *buffer);
 void (*scheme_log_warning)(char *buffer);
+void (*scheme_glib_log_message)(const char *log_domain, int log_level, const char *message, void *user_data);
 void (*scheme_out_of_memory_abort)();
 void (*scheme_wrong_count)(const char *name, int minc, int maxc,
 				  int argc, Scheme_Object **argv);

src/racket/src/schemex.inc

@@ -106,6 +106,7 @@
   scheme_extension_table->scheme_log_message = scheme_log_message;
   scheme_extension_table->scheme_log_abort = scheme_log_abort;
   scheme_extension_table->scheme_log_warning = scheme_log_warning;
+  scheme_extension_table->scheme_glib_log_message = scheme_glib_log_message;
   scheme_extension_table->scheme_out_of_memory_abort = scheme_out_of_memory_abort;
   scheme_extension_table->scheme_wrong_count = scheme_wrong_count;
   scheme_extension_table->scheme_wrong_count_m = scheme_wrong_count_m;

src/racket/src/schemexm.h

@@ -106,6 +106,7 @@
 #define scheme_log_message (scheme_extension_table->scheme_log_message)
 #define scheme_log_abort (scheme_extension_table->scheme_log_abort)
 #define scheme_log_warning (scheme_extension_table->scheme_log_warning)
+#define scheme_glib_log_message (scheme_extension_table->scheme_glib_log_message)
 #define scheme_out_of_memory_abort (scheme_extension_table->scheme_out_of_memory_abort)
 #define scheme_wrong_count (scheme_extension_table->scheme_wrong_count)
 #define scheme_wrong_count_m (scheme_extension_table->scheme_wrong_count_m)

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.0.99.4"
+#define MZSCHEME_VERSION "5.0.99.5"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 99
-#define MZSCHEME_VERSION_W 4
+#define MZSCHEME_VERSION_W 5
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)