diff --git a/hslogger.cabal b/hslogger.cabal --- a/hslogger.cabal +++ b/hslogger.cabal @@ -1,10 +1,10 @@ Name: hslogger -Version: 1.0.7 +Version: 1.0.9 License: LGPL Maintainer: John Goerzen Author: John Goerzen Stability: Stable -Copyright: Copyright (c) 2004-2008 John Goerzen +Copyright: Copyright (c) 2004-2010 John Goerzen license-file: COPYRIGHT build-type: Simple Homepage: http://software.complete.org/hslogger @@ -23,11 +23,17 @@ contrib/java/hslogger4j-plugins.xml, contrib/java/org/haskell/hslogger/HsloggerLevel.java, contrib/java/org/haskell/hslogger/LogFileXMLReceiver.java, - contrib/java/org/haskell/hslogger/XMLDecoder.java + contrib/java/org/haskell/hslogger/XMLDecoder.java, + testsrc/Tests.hs, + testsrc/runtests.hs, + winbuild.bat Cabal-Version: >= 1.2 flag small_base description: choose the new smaller, split-up base package. +flag buildtests + description: Build the executable to run unit tests + default: False Library Exposed-Modules: @@ -40,7 +46,7 @@ if !os(windows) Build-Depends: unix if flag(small_base) - build-depends: base >= 3 && < 4, containers, directory, process, + build-depends: base >= 3 && < 5, containers, directory, process, time, old-locale else build-depends: base < 3, time @@ -48,7 +54,10 @@ Hs-Source-Dirs: src Executable runtests - Buildable: False + if flag(buildtests) + Buildable: True + else + Buildable: False Main-Is: runtests.hs HS-Source-Dirs: testsrc, . Extensions: ExistentialQuantification, OverlappingInstances, diff --git a/src/System/Log/Handler/Syslog.hs b/src/System/Log/Handler/Syslog.hs --- a/src/System/Log/Handler/Syslog.hs +++ b/src/System/Log/Handler/Syslog.hs @@ -185,7 +185,7 @@ openlog_local fifopath ident options fac pri = do s <- socket AF_UNIX Datagram 0 - openlog_generic s (SockAddrUnix "/dev/log") ident options fac pri + openlog_generic s (SockAddrUnix fifopath) ident options fac pri #endif {- | Log to a remote server via UDP. -} diff --git a/src/System/Log/Logger.hs b/src/System/Log/Logger.hs --- a/src/System/Log/Logger.hs +++ b/src/System/Log/Logger.hs @@ -1,6 +1,6 @@ {-# OPTIONS -fglasgow-exts #-} {- arch-tag: Logger main definition -Copyright (C) 2004-2006 John Goerzen +Copyright (C) 2004-2009 John Goerzen This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -19,7 +19,7 @@ {- | Module : System.Log.Logger - Copyright : Copyright (C) 2004-2006 John Goerzen + Copyright : Copyright (C) 2004-2009 John Goerzen License : GNU LGPL, version 2.1 or above Maintainer : John Goerzen @@ -72,6 +72,16 @@ ancestors of the Logger/, regardless of whether those 'Logger's would normally have passed on the message. +Each 'Logger' can /optionally/ store a 'Priority'. If a given Logger does +not have a Priority, and you log a message to that logger, the system will +use the priority of the parent of the destination logger to find out whether +to log the message. If the parent has no priority associated with it, +the system continues walking up the tree to figure out a priority until +it hits the root logger. In this way, you can easily adjust the priority +of an entire subtree of loggers. When a new logger is created, it has no +priority by default. The exception is the root logger, which has a WARNING +priority by default. + To give you one extra little knob to turn, 'LogHandler's can also have importance levels ('Priority') associated with them in the same way that 'Logger's do. They act just like the 'Priority' value in the @@ -111,7 +121,7 @@ > -- Also, we'd like to still ignore things less than > -- WARNING in other areas. > -- -> -- So, we adjust the Logger for MyApp.Component. +> -- So, we adjust the Logger for MyApp.BuggyComponent. > > updateGlobalLogger "MyApp.BuggyComponent" > (setLevel DEBUG) @@ -148,7 +158,7 @@ special things to be aware of. First of all, whenever you first access a given logger by name, it -magically springs to life. It has a default 'Priority' of 'DEBUG' +magically springs to life. It has a default 'Priority' of Nothing and an empty handler list -- which means that it will inherit whatever its parents do. -} @@ -165,7 +175,7 @@ you'll need to use 'updateGlobalLogger' or 'saveGlobalLogger'. -} addHandler, setHandlers, - getLevel, setLevel, + getLevel, setLevel, clearLevel, -- ** Saving Your Changes {- | These functions commit changes you've made to loggers to the global logger hierarchy. -} @@ -189,11 +199,10 @@ --------------------------------------------------------------------------- data HandlerT = forall a. LogHandler a => HandlerT a -data Logger = Logger { level :: Priority, +data Logger = Logger { level :: Maybe Priority, handlers :: [HandlerT], name :: String} - type LogTree = Map.Map String Logger {- | This is the base class for the various log handlers. They should @@ -209,12 +218,6 @@ rootLoggerName :: String rootLoggerName = "" -{- | Placeholders created when a new logger must be created. This is used -only for the root logger default for now, as all others crawl up the tree -to find a sensible default. -} -placeholder :: Logger -placeholder = Logger {level = WARNING, handlers = [], name = ""} - --------------------------------------------------------------------------- -- Logger Tree Storage --------------------------------------------------------------------------- @@ -230,7 +233,7 @@ unsafePerformIO $ do h <- streamHandler stderr DEBUG newMVar (Map.singleton rootLoggerName (Logger - {level = WARNING, + {level = Just WARNING, name = "", handlers = [HandlerT h]})) @@ -340,16 +343,8 @@ if Map.member x lt then createLoggers xs lt else createLoggers xs - (Map.insert x ((modellogger lt) {name=x}) lt) - modellogger :: LogTree -> Logger - -- the modellogger is what we use for adding new loggers - modellogger lt = - findmodellogger lt (reverse $ componentsOfName lname) - findmodellogger _ [] = error "findmodellogger: root logger does not exist?!" - findmodellogger lt (x:xs) = - case Map.lookup x lt of - Nothing -> findmodellogger lt xs - Just logger -> logger {handlers = []} + (Map.insert x (defaultLogger {name=x}) lt) + defaultLogger = Logger Nothing [] undefined -- | Returns the root logger. @@ -363,27 +358,34 @@ -- | Handle a log request. handle :: Logger -> LogRecord -> IO () handle l (pri, msg) = - let parentHandlers [] = return [] - parentHandlers name = + let parentLoggers :: String -> IO [Logger] + parentLoggers [] = return [] + parentLoggers name = let pname = (head . drop 1 . reverse . componentsOfName) name - in - do - --putStrLn (join "," foo) - --putStrLn pname - --putStrLn "1" - parent <- getLogger pname - --putStrLn "2" - next <- parentHandlers pname - --putStrLn "3" - return ((handlers parent) ++ next) + in + do parent <- getLogger pname + next <- parentLoggers pname + return (parent : next) + parentHandlers :: String -> IO [HandlerT] + parentHandlers name = parentLoggers name >>= (return . concatMap handlers) + + -- Get the priority we should use. Find the first logger in the tree, + -- starting here, with a set priority. If even root doesn't have one, + -- assume DEBUG. + getLoggerPriority :: String -> IO Priority + getLoggerPriority name = + do pl <- parentLoggers name + case catMaybes . map level $ (l : pl) of + [] -> return DEBUG + (x:_) -> return x in - if pri >= (level l) - then do + do lp <- getLoggerPriority (name l) + if pri >= lp + then do ph <- parentHandlers (name l) sequence_ (handlerActions (ph ++ (handlers l)) (pri, msg) (name l)) - else return () - + else return () -- | Call a handler given a HandlerT. callHandler :: LogRecord -> String -> HandlerT -> IO () @@ -408,15 +410,21 @@ -- | Returns the "level" of the logger. Items beneath this -- level will be ignored. -getLevel :: Logger -> Priority +getLevel :: Logger -> Maybe Priority getLevel l = level l -- | Sets the "level" of the 'Logger'. Returns a new -- 'Logger' object with the new level. setLevel :: Priority -> Logger -> Logger -setLevel p l = l{level = p} +setLevel p l = l{level = Just p} +-- | Clears the "level" of the 'Logger'. It will now inherit the level of +-- | its parent. + +clearLevel :: Logger -> Logger +clearLevel l = l {level = Nothing} + -- | Updates the global record for the given logger to take into -- account any changes you may have made. @@ -454,6 +462,7 @@ let realdesc = case desc of "" -> "" x -> x ++ ": " + handler :: Control.Exception.SomeException -> IO a handler e = do logM logger priority (realdesc ++ (show e)) Control.Exception.throw e -- Re-raise it diff --git a/testsrc/Tests.hs b/testsrc/Tests.hs new file mode 100644 --- /dev/null +++ b/testsrc/Tests.hs @@ -0,0 +1,26 @@ +{- arch-tag: Tests main file +Copyright (C) 2004 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Tests(tests) where +import Test.HUnit + +test1 = TestCase ("x" @=? "x") + +tests = TestList [TestLabel "test1" test1] + + diff --git a/testsrc/runtests.hs b/testsrc/runtests.hs new file mode 100644 --- /dev/null +++ b/testsrc/runtests.hs @@ -0,0 +1,25 @@ +{- arch-tag: Test runner +Copyright (C) 2004 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Main where + +import Test.HUnit +import Tests + +main = runTestTT tests + diff --git a/winbuild.bat b/winbuild.bat new file mode 100644 --- /dev/null +++ b/winbuild.bat @@ -0,0 +1,4 @@ +ghc -package Cabal Setup.hs -o setup.exe +setup configure +setup build +