make-logger: support specification of events to propagate

Events to propagate to a parent are described in the same way
as events to receive for a log receiver. The default is still
to propagate all events to the parent, which corresponds to
a propagation specification of 'debug.

Making a propagation-filtering specification built-in, instead of
allowing arbitrary filter functions, keeps `log-level?` efficient and
avoid hooks that might be implemented by untrusted code.

pkgs/racket-pkgs/racket-doc/scribblings/reference/logging.scrbl

@@ -84,13 +84,26 @@ otherwise.}
 
 
 @defproc[(make-logger [name (or/c symbol? #f) #f]
-                      [parent (or/c logger? #f) #f])
+                      [parent (or/c logger? #f) #f]
+                      [propagate-level (or/c 'none 'fatal 'error 'warning 'info 'debug) 'debug]
+                      [propagate-name (or/c #f symbol?) #f]
+                      ... ...)
          logger?]{
 
 Creates a new @tech{logger} with an optional name and parent.
 
+The optional @racket[propagate-level] and @racket[propagate-name]
+arguments constrain the events that are propagated from the new logger
+to @racket[parent] (when @racket[parent] is not @racket[#f]) in the
+same way that events are described for a log receiver in
+@racket[make-log-receiver]. By default, all events are propagated to
+@racket[parent].
+
 @history[#:changed "6.1.1.3" @elem{Removed an optional argument to
-                                   specify a notification callback.}]}
+                                   specify a notification callback,
+                                   and added @racket[propagate-level] and
+                                   @racket[propagate-name] constraints for
+                                   events to propagate.}]}
 
 
 @defproc[(logger-name [logger logger?]) (or/c symbol? #f)]{
@@ -148,11 +161,8 @@ by @racket[": "] before it is sent to receivers.
 Reports whether any @tech{log receiver} attached to @racket[logger] or
 one of its ancestors is interested in @racket[level] events (or
 potentially lower) or @racket[name]. If @racket[name] is @racket[#f],
-the result indicates whether any @tech{log receiver} is interested in
+the result indicates whether a @tech{log receiver} is interested in
-events at @racket[level] for any name. A true result for
+events at @racket[level] for any name.
-@racket[(log-level?  logger level name)] implies a true result for
-@racket[(log-level? logger level #f)], but not vice versa if
-@racket[name] is a symbol.
 
 Use this function to avoid work generating an
 event for @racket[log-message] if no receiver is interested in the

pkgs/racket-pkgs/racket-test/tests/racket/logger.rktl

@@ -13,7 +13,7 @@
 
 (test #f logger-name (make-logger))
 
-(arity-test make-logger 0 2)
+(arity-test make-logger 0 -1)
 
 ; --------------------
 
@@ -100,23 +100,28 @@
 
 (let ()
   (define-logger test)
-  (define r (make-log-receiver (current-logger) 'info 'test 'warning))
+  (define r (make-log-receiver (current-logger) 'info 'test2 'warning))
   (test #t log-level? test-logger 'warning)
   (test #t log-level? test-logger 'info)
-  (test #t log-level? test-logger 'info 'test)
+  (test #t log-level? test-logger 'info 'test2)
   (test #f log-level? test-logger 'info 'not-test)
-  (test #f log-level? test-logger 'debug 'test)
+  (test #f log-level? test-logger 'debug 'test2)
   (test 'info log-max-level test-logger)
-  (test 'info log-max-level test-logger 'test)
+  (test 'info log-max-level test-logger 'test2)
   (test 'warning log-max-level test-logger 'not-test)
-  (define r2 (make-log-receiver (current-logger) 'warning 'test 'info))
+  ;; Retain receiver to avoid GC influence on tests
-  (test #t log-level? test-logger 'info 'test)
+  (test #f sync/timeout 0 r))
+
+(let ()
+  (define-logger test)
+  (define r2 (make-log-receiver (current-logger) 'warning 'test3 'info))
+  (test #f log-level? test-logger 'info 'test3)
   (test #t log-level? test-logger 'info 'not-test)
-  (test #f log-level? test-logger 'debug 'test)
+  (test #f log-level? test-logger 'debug 'test3)
   (test 'info log-max-level test-logger)
-  (test 'info log-max-level test-logger 'test)
+  (test 'warning log-max-level test-logger 'test3)
   (test 'info log-max-level test-logger 'not-test)
-  (test #f sync/timeout 0 r)
+  ;; Retain receiver to avoid GC influence on tests
   (test #f sync/timeout 0 r2))
 
 ; ----------------------------------------
@@ -170,6 +175,57 @@
   (log-message l 'info 'sub "hey" #f)
   (test '#(info "sub: hey" #f sub) sync/timeout 0 r))
 
+;; --------------------
+;; Check logger propagate constraints
+
+(let ()
+  (define l (make-logger))
+  (define l2 (make-logger #f l 'error))
+  (define l3 (make-logger #f l2 'warning 'test 'info))
+  (define l32 (make-logger #f l2 'info 'test 'warning))
+  
+  (define r (make-log-receiver l 'debug))
+  (test #f sync/timeout 0 r)
+  
+  (log-message l 'debug "debug message" #f)
+  (test #t vector? (sync/timeout 0 r))
+  
+  (define r2 (make-log-receiver l2 'info))
+  (test (void) log-message l2 'warning "warning message not propagated" #f)
+  (test #f sync/timeout 0 r)
+  (test #t vector? (sync/timeout 0 r2))
+
+  (test (void) log-message l3 'error "error message propagated" #f)
+  (test #t vector? (sync/timeout 0 r))
+  (test #t vector? (sync/timeout 0 r2))
+
+  (test (void) log-message l3 'info "info message partially propagated" #f)
+  (test #f sync/timeout 0 r)
+  (test #t vector? (sync/timeout 0 r2))
+  
+  (test (void) log-message l3 'info 'test "info message not propagated" #f)
+  (test #f sync/timeout 0 r)
+  (test #f sync/timeout 0 r2)
+  
+  (test 'debug log-max-level l)
+  (test 'info log-max-level l2)
+  (test 'info log-max-level l3)
+  
+  (define r22 (make-log-receiver l2 'debug))
+  (test 'debug log-max-level l)
+  (test 'debug log-max-level l2)
+  (test 'info log-max-level l3)
+  (test 'warning log-max-level l3 'test)
+  (test 'info log-max-level l3 'not-test)
+  (test 'info log-max-level l32)
+  (test 'warning log-max-level l32 'not-test)
+  (test 'info log-max-level l32 'test)
+  
+  ;; Retain receivers to avoid GC influence on tests
+  (test #f sync/timeout 0 r)
+  (test #f sync/timeout 0 r2)
+  (test #f sync/timeout 0 r22))
+
 ; --------------------
 
 (report-errs)

racket/src/racket/src/error.c

@@ -727,7 +727,7 @@ void scheme_init_error(Scheme_Env *env)
   GLOBAL_NONCM_PRIM("exit",              scheme_do_exit,  0, 1, env);
   GLOBAL_NONCM_PRIM("log-level?",        log_level_p,     2, 3, env);
   GLOBAL_NONCM_PRIM("log-max-level",     log_max_level,   1, 2, env);
-  GLOBAL_NONCM_PRIM("make-logger",       make_logger,     0, 2, env);
+  GLOBAL_NONCM_PRIM("make-logger",       make_logger,     0, -1, env);
   GLOBAL_NONCM_PRIM("make-log-receiver", make_log_reader, 2, -1, env);
 
   GLOBAL_PRIM_W_ARITY("log-message",    log_message,   4, 6, env);
@@ -3458,19 +3458,12 @@ static int extract_max_spec_level(Scheme_Object *level_spec, Scheme_Object *name
 void update_want_level(Scheme_Logger *logger, Scheme_Object *name)
 {
   Scheme_Log_Reader *lr;
-  Scheme_Object *stack = NULL, *queue, *b, *prev;
+  Scheme_Object *queue, *b, *prev;
-  Scheme_Logger *parent = logger, *orig_logger = logger;
+  Scheme_Logger *parent = logger;
-  int want_level, level;
+  int want_level, level, ceiling_level = SCHEME_LOG_DEBUG;
-
-  while (parent) {
-    stack = scheme_make_raw_pair((Scheme_Object *)parent, stack);
-    parent = parent->parent;
-  }
 
   want_level = 0;
-  while (stack) {
+  while (parent) {
-    parent = (Scheme_Logger *)SCHEME_CAR(stack);
-    
     queue = parent->readers;
     prev = NULL;
     while (queue) {
@@ -3479,8 +3472,12 @@ void update_want_level(Scheme_Logger *logger, Scheme_Object *name)
       lr = (Scheme_Log_Reader *)SCHEME_BOX_VAL(b);
       if (lr) {
         level = extract_max_spec_level(lr->level, name);
+        if (level > ceiling_level)
+          level = ceiling_level;
         if (level > want_level)
           want_level = level;
+        if (want_level >= ceiling_level)
+          break;
         prev = queue;
       } else {
         if (prev)
@@ -3498,7 +3495,17 @@ void update_want_level(Scheme_Logger *logger, Scheme_Object *name)
     if (level > want_level)
       want_level = level;    
 
-    stack = SCHEME_CDR(stack);
+    if (parent->propagate_level)
+      level = extract_max_spec_level(parent->propagate_level, name);
+    else
+      level = SCHEME_LOG_DEBUG;
+    if (level <= ceiling_level)
+      ceiling_level = level;
+
+    if (want_level >= ceiling_level)
+      break;
+
+    parent = parent->parent;
   }
 
   if (!name) {
@@ -3508,8 +3515,6 @@ void update_want_level(Scheme_Logger *logger, Scheme_Object *name)
 #   define WANT_NAME_LEVEL_CACHE_SIZE 8
     int i;
 
-    logger = orig_logger;
-
     b = logger->want_name_level_cache;
     if (!b) {
       b = scheme_make_vector(3 * WANT_NAME_LEVEL_CACHE_SIZE, scheme_make_integer(-1));
@@ -3783,6 +3788,11 @@ void scheme_log_name_pfx_message(Scheme_Logger *logger, int level, Scheme_Object
       queue = SCHEME_CDR(queue);
     }
 
+    if (logger->parent && logger->propagate_level) {
+      if (extract_spec_level(logger->propagate_level, name) < level)
+        break;
+    }
+
     logger = logger->parent;
   }
 }
@@ -3991,10 +4001,42 @@ log_max_level(int argc, Scheme_Object *argv[])
   }
 }
 
+static Scheme_Object *get_levels_and_names(const char *who, int i, int argc, Scheme_Object **argv,
+                                           int default_lvl)
+{
+  int lvl;
+  Scheme_Object *level = scheme_null, *last = NULL;
+
+  for (; i < argc; i += 2) {
+    lvl = extract_level(who, 1, i, argc, argv);
+    if ((i+1) < argc) {
+      if (SCHEME_FALSEP(argv[i+1]))
+        default_lvl = lvl;
+      else {
+        if (!SCHEME_SYMBOLP(argv[i+1]))
+          scheme_wrong_contract(who, "(or/c symbol? #f)", i+1, argc, argv);
+        level = scheme_make_pair(argv[i+1], level);
+        if (!last) last = level;
+        level = scheme_make_pair(scheme_make_integer(lvl), level);
+      }
+    } else {
+      default_lvl = lvl;
+    }
+  }
+
+  if (last)
+    SCHEME_CDR(last) = scheme_make_integer(default_lvl);
+  else
+    level = scheme_make_integer(default_lvl);
+
+  return level;
+}
+
 static Scheme_Object *
 make_logger(int argc, Scheme_Object *argv[])
 {
   Scheme_Logger *parent, *logger;
+  Scheme_Object *propagate_level;
 
   if (argc) {
     if (!SCHEME_FALSEP(argv[0]) && !SCHEME_SYMBOLP(argv[0]))
@@ -4013,11 +4055,17 @@ make_logger(int argc, Scheme_Object *argv[])
   } else
     parent = NULL;
 
+  propagate_level = get_levels_and_names("make-logger", 2, argc, argv,
+                                         SCHEME_LOG_DEBUG);
+
   logger = scheme_make_logger(parent, 
                               (argc 
                                ? (SCHEME_FALSEP(argv[0]) ? NULL : argv[0])
                                : NULL));
-  
+
+  if (parent)
+    logger->propagate_level = propagate_level;
+
   return (Scheme_Object *)logger;
 }
 
@@ -4076,34 +4124,13 @@ make_log_reader(int argc, Scheme_Object *argv[])
   Scheme_Logger *logger;
   Scheme_Log_Reader *lr;
   Scheme_Object *sema, *q;
-  int default_lvl = 0, lvl, i;
+  Scheme_Object *level;
-  Scheme_Object *level = scheme_null, *last = NULL;
 
   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
     scheme_wrong_contract("make-log-receiver", "logger?", 0, argc, argv);
   logger = (Scheme_Logger *)argv[0];
 
-  for (i = 1; i < argc; i += 2) {
+  level = get_levels_and_names("make-log-receiver", 1, argc, argv, 0);
-    lvl = extract_level("make-log-receiver", 1, i, argc, argv);
-    if ((i+1) < argc) {
-      if (SCHEME_FALSEP(argv[i+1]))
-        default_lvl = lvl;
-      else {
-        if (!SCHEME_SYMBOLP(argv[i+1]))
-          scheme_wrong_contract("make-log-receiver", "(or/c symbol? #f)", i+1, argc, argv);
-        level = scheme_make_pair(argv[i+1], level);
-        if (!last) last = level;
-        level = scheme_make_pair(scheme_make_integer(lvl), level);
-      }
-    } else {
-      default_lvl = lvl;
-    }
-  }
-
-  if (last)
-    SCHEME_CDR(last) = scheme_make_integer(default_lvl);
-  else
-    level = scheme_make_integer(default_lvl);
 
   lr = MALLOC_ONE_TAGGED(Scheme_Log_Reader);
   lr->so.type = scheme_log_reader_type;

racket/src/racket/src/mzmark_type.inc

@@ -3008,6 +3008,7 @@ static int mark_logger_MARK(void *p, struct NewGC *gc) {
   gcMARK2(l->timestamp, gc);
   gcMARK2(l->syslog_level, gc);
   gcMARK2(l->stderr_level, gc);
+  gcMARK2(l->propagate_level, gc);
   gcMARK2(l->readers, gc);
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Logger));
@@ -3021,6 +3022,7 @@ static int mark_logger_FIXUP(void *p, struct NewGC *gc) {
   gcFIXUP2(l->timestamp, gc);
   gcFIXUP2(l->syslog_level, gc);
   gcFIXUP2(l->stderr_level, gc);
+  gcFIXUP2(l->propagate_level, gc);
   gcFIXUP2(l->readers, gc);
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Logger));

racket/src/racket/src/mzmarksrc.c

@@ -1211,6 +1211,7 @@ mark_logger {
   gcMARK2(l->timestamp, gc);
   gcMARK2(l->syslog_level, gc);
   gcMARK2(l->stderr_level, gc);
+  gcMARK2(l->propagate_level, gc);
   gcMARK2(l->readers, gc);
  size:
   gcBYTES_TO_WORDS(sizeof(Scheme_Logger));

racket/src/racket/src/schpriv.h

@@ -3697,6 +3697,7 @@ struct Scheme_Logger {
   intptr_t *timestamp, local_timestamp; /* determines when want_level is up-to-date */
   Scheme_Object *syslog_level; /* (list* <level-int> <name-sym> ... <level-int>) */
   Scheme_Object *stderr_level;
+  Scheme_Object *propagate_level; /* can be NULL */
   Scheme_Object *readers; /* list of (cons (make-weak-box <reader>) <sema>) */
 };