log.tcl

Linux下的MSN聊天程序源码

#	suppressed. Unique abbreviations of level names are allowed.
#
# Arguments:
#	level	The level to query.
#
# Side Effects:
#	None.
#
# Results:
#	None.

proc ::log::lvIsSuppressed {level} {
    variable suppressed
    set level [lv2longform $level]
    return $suppressed($level)
}

# log::lvCmd --
#
#	Defines for the specified level with which command to write
#	the messages having this level. Unique abbreviations of level
#	names are allowed. The command is actually a command prefix
#	and this facility will append 2 arguments before calling it,
#	the level of the message and the message itself, in this
#	order.
#
# Arguments:
#	level	The level the command prefix is for.
#	cmd	The command prefix to use for the specified level.
#
# Side Effects:
#	See above.
#
# Results:
#	None.

proc ::log::lvCmd {level cmd} {
    variable cmdMap
    set level [lv2longform $level]
    set cmdMap($level) $cmd
    return
}

# log::lvCmdForall --
#
#	Defines for all known levels with which command to write the
#	messages having this level. The command is actually a command
#	prefix and this facility will append 2 arguments before
#	calling it, the level of the message and the message itself,
#	in this order.
#
# Arguments:
#	cmd	The command prefix to use for all levels.
#
# Side Effects:
#	See above.
#
# Results:
#	None.

proc ::log::lvCmdForall {cmd} {
    variable cmdMap
    variable levels

    foreach l $levels {
	set cmdMap($l) $cmd
    }
    return
}

# log::lvChannel --
#
#	Defines for the specified level into which channel ::log::Puts
#	(the standard command) shall write the messages having this
#	level. Unique abbreviations of level names are allowed. The
#	command is actually a command prefix and this facility will
#	append 2 arguments before calling it, the level of the message
#	and the message itself, in this order.
#
# Arguments:
#	level	The level the channel is for.
#	chan	The channel to use for the specified level.
#
# Side Effects:
#	See above.
#
# Results:
#	None.

proc ::log::lvChannel {level chan} {
    variable channelMap
    set level [lv2longform $level]
    set channelMap($level) $chan
    return
}

# log::lvChannelForall --
#
#	Defines for all known levels with which which channel
#	::log::Puts (the standard command) shall write the messages
#	having this level. The command is actually a command prefix
#	and this facility will append 2 arguments before calling it,
#	the level of the message and the message itself, in this
#	order.
#
# Arguments:
#	chan	The channel to use for all levels.
#
# Side Effects:
#	See above.
#
# Results:
#	None.

proc ::log::lvChannelForall {chan} {
    variable channelMap
    variable levels

    foreach l $levels {
	set channelMap($l) $chan
    }
    return
}

# log::lvColor --
#
#	Defines for the specified level the color to return for it in
#	a call to ::log::lv2color. Unique abbreviations of level names
#	are allowed.
#
# Arguments:
#	level	The level the color is for.
#	color	The color to use for the specified level.
#
# Side Effects:
#	See above.
#
# Results:
#	None.

proc ::log::lvColor {level color} {
    variable colorMap
    set level [lv2longform $level]
    set colorMap($level) $color
    return
}

# log::lvColorForall --
#
#	Defines for all known levels the color to return for it in a
#	call to ::log::lv2color. Unique abbreviations of level names
#	are allowed.
#
# Arguments:
#	color	The color to use for all levels.
#
# Side Effects:
#	See above.
#
# Results:
#	None.

proc ::log::lvColorForall {color} {
    variable colorMap
    variable levels

    foreach l $levels {
	set colorMap($l) $color
    }
    return
}

# log::logarray --
#
#	Similar to parray, except that the contents of the array
#	printed out through the log system instead of directly
#	to stdout.
#
#	See also 'log::log' for a general explanation
#
# Arguments:
#	level		The level of the message.
#	arrayvar	The name of the array varaibe to dump
#	pattern		Optional pattern to restrict the dump
#			to certain elements in the array.
#
# Side Effects:
#	See above.
#
# Results:
#	None.

proc ::log::logarray {level arrayvar {pattern *}} {
    variable cmdMap

    if {[lvIsSuppressed $level]} {
	# Ignore messages for suppressed levels.
	return
    }

    set level [lv2longform $level]

    set cmd $cmdMap($level)
    if {$cmd == {}} {
	# Ignore messages for levels without a command
	return
    }

    upvar 1 $arrayvar array
    if {![array exists array]} {
        error "\"$arrayvar\" isn't an array"
    }
    set maxl 0
    foreach name [lsort [array names array $pattern]] {
        if {[string length $name] > $maxl} {
            set maxl [string length $name]
        }
    }
    set maxl [expr {$maxl + [string length $arrayvar] + 2}]
    foreach name [lsort [array names array $pattern]] {
        set nameString [format %s(%s) $arrayvar $name]

	eval [linsert $cmd end $level \
		[format "%-*s = %s" $maxl $nameString $array($name)]]
    }
    return
}

# log::loghex --
#
#	Like 'log::log', except that the logged data is assumed to
#	be binary and is logged as a block of hex numbers.
#
#	See also 'log::log' for a general explanation
#
# Arguments:
#	level	The level of the message.
#	text	Message printed before the hex block
#	data	Binary data to show as hex.
#
# Side Effects:
#	See above.
#
# Results:
#	None.

proc ::log::loghex {level text data} {
    variable cmdMap

    if {[lvIsSuppressed $level]} {
	# Ignore messages for suppressed levels.
	return
    }

    set level [lv2longform $level]

    set cmd $cmdMap($level)
    if {$cmd == {}} {
	# Ignore messages for levels without a command
	return
    }

    # Format the messages and print them.

    set len [string length $data]

    eval [linsert $cmd end $level "$text ($len bytes):"]

    set address ""
    set hexnums ""
    set ascii   ""

    for {set i 0} {$i < $len} {incr i} {
        set v [string index $data $i]
        binary scan $v H2 hex
        binary scan $v c  num
        set num [expr {($num + 0x100) % 0x100}]

        set text .
        if {$num > 31} {set text $v} 

        if {($i % 16) == 0} {
            if {$address != ""} {
                eval [linsert $cmd end $level [format "%4s  %-48s  |%s|" $address $hexnums $ascii]]
                set address ""
                set hexnums ""
                set ascii   ""
            }
            append address [format "%04d" $i]
        }
        append hexnums "$hex "
        append ascii   $text
    }
    if {$address != ""} {
	eval [linsert $cmd end $level [format "%4s  %-48s  |%s|" $address $hexnums $ascii]]
    }
    eval [linsert $cmd end $level ""]
    return
}

# log::log --
#
#	Log a message according to the specifications for commands,
#	channels and suppression. In other words: The command will do
#	nothing if the specified level is suppressed. If it is not
#	suppressed the actual logging is delegated to the specified
#	command. If there is no command specified for the level the
#	message won't be logged. The standard command ::log::Puts will
#	write the message to the channel specified for the given
#	level. If no channel is specified for the level the message
#	won't be logged. Unique abbreviations of level names are
#	allowed. Errors in the actual logging command are *not*
#	catched, but propagated to the caller, as they may indicate
#	misconfigurations of the log facility or errors in the callers
#	code itself.
#
# Arguments:
#	level	The level of the message.
#	text	The message to log.
#
# Side Effects:
#	See above.
#
# Results:
#	None.

proc ::log::log {level text} {
    variable cmdMap

    if {[lvIsSuppressed $level]} {
	# Ignore messages for suppressed levels.
	return
    }

    set level [lv2longform $level]

    set cmd $cmdMap($level)
    if {$cmd == {}} {
	# Ignore messages for levels without a command
	return
    }

    # Delegate actual logging to the command.
    # Handle multi-line messages correctly.

    foreach line [split $text \n] {
	eval [linsert $cmd end $level $line]
    }
    return
}

# log::logMsg --
#
#	Convenience wrapper around ::log::log. Equivalent to
#	'::log::log info text'.
#
# Arguments:
#	text	The message to log.
#
# Side Effects:
#	See ::log::log.
#
# Results:
#	None.

proc ::log::logMsg {text} {
    log info $text
}

# log::logError --
#
#	Convenience wrapper around ::log::log. Equivalent to
#	'::log::log error text'.
#
# Arguments:
#	text	The message to log.
#
# Side Effects:
#	See ::log::log.
#
# Results:
#	None.

proc ::log::logError {text} {
    log error $text
}


# log::Puts --
#
#	Standard log command, writing messages and levels to
#	user-specified channels. Assumes that the supression checks
#	were done by the caller. Expects full level names,
#	abbreviations are *not allowed*.
#
# Arguments:
#	level	The level of the message. 
#	text	The message to log.
#
# Side Effects:
#	Writes into channels.
#
# Results:
#	None.

proc ::log::Puts {level text} {
    variable channelMap
    variable fill

    set chan $channelMap($level)
    if {$chan == {}} {
	# Ignore levels without channel.
	return
    }

    puts $chan "$level$fill($level) $text"
    return
}

# ### ### ### ######### ######### #########
## Initialization code. Disable logging for the lower levels by
## default.

## log::lvSuppressLE emergency
log::lvSuppressLE warning