logger.tcl

Linux下的MSN聊天程序源码

# logger.tcl --
#
#   Tcl implementation of a general logging facility.
#
# Copyright (c) 2003 by David N. Welton <[e-mail]>
# Copyright (c) 2004,2005 by Michael Schlenker <[e-mail]>
#
# See the file license.terms.

# The logger package provides an 'object oriented' log facility that
# lets you have trees of services, that inherit from one another.
# This is accomplished through the use of Tcl namespaces.


package require Tcl 8.2
package provide logger 0.6.1

namespace eval ::logger {
    namespace eval tree {}
    namespace export init enable disable services servicecmd import

    # The active services.
    variable services {}

    # The log 'levels'.
    variable levels [list debug info notice warn error critical]
}

# ::logger::_nsExists --
#
#   Workaround for missing namespace exists in Tcl 8.2 and 8.3.
#

if {[package vcompare [package provide Tcl] 8.4] < 0} {
    proc ::logger::_nsExists {ns} {
        expr {![catch {namespace parent $ns}]}
    }
} else {
    proc ::logger::_nsExists {ns} {
        namespace exists $ns
    }
}

# ::logger::_cmdPrefixExists --
#
# Utility function to check if a given callback prefix exists,
# this should catch all oddities in prefix names, including spaces, 
# glob patterns, non normalized namespaces etc.
#
# Arguments:
#   prefix - The command prefix to check
#   
# Results:
#   1 or 0 for yes or no
#
proc ::logger::_cmdPrefixExists {prefix} {
    set cmd [lindex $prefix 0]
    set full [namespace eval :: namespace which [list $cmd]]
    if {[string equal $full ""]} {return 0} else {return 1}
    # normalize namespaces
    set ns [namespace qualifiers $cmd]
    set cmd ${ns}::[namespace tail $cmd]
    set matches [::info command ${ns}::*]
    if {[lsearch -exact $matches $cmd] != -1} {return 1}
    return 0
}

# ::logger::walk --
#
#   Walk namespaces, starting in 'start', and evaluate 'code' in
#   them.
#
# Arguments:
#   start - namespace to start in.
#   code - code to execute in namespaces walked.
#
# Side Effects:
#   Side effects of code executed.
#
# Results:
#   None.

proc ::logger::walk { start code } {
    set children [namespace children $start]
    foreach c $children {
    logger::walk $c $code
    namespace eval $c $code
    }
}

proc ::logger::init {service} {
    variable levels
    variable services
        
    # We create a 'tree' namespace to house all the services, so
    # they are in a 'safe' namespace sandbox, and won't overwrite
    # any commands.
    namespace eval tree::${service} {
        variable service
        variable levels
        variable oldname 
    }

    lappend services $service

    set [namespace current]::tree::${service}::service $service
    set [namespace current]::tree::${service}::levels $levels
    set [namespace current]::tree::${service}::oldname $service
    
    namespace eval tree::${service} {
    # Defaults to 'debug' level - show everything.  I don't
    # want people to wonder where there debug messages are
    # going.  They can turn it off themselves.
    variable enabled "debug"

    # Callback to use when the service in question is shut down.
    variable delcallback [namespace current]::no-op

    # Callback when the loglevel is changed
    variable levelchangecallback [namespace current]::no-op
    
    # State variable to decide when to call levelcallback
    variable inSetLevel 0
    
    # The currently configured levelcommands
    variable lvlcmds 
    array set lvlcmds {}
    # We use this to disable a service completely.  In Tcl 8.4
    # or greater, by using this, disabled log calls are a
    # no-op!

    proc no-op args {}


    proc stdoutcmd {level text} {
        variable service
        puts "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'"
    }

    proc stderrcmd {level text} {
        variable service
        puts stderr "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'"
    }


    # setlevel --
    #
    #   This command differs from enable and disable in that
    #   it disables all the levels below that selected, and
    #   then enables all levels above it, which enable/disable
    #   do not do.
    #
    # Arguments:
    #   lv - the level, as defined in $levels.
    #
    # Side Effects:
    #   Runs disable for the level, and then enable, in order
    #   to ensure that all levels are set correctly.
    #
    # Results:
    #   None.


    proc setlevel {lv} {
        variable inSetLevel 1
        set oldlvl [currentloglevel]
        
        # do not allow enable and disable to do recursion
        if {[catch {
            disable $lv 0
            set newlvl [enable $lv 0]
        } msg] == 1} {
            return -code error -errorcode $::errorCode $msg
        }
        # do the recursion here
        logger::walk [namespace current] [list setlevel $lv]
        
        set inSetLevel 0
        lvlchangewrapper $oldlvl $newlvl
        return
    }

    # enable --
    #
    #   Enable a particular 'level', and above, for the
    #   service, and its 'children'.
    #
    # Arguments:
    #   lv - the level, as defined in $levels.
    #
    # Side Effects:
    #   Enables logging for the particular level, and all
    #   above it (those more important).  It also walks
    #   through all services that are 'children' and enables
    #   them at the same level or above.
    #
    # Results:
    #   None.

    proc enable {lv {recursion 1}} {
        variable levels
        set lvnum [lsearch -exact $levels $lv]
        if { $lvnum == -1 } {
        return -code error "Invalid level '$lv' - levels are $levels"
        }

        variable enabled
        set newlevel $enabled
        set elnum [lsearch -exact $levels $enabled]
        if {($elnum == -1) || ($elnum > $lvnum)} {
            set newlevel $lv
        }
                
        variable service
        while { $lvnum <  [llength $levels] } {
        interp alias {} [namespace current]::[lindex $levels $lvnum] \
            {} [namespace current]::[lindex $levels $lvnum]cmd
        incr lvnum
        }
        
        if {$recursion} {
            logger::walk [namespace current] [list enable $lv]
        }
        lvlchangewrapper $enabled $newlevel
        set enabled $newlevel
    }

    # disable --
    #
    #   Disable a particular 'level', and below, for the
    #   service, and its 'children'.
    #
    # Arguments:
    #   lv - the level, as defined in $levels.
    #
    # Side Effects:
    #   Disables logging for the particular level, and all
    #   below it (those less important).  It also walks
    #   through all services that are 'children' and disables
    #   them at the same level or below.
    #
    # Results:
    #   None.

    proc disable {lv {recursion 1}} {
        variable levels
        set lvnum [lsearch -exact $levels $lv]
        if { $lvnum == -1 } {
        return -code error "Invalid level '$lv' - levels are $levels"
        }

        variable enabled
        set newlevel $enabled
        set elnum [lsearch -exact $levels $enabled]
        if {($elnum > -1) && ($elnum <= $lvnum)} {
            if {$lvnum+1 >= [llength $levels]} {
                set newlevel "none"
            } else {
                set newlevel [lindex $levels [expr {$lvnum+1}]]
            }
        }
        
        while { $lvnum >= 0 } {
        
        interp alias {} [namespace current]::[lindex $levels $lvnum] {} \
            [namespace current]::no-op
        incr lvnum -1
        }
        if {$recursion} {
            logger::walk [namespace current] [list disable $lv]
        }
        lvlchangewrapper $enabled $newlevel
        set enabled $newlevel
    }

    # currentloglevel --
    #
    #   Get the currently enabled log level for this service.
    #
    # Arguments:
    #   none
    #
    # Side Effects:
    #   none
    #
    # Results:
    #   current log level
    #

    proc currentloglevel {} {
        variable enabled
        return $enabled
    }

    # lvlchangeproc --
    #
    #   Set or introspect a callback for when the logger instance 
    #   changes its loglevel.
    #
    # Arguments:
    #   cmd - the Tcl command to call, it is called with two parameters, old and new log level.
    #   or none for introspection
    #
    # Side Effects:
    #   None.
    #
    # Results:
    #   If no arguments are given return the current callback cmd.

    proc lvlchangeproc {args} {
        variable levelchangecallback
        
        switch -exact -- [llength [::info level 0]] {
                1   {return $levelchangecallback}
                2   {
                     if {[::logger::_cmdPrefixExists [lindex $args 0]]} {
                        set levelchangecallback [lindex $args 0]
                     } else {
                        return -code error "Invalid cmd '[lindex $args 0]' - does not exist"
                     }    
                    }
                default {
                    return -code error "Wrong # of arguments. Usage: \${log}::lvlchangeproc ?cmd?"
                }
        }
    }

    proc lvlchangewrapper {old new} {
        variable inSetLevel
        
        # we are called after disable and enable are finished 
        if {$inSetLevel} {return}
        
        # no action if level does not change
        if {[string equal $old $new]} {return}
        
        variable levelchangecallback
        # no action if levelchangecallback isn't a valid command
        if {[::logger::_cmdPrefixExists $levelchangecallback]} {
        catch {
            uplevel \#0 [linsert $levelchangecallback end $old $new]
        }
        }
    }
    
    # logproc --
    #
    #   Command used to create a procedure that is executed to
    #   perform the logging.  This could write to disk, out to
    #   the network, or something else.
    #   If two arguments are given, use an existing command.
    #   If three arguments are given, create a proc.
    #
    # Arguments:
    #   lv - the level to log, which must be one of $levels.
    #   args - either zero, one or two arguments.
    #          if zero this returns the current command registered 
    #          if one, this is a cmd name that is called for this level
    #          if two, these are an argument and proc body
    #
    # Side Effects:
    #   Creates a logging command to take care of the details
    #   of logging an event.
    #
    # Results:
    #   If called with zero length args, returns the name of the currently
    #   configured logging procedure.
    #   
    #

    proc logproc {lv args} {
        variable levels
        variable lvlcmds
        
        set lvnum [lsearch -exact $levels $lv]
        if { $lvnum == -1 } {
        return -code error "Invalid level '$lv' - levels are $levels"
        }
        switch -exact -- [llength $args] {
        0  {
            return $lvlcmds($lv)
           }
        1  {
            set cmd [lindex $args 0]
            if {[string equal "[namespace current]::${lv}cmd" $cmd]} {return} 
            if {[llength [::info commands $cmd]]} {
                proc ${lv}cmd {args} "uplevel 1 \[list $cmd \[lindex \$args end\]\]"
            } else {
                return -code error "Invalid cmd '$cmd' - does not exist"
            }