logger.tcl

Linux下的MSN聊天程序源码

            set lvlcmds($lv) $cmd
        }
        2  {
            foreach {arg body} $args {break}
            proc ${lv}cmd {args} "_setservicename \$args; 
                                      set val \[${lv}customcmd \[lindex \$args end\]\] ; 
                                      _restoreservice; set val"
            proc ${lv}customcmd $arg $body
            set lvlcmds($lv) [namespace current]::${lv}customcmd
        }
        default {
            return -code error "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body"
        }
        }
    }


    # delproc --
    #
    #   Set or introspect a callback for when the logger instance 
    #   is deleted.
    #
    # Arguments:
    #   cmd - the Tcl command to call.
    #   or none for introspection
    #
    # Side Effects:
    #   None.
    #
    # Results:
    #   If no arguments are given return the current callback cmd.

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


    # delete --
    #
    #   Delete the namespace and its children.

    proc delete {} {
        variable delcallback
        variable service
        
        logger::walk [namespace current] delete
        if {[::logger::_cmdPrefixExists $delcallback]} {
             uplevel \#0 [lrange $delcallback 0 end]  
        } 
        # clean up the global services list
        set idx [lsearch -exact [logger::services] $service]
        if {$idx !=-1} {
            set ::logger::services [lreplace [logger::services] $idx $idx]
        }
        
        namespace delete [namespace current]
        
    }

    # services --
    #
    #   Return all child services 
    
    proc services {} {
        variable service
        
        set children [list]
        foreach srv [logger::services] {
            if {[string match "${service}::*" $srv]} {
                lappend children $srv
            }
        }
        return $children
    }

    # servicename --
    #
    #   Return the name of the service
    
    proc servicename {} {
        variable service
        return $service
    }
    
    proc _setservicename {arg} {
        variable service
        variable oldname
        if {[llength $arg] <= 1} {
            return
        } else {
            set oldname $service
            set service [lindex $arg end-1]
        }
    }
        
    proc _restoreservice {} {
        variable service
        variable oldname
        set service $oldname
        return
    }
    
    # Walk the parent service namespaces to see first, if they
    # exist, and if any are enabled, and then, as a
    # consequence, enable this one
    # too.

    enable $enabled
    variable parent [namespace parent]
    while {[string compare $parent "::logger::tree"]} {
        # If the 'enabled' variable doesn't exist, create the
        # whole thing.
        if { ! [::info exists ${parent}::enabled] } {
        
        logger::init [string range $parent 16 end]
        }
        set enabled [set ${parent}::enabled]
        enable $enabled
        set parent [namespace parent $parent]
    }
    }

    # Now create the commands for different levels.

    namespace eval tree::${service} {
    set parent [namespace parent]

    # We 'inherit' the commands from the parents.  This
    # means that, if you want to share the same methods with
    # children, they should be instantiated after the parent's
    # methods have been defined.
    if {[string compare $parent "::logger::tree"]} {
        foreach lvl [::logger::levels] {
            # OPTIMIZE: do not allow multiple aliases in the hierarchy
            #           they can always be replaced by more efficient
            #           direct aliases to the target procs.
            interp alias {} [namespace current]::${lvl}cmd {} ${parent}::${lvl}cmd $service
        }
        # inherit the starting loglevel of the parent service
        setlevel [${parent}::currentloglevel]

    } else {
        foreach lvl [::logger::levels] {
            proc ${lvl}cmd {args} "_setservicename \$args ; 
                                   set val \[stdoutcmd $lvl \[lindex \$args end\]\] ; 
                                   _restoreservice; set val"
            set lvlcmds($lvl) [namespace current]::${lvl}cmd
        }
    }
    }
    
    
    return ::logger::tree::${service}
}

# ::logger::services --
#
#   Returns a list of all active services.
#
# Arguments:
#   None.
#
# Side Effects:
#   None.
#
# Results:
#   List of active services.

proc ::logger::services {} {
    variable services
    return $services
}

# ::logger::enable --
#
#   Global enable for a certain level.  NOTE - this implementation
#   isn't terribly effective at the moment, because it might hit
#   children before their parents, who will then walk down the
#   tree attempting to disable the children again.
#
# Arguments:
#   lv - level above which to enable logging.
#
# Side Effects:
#   Enables logging in a given level, and all higher levels.
#
# Results:
#   None.

proc ::logger::enable {lv} {
    variable services
    if {[catch {
        foreach sv $services {
        ::logger::tree::${sv}::enable $lv
        }
    } msg] == 1} {
        return -code error -errorcode $::errorCode $msg
    }
}

proc ::logger::disable {lv} {
    variable services
    if {[catch {
        foreach sv $services {
        ::logger::tree::${sv}::disable $lv
        }
    } msg] == 1} {
        return -code error -errorcode $::errorCode $msg
    }
}

proc ::logger::setlevel {lv} {
    variable services
    if {[catch {
        foreach sv $services {
        ::logger::tree::${sv}::setlevel $lv
        }
    } msg] == 1} {
        return -code error -errorcode $::errorCode $msg
    }
}

# ::logger::levels --
#
#   Introspect the available log levels.  Provided so a caller does
#   not need to know implementation details or code the list
#   himself.
#
# Arguments:
#   None.
#
# Side Effects:
#   None.
#
# Results:
#   levels - The list of valid log levels accepted by enable and disable

proc ::logger::levels {} {
    variable levels
    return $levels
}

# ::logger::servicecmd --
#
#   Get the command token for a given service name.
#
# Arguments:
#   service - name of the service.
#
# Side Effects:
#   none
#
# Results:
#   log - namespace token for this service

proc ::logger::servicecmd {service} {
    variable services
    if {[lsearch -exact $services $service] == -1} {
        return -code error "Service \"$service\" does not exist."
    }
    return "::logger::tree::${service}"
}

# ::logger::import --
#
#   Import the logging commands.
#
# Arguments:
#   service - name of the service.
#
# Side Effects:
#   creates aliases in the target namespace
#
# Results:
#   none

proc ::logger::import {args} {
    variable services
    
    if {[llength $args] == 0 || [llength $args] > 7} {
    return -code error "Wrong # of arguments: \"logger::import ?-all?\
                        ?-force?\
                        ?-prefix prefix? ?-namespace namespace? service\""
    }
    
    # process options
    #
    set import_all 0
    set force 0
    set prefix ""
    set ns [uplevel 1 namespace current]
    while {[llength $args] > 1} {
        set opt [lindex $args 0]
        set args [lrange $args 1 end]
        switch  -exact -- $opt {
            -all    { set import_all 1}
            -prefix { set prefix [lindex $args 0]
                      set args [lrange $args 1 end]        
                    }
            -namespace {
                      set ns [lindex $args 0]
                      set args [lrange $args 1 end]
            }
            -force {
                     set force 1
            }
            default {
                return -code error "Unknown argument: \"$opt\" :\nUsage:\
                \"logger::import ?-all? ?-force?\
                        ?-prefix prefix? ?-namespace namespace? service\""
            }
        }
    }
    
    #
    # build the list of commands to import
    #
    
    set cmds [logger::levels]
    if {$import_all} {
        lappend cmds setlevel enable disable logproc delproc services 
        lappend cmds servicename currentloglevel delete
    }
    
    #
    # check the service argument
    #
    
    set service [lindex $args 0]
    if {[lsearch -exact $services $service] == -1} {
            return -code error "Service \"$service\" does not exist."
    }

    #
    # setup the namespace for the import
    #

    set sourcens [logger::servicecmd $service]     
    set localns  [uplevel 1 namespace current]
    
    if {[string match ::* $ns]} {
        set importns $ns
    } else {
        set importns ${localns}::$ns
    }    

    # fake namespace exists for Tcl 8.2 - 8.3
    if {![_nsExists $importns]} {
        namespace eval $importns {}
    } 

    
    #
    # prepare the import
    #
    
    set imports ""
    foreach cmd $cmds {
        set cmdname ${importns}::${prefix}$cmd
        set collision [llength [info commands $cmdname]]
        if {$collision && !$force} {
            return -code error "can't import command \"$cmdname\": already exists"
        }
        lappend imports ${importns}::${prefix}$cmd ${sourcens}::${cmd}
    }
    
    #
    # and execute the aliasing after checking all is well
    #
    
    foreach {target source} $imports {
        proc $target {args} "uplevel 1 \[linsert \$args 0 $source \]"
    }
}