From a6989e2cc2009887c0b162bc8d321b5bef2dd78e Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Wed, 12 Mar 2014 12:41:57 -0700
Subject: [PATCH] logging.server: add support for changing the logging root
 temporarily.

---
 basis/logging/logging-tests.factor | 25 ++++++++++++++-----------
 basis/logging/server/server.factor | 15 ++++++++++++---
 2 files changed, 26 insertions(+), 14 deletions(-)

diff --git a/basis/logging/logging-tests.factor b/basis/logging/logging-tests.factor
index a7cc6c6f5f..a2e67bfd62 100644
--- a/basis/logging/logging-tests.factor
+++ b/basis/logging/logging-tests.factor
@@ -1,5 +1,6 @@
 IN: logging.tests
-USING: tools.test logging logging.analysis io math ;
+USING: tools.test logging logging.analysis logging.server io
+io.files.temp math ;
 
 : input-logging-test ( a b -- c ) + ;
 
@@ -13,14 +14,16 @@ USING: tools.test logging logging.analysis io math ;
 
 \ error-logging-test ERROR add-error-logging
 
-"logging-test" [
-    [ 4 ] [ 1 3 input-logging-test ] unit-test
-    
-    [ 4 ] [ 1 3 output-logging-test ] unit-test
-    
-    [ 4/3 ] [ 4 3 error-logging-test ] unit-test
-    
-    [ f ] [ 1 0 error-logging-test ] unit-test
-] with-logging
+temp-directory [
+    "logging-test" [
+        [ 4 ] [ 1 3 input-logging-test ] unit-test
 
-[ ] [ "logging-test" { "input-logging-test" } analyze-log-file ] unit-test
+        [ 4 ] [ 1 3 output-logging-test ] unit-test
+
+        [ 4/3 ] [ 4 3 error-logging-test ] unit-test
+
+        [ f ] [ 1 0 error-logging-test ] unit-test
+    ] with-logging
+
+    [ ] [ "logging-test" { "input-logging-test" } analyze-log-file ] unit-test
+] with-log-root
diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor
index 440e192107..28fbe22e7b 100644
--- a/basis/logging/server/server.factor
+++ b/basis/logging/server/server.factor
@@ -3,12 +3,12 @@
 USING: assocs calendar calendar.format combinators
 concurrency.messaging continuations debugger destructors init io
 io.directories io.encodings.utf8 io.files io.pathnames kernel
-literals math math.parser math.ranges namespaces sequences
+locals math math.parser math.ranges namespaces sequences
 strings threads ;
 IN: logging.server
 
 : log-root ( -- string )
-    \ log-root get [ "logs" resource-path ] unless* ;
+    \ log-root get-global [ "logs" resource-path ] unless* ;
 
 : log-path ( service -- path )
     log-root prepend-path ;
@@ -26,10 +26,19 @@ SYMBOL: log-files
 : log-stream ( service -- stream )
     log-files get [ open-log-stream ] cache ;
 
+: close-log-streams ( -- )
+    log-files get [ values dispose-each ] [ clear-assoc ] bi ;
+
+:: with-log-root ( path quot -- )
+    [ close-log-streams path \ log-root set-global quot call ]
+    \ log-root get-global
+    [ \ log-root set-global close-log-streams ] curry
+    [ ] cleanup ; inline
+
 : timestamp-header. ( -- )
     "[" write now (timestamp>rfc3339) "] " write ;
 
-CONSTANT: multiline-header $[ 20 CHAR: - <string> ]
+: multiline-header ( -- str ) 20 CHAR: - <string> ; foldable
 
 : multiline-header. ( -- )
     "[" write multiline-header write "] " write ;