log.tcl

Linux下的MSN聊天程序源码

# log.tcl --
#
#	Tcl implementation of a general logging facility
#	(Reaped from Pool_Base and modified to fit into tcllib)
#
# Copyright (c) 2001 by ActiveState Tool Corp.
# See the file license.terms.

package require Tcl 8
package provide log 1.2

# ### ### ### ######### ######### #########

namespace eval ::log {
    namespace export levels lv2longform lv2color lv2priority 
    namespace export lv2cmd lv2channel lvCompare
    namespace export lvSuppress lvSuppressLE lvIsSuppressed
    namespace export lvCmd lvCmdForall
    namespace export lvChannel lvChannelForall lvColor lvColorForall
    namespace export log logMsg logError

    # The known log-levels.

    variable levels [list \
	    emergency \
	    alert \
	    critical \
	    error \
	    warning \
	    notice \
	    info \
	    debug]

    # Array mapping from all unique prefixes for log levels to their
    # corresponding long form.

    # *future* Use a procedure from 'textutil' to calculate the
    #          prefixes and to fill the map.

    variable  levelMap
    array set levelMap {
	a		alert
	al		alert
	ale		alert
	aler		alert
	alert		alert
	c		critical
	cr		critical
	cri		critical
	crit		critical
	criti		critical
	critic		critical
	critica		critical
	critical	critical
	d		debug
	de		debug
	deb		debug
	debu		debug
	debug		debug
	em		emergency
	eme		emergency
	emer		emergency
	emerg		emergency
	emerge		emergency
	emergen		emergency
	emergenc	emergency
	emergency	emergency
	er		error
	err		error
	erro		error
	error		error
	i		info
	in		info
	inf		info
	info		info
	n		notice
	no		notice
	not		notice
	noti		notice
	notic		notice
	notice		notice
	w		warning
	wa		warning
	war		warning
	warn		warning
	warni		warning
	warnin		warning
	warning		warning
    }

    # Map from log-levels to the commands to execute when a message
    # with that level arrives in the system. The standard command for
    # all levels is '::log::Puts' which writes the message to either
    # stdout or stderr, depending on the level. The decision about the
    # channel is stored in another map and modifiable by the user of
    # the package.

    variable  cmdMap
    array set cmdMap {}

    variable lv
    foreach  lv $levels {set cmdMap($lv) ::log::Puts}
    unset    lv

    # Map from log-levels to the channels ::log::Puts shall write
    # messages with that level to. The map can be queried and changed
    # by the user.

    variable  channelMap
    array set channelMap {
	emergency  stderr
	alert      stderr
	critical   stderr
	error      stderr
	warning    stdout
	notice     stdout
	info       stdout
	debug      stdout
    }

    # Graphical user interfaces may want to colorize messages based
    # upon their level. The following array stores a map from levels
    # to colors. The map can be queried and changed by the user.

    variable  colorMap
    array set colorMap {
	emergency red
	alert     red
	critical  red
	error     red
	warning   yellow
	notice    seagreen
	info      {}
	debug     lightsteelblue
    }

    # To allow an easy comparison of the relative importance of a
    # level the following array maps from levels to a numerical
    # priority. The higher the number the more important the
    # level. The user cannot change this map (for now). This package
    # uses the priorities to allow the user to supress messages based
    # upon their levels.

    variable  priorityMap
    array set priorityMap {
	emergency 7
	alert     6
	critical  5
	error     4
	warning   3
	notice    2
	info      1
	debug     0
    }

    # The following array is internal and holds the information about
    # which levels are suppressed, i.e. may not be written.
    #
    # 0 - messages with with level are written out.
    # 1 - messages with this level are suppressed.

    variable  suppressed
    array set suppressed {
	emergency 0
	alert     0
	critical  0
	error     0
	warning   0
	notice    0
	info      0
	debug     0
    }

    # Internal static information. Map from levels to a string of
    # spaces. The number of spaces in each string is just enough to
    # make all level names together with their string of the same
    # length.

    variable  fill
    array set fill {
	emergency ""	alert "    "	critical " "	error "    "
	warning "  "	notice "   "	info "     "	debug "    "
    }
}


# log::levels --
#
#	Retrieves the names of all known levels.
#
# Arguments:
#	None.
#
# Side Effects:
#	None.
#
# Results:
#	A list containing the names of all known levels,
#	alphabetically sorted.

proc ::log::levels {} {
    variable levels
    return [lsort $levels]
}

# log::lv2longform --
#
#	Converts any unique abbreviation of a level name to the full
#	level name.
#
# Arguments:
#	level	The prefix of a level name to convert.
#
# Side Effects:
#	None.
#
# Results:
#	Returns the full name to the specified abbreviation or an
#	error.

proc ::log::lv2longform {level} {
    variable levelMap

    if {[info exists levelMap($level)]} {
	return $levelMap($level)
    }

    return -code error "\"$level\" is no unique abbreviation of a level name"
}

# log::lv2color --
#
#	Converts any level name including unique abbreviations to the
#	corresponding color.
#
# Arguments:
#	level	The level to convert into a color.
#
# Side Effects:
#	None.
#
# Results:
#	The name of a color or an error.

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

# log::lv2priority --
#
#	Converts any level name including unique abbreviations to the
#	corresponding priority.
#
# Arguments:
#	level	The level to convert into a priority.
#
# Side Effects:
#	None.
#
# Results:
#	The numerical priority of the level or an error.

proc ::log::lv2priority {level} {
    variable priorityMap
    set level [lv2longform $level]
    return $priorityMap($level)
}

# log::lv2cmd --
#
#	Converts any level name including unique abbreviations to the
#	command prefix used to write messages with that level.
#
# Arguments:
#	level	The level to convert into a command prefix.
#
# Side Effects:
#	None.
#
# Results:
#	A string containing a command prefix or an error.

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

# log::lv2channel --
#
#	Converts any level name including unique abbreviations to the
#	channel used by ::log::Puts to write messages with that level.
#
# Arguments:
#	level	The level to convert into a channel.
#
# Side Effects:
#	None.
#
# Results:
#	A string containing a channel handle or an error.

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

# log::lvCompare --
#
#	Compares two levels (including unique abbreviations) with
#	respect to their priority. This command can be used by the
#	-command option of lsort.
#
# Arguments:
#	level1	The first of the levels to compare.
#	level2	The second of the levels to compare.
#
# Side Effects:
#	None.
#
# Results:
#	One of -1, 0 or 1 or an error. A result of -1 signals that
#	level1 is of less priority than level2. 0 signals that both
#	levels have the same priority. 1 signals that level1 has
#	higher priority than level2.

proc ::log::lvCompare {level1 level2} {
    variable priorityMap

    set level1 $priorityMap([lv2longform $level1])
    set level2 $priorityMap([lv2longform $level2])

    if {$level1 < $level2} {
	return -1
    } elseif {$level1 > $level2} {
	return 1
    } else {
	return 0
    }
}

# log::lvSuppress --
#
#	(Un)suppresses the output of messages having the specified
#	level. Unique abbreviations for the level are allowed here
#	too.
#
# Arguments:
#	level		The name of the level to suppress or
#			unsuppress. Unique abbreviations are allowed
#			too.
#	suppress	Boolean flag. Optional. Defaults to the value
#			1, which means to suppress the level. The
#			value 0 on the other hand unsuppresses the
#			level.
#
# Side Effects:
#	See above.
#
# Results:
#	None.

proc ::log::lvSuppress {level {suppress 1}} {
    variable suppressed
    set level [lv2longform $level]

    switch -exact -- $suppress {
	0 - 1 {} default {
	    return -code error "\"$suppress\" is not a member of \{0, 1\}"
	}
    }

    set suppressed($level) $suppress
    return
}

# log::lvSuppressLE --
#
#	(Un)suppresses the output of messages having the specified
#	level or one of lesser priority. Unique abbreviations for the
#	level are allowed here too.
#
# Arguments:
#	level		The name of the level to suppress or
#			unsuppress. Unique abbreviations are allowed
#			too.
#	suppress	Boolean flag. Optional. Defaults to the value
#			1, which means to suppress the specified
#			levels. The value 0 on the other hand
#			unsuppresses the levels.
#
# Side Effects:
#	See above.
#
# Results:
#	None.

proc ::log::lvSuppressLE {level {suppress 1}} {
    variable suppressed
    variable levels
    variable priorityMap

    set level [lv2longform $level]

    switch -exact -- $suppress {
	0 - 1 {} default {
	    return -code error "\"$suppress\" is not a member of \{0, 1\}"
	}
    }

    set prio  [lv2priority $level]

    foreach l $levels {
	if {$priorityMap($l) <= $prio} {
	    set suppressed($l) $suppress
	}
    }
    return
}

# log::lvIsSuppressed --
#
#	Asks the package wether the specified level is currently