Attachment "log.diff" to
ticket [410198ffff]
added by
andreas_kupries
2001-03-21 07:31:20.
? .aku
? log.diff.2
? ChangeLog.orig.0
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/ChangeLog,v
retrieving revision 1.49
diff -u -r1.49 ChangeLog
--- ChangeLog 2000/11/03 06:43:41 1.49
+++ ChangeLog 2001/03/21 00:15:03
@@ -1,3 +1,30 @@
+2001-03-21 Andreas Kupries <[email protected]>
+
+ * Makefile.in: Added module 'log'.
+
+2001-03-20 Andreas Kupries <[email protected]>
+
+ * all.tcl: [Bug #410100, Patch #410105]
+ Squashed a subtle bug with package management for the
+ tests. Changes: all.tcl now adds the module path to the
+ auto_path (the tested modules did it themselves before) and also
+ moved the setting of the auto_path in the slave before the first
+ 'package require'. Why ? Assume the old code, an installed
+ fileutil 1.0 and a new fileutil 1.1 under development. The
+ initialization of the tests scans the package directories and
+ finds fileutil 1.0. The module then adds itself to the auto_path
+ and then requires fileutil (without version). Now fileutil 1.0
+ is found by the pkg management, it is acceptable according to
+ the rules of require and thus used. The new version is not
+ considered at all, as changing the auto_path does *not* enforce
+ a rescan of package directories. It is possible to solve the
+ problem by having the modules require themselves and request a
+ specific version (1.1 in this case). But this would mean that in
+ each module we have (at least) one more file containing the
+ version number (all test files!) and we have to maintain this
+ for every module. The change here however solves the problem
+ without touching the modules at all.
+
2000-11-02 Brent Welch <[email protected]>
* configure.in: Bumped version number to 0.8
Index: Makefile.in
===================================================================
RCS file: /cvsroot/tcllib/tcllib/Makefile.in,v
retrieving revision 1.40
diff -u -r1.40 Makefile.in
--- Makefile.in 2000/11/02 19:26:55 1.40
+++ Makefile.in 2001/03/21 00:15:05
@@ -7,6 +7,7 @@
# replaced in the actual Makefile.
#
# Copyright (c) 1999-2000 Ajuba Solutions
+# Copyright (c) 2001 ActiveState Tool Corp.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -66,6 +67,9 @@
# Counters and statistics
COUNTER=counter
+# Logging facility
+LOGGER=log
+
MODULES= \
$(BASE64) \
$(CMDLINE) \
@@ -83,7 +87,8 @@
$(POP3) \
$(PROFILER) \
$(TEXTUTIL) \
- $(URI)
+ $(URI) \
+ $(LOGGER)
#========================================================================
# Nothing of the variables below this line need to be changed. Please
Index: modules/log/ChangeLog
===================================================================
RCS file: ChangeLog
diff -N ChangeLog
--- /dev/null Mon Dec 11 17:26:27 2000
+++ ChangeLog Tue Mar 20 16:15:07 2001
@@ -0,0 +1,3 @@
+2001-03-20 Andreas Kupries <[email protected]>
+
+ * New module 'log', a logging facility.
Index: modules/log/log.n
===================================================================
RCS file: log.n
diff -N log.n
Index: modules/log/log.tcl
===================================================================
RCS file: log.tcl
diff -N log.tcl
--- /dev/null Mon Dec 11 17:26:27 2000
+++ log.tcl Tue Mar 20 16:15:09 2001
@@ -0,0 +1,705 @@
+# 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 provide log 1.0
+
+namespace eval ::log {
+ namespace export *
+
+ # 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
+# 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::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
+
+ lappend cmd $level $text
+ eval $cmd
+ 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 a supression checks were
+# done by the caller. Expects full level names, *no* abbreviations.
+#
+# 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
+}
Index: modules/log/log.test
===================================================================
RCS file: log.test
diff -N log.test
--- /dev/null Mon Dec 11 17:26:27 2000
+++ log.test Tue Mar 20 16:15:09 2001
@@ -0,0 +1,355 @@
+# -*- tcl -*-
+# Tests for the log facility
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# All rights reserved.
+#
+# RCS: @(#) $Id: fileutil.test,v 1.3 2000/05/31 00:00:00 ericm Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import ::tcltest::*
+}
+
+if { [lsearch $auto_path [file dirname [info script]]] == -1 } {
+ set auto_path [linsert $auto_path 0 [file dirname [info script]]]
+}
+
+package require log
+puts "log [package present log]"
+
+test log-1.0 {levels} {
+ ::log::levels
+} {alert critical debug emergency error info notice warning}
+
+foreach {abbrev long} {
+ a alert d debug
+ al alert de debug
+ ale alert deb debug
+ aler alert debu debug
+ alert alert debug debug
+ c critical em emergency
+ cr critical eme emergency
+ cri critical emer emergency
+ crit critical emerg emergency
+ criti critical emerge emergency
+ critic critical emergen emergency
+ critica critical emergenc emergency
+ critical critical emergency emergency
+ er error i info
+ err error in info
+ erro error inf info
+ error error info info
+ n notice w warning
+ no notice wa warning
+ not notice war warning
+ noti notice warn warning
+ notic notice warni warning
+ notice notice warnin warning
+ warning warning
+} {
+ test log-2.0.$abbrev {level abbreviations} {
+ ::log::lv2longform $abbrev
+ } $long
+}
+
+test log-2.1 {abbreviation error} {
+ if {![catch {::log::lv2longform e} msg]} {
+ error "e is an unique abbreviation of a level name"
+ }
+ set msg
+} {"e" is no unique abbreviation of a level name}
+
+foreach {level color} {
+ emergency red warning yellow
+ alert red notice seagreen
+ critical red info {}
+ error red debug lightsteelblue
+} {
+ test log-3.0.$level {color conversion} {
+ ::log::lv2color $level
+ } $color
+}
+
+test log-3.1 {color conversion error} {
+ if {![catch {::log::lv2color foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {"foo" is no unique abbreviation of a level name}
+
+foreach {level priority} {
+ emergency 7 warning 3
+ alert 6 notice 2
+ critical 5 info 1
+ error 4 debug 0
+} {
+ test log-4.0.$level {priority conversion} {
+ ::log::lv2priority $level
+ } $priority
+}
+
+test log-4.1 {priority conversion error} {
+ if {![catch {::log::lv2priority foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {"foo" is no unique abbreviation of a level name}
+
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-5.0.$level {cmd retrieval} {
+ ::log::lv2cmd $level
+ } ::log::Puts
+}
+
+test log-5.1 {cmd error} {
+ if {![catch {::log::lv2cmd foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {"foo" is no unique abbreviation of a level name}
+
+foreach {level chan} {
+ emergency stderr warning stdout
+ alert stderr notice stdout
+ critical stderr info stdout
+ error stderr debug stdout
+} {
+ test log-6.0.$level {channel retrieval} {
+ ::log::lv2channel $level
+ } $chan
+}
+
+test log-6.1 {channel error} {
+ if {![catch {::log::lv2channel foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {"foo" is no unique abbreviation of a level name}
+
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-7.0.$level {query suppression state} {
+ ::log::lvIsSuppressed $level
+ } 0
+}
+
+test log-7.1 {error when querying suppression state} {
+ if {![catch {::log::lv2cmd foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {"foo" is no unique abbreviation of a level name}
+
+
+foreach {la lb res} {
+ emergency emergency 0 alert emergency -1 critical emergency -1 error emergency -1
+ emergency alert 1 alert alert 0 critical alert -1 error alert -1
+ emergency critical 1 alert critical 1 critical critical 0 error critical -1
+ emergency error 1 alert error 1 critical error 1 error error 0
+ emergency warning 1 alert warning 1 critical warning 1 error warning 1
+ emergency notice 1 alert notice 1 critical notice 1 error notice 1
+ emergency info 1 alert info 1 critical info 1 error info 1
+ emergency debug 1 alert debug 1 critical debug 1 error debug 1
+
+ warning emergency -1 notice emergency -1 info emergency -1 debug emergency -1
+ warning alert -1 notice alert -1 info alert -1 debug alert -1
+ warning critical -1 notice critical -1 info critical -1 debug critical -1
+ warning error -1 notice error -1 info error -1 debug error -1
+ warning warning 0 notice warning -1 info warning -1 debug warning -1
+ warning notice 1 notice notice 0 info notice -1 debug notice -1
+ warning info 1 notice info 1 info info 0 debug info -1
+ warning debug 1 notice debug 1 info debug 1 debug debug 0
+} {
+ test log-8.0.$la.$lb {level priority comparisons} {
+ list [::log::lvCompare $la $lb] $la $lb
+ } [list $res $la $lb]
+}
+
+test log-8.1 {comparison errors} {
+ if {![catch {::log::lvCompare foo error} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {"foo" is no unique abbreviation of a level name}
+
+test log-8.2 {comparison errors} {
+ if {![catch {::log::lvCompare error foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {"foo" is no unique abbreviation of a level name}
+
+
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-9.0.$level {redefining colors} {
+ set old [::log::lv2color $level]
+ ::log::lvColor $level foo
+ set new [::log::lv2color $level]
+ ::log::lvColor $level $old
+ set new
+ } foo
+}
+
+test log-9.1 {redefining colors} {
+ ::log::lvColorForall fox
+ set res [list]
+ foreach level [::log::levels] {
+ lappend res [::log::lv2color $level]
+ }
+ set res
+} {fox fox fox fox fox fox fox fox}
+
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-10.0.$level {redefining channels} {
+ set old [::log::lv2channel $level]
+ ::log::lvChannel $level foo
+ set new [::log::lv2channel $level]
+ ::log::lvChannel $level $old
+ set new
+ } foo
+}
+
+test log-10.1 {redefining channels} {
+ ::log::lvChannelForall fox
+ set res [list]
+ foreach level [::log::levels] {
+ lappend res [::log::lv2channel $level]
+ }
+ set res
+} {fox fox fox fox fox fox fox fox}
+
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-11.0.$level {redefining cmds} {
+ set old [::log::lv2cmd $level]
+ ::log::lvCmd $level foo
+ set new [::log::lv2cmd $level]
+ ::log::lvCmd $level $old
+ set new
+ } foo
+}
+
+test log-11.1 {redefining cmds} {
+ ::log::lvCmdForall logMem
+ set res [list]
+ foreach level [::log::levels] {
+ lappend res [::log::lv2cmd $level]
+ }
+ set res
+} {logMem logMem logMem logMem logMem logMem logMem logMem}
+
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-12.0.$level {change suppression state} {
+ set old [::log::lvIsSuppressed $level]
+ ::log::lvSuppress $level
+ set new [::log::lvIsSuppressed $level]
+ ::log::lvSuppress $level 0
+ lappend new [::log::lvIsSuppressed $level]
+ set new
+ } {1 0}
+}
+
+test log-12.1 {suppressor errors} {
+ if {![catch {::log::lvSuppress error foo} msg]} {
+ error "foo should be no boolean value"
+ }
+ set msg
+} {"foo" is not a member of {0, 1}}
+
+foreach {level range} {
+ emergency {1 1 1 1 1 1 1 1}
+ alert {1 1 1 0 1 1 1 1}
+ critical {0 1 1 0 1 1 1 1}
+ error {0 0 1 0 1 1 1 1}
+ warning {0 0 1 0 0 1 1 1}
+ notice {0 0 1 0 0 1 1 0}
+ info {0 0 1 0 0 1 0 0}
+ debug {0 0 1 0 0 0 0 0}
+} {
+ test log-12.2.$level {change suppression state, ranges} {
+ ::log::lvSuppressLE emergency 0 ; # initial full unsuppressed state
+ ::log::lvSuppressLE $level
+ set res [list]
+ foreach l [::log::levels] {
+ lappend res [::log::lvIsSuppressed $l]
+ }
+ set res
+ } $range
+}
+
+foreach {level range} {
+ debug {1 1 0 1 1 1 1 1}
+ info {1 1 0 1 1 0 1 1}
+ notice {1 1 0 1 1 0 0 1}
+ warning {1 1 0 1 1 0 0 0}
+ error {1 1 0 1 0 0 0 0}
+ critical {1 0 0 1 0 0 0 0}
+ alert {0 0 0 1 0 0 0 0}
+ emergency {0 0 0 0 0 0 0 0}
+} {
+ test log-12.3.$level {change suppression state, ranges} {
+ ::log::lvSuppressLE emergency ; # initial full supressed state
+ ::log::lvSuppressLE $level 0
+ set res [list]
+ foreach l [::log::levels] {
+ lappend res [::log::lvIsSuppressed $l]
+ }
+ set res
+ } $range
+}
+
+
+
+# Define our own logger command adding all messages to a global list
+# variable.
+
+global _log_
+set _log_ [list]
+proc logMem {level text} {
+ global _log_
+ lappend _log_ $level $text
+}
+
+# Setup some levels with different properties:
+# - Suppressed
+# - No command
+
+::log::lvCmdForall logMem
+::log::lvCmd alert {}
+::log::lvSuppress critical
+
+test log-13.0 {logging} {
+ set _log_ [list]
+ ::log::log emergency fofafraz
+ ::log::log alert fofafraz1
+ ::log::log critical fofafraz2
+ ::log::log error fofafraz3
+ ::log::log warning fofafraz4
+ set _log_
+} {emergency fofafraz error fofafraz3 warning fofafraz4}
+
+test log-13.1 {logging} {
+ set _log_ [list]
+ ::log::logMsg fobar
+ set _log_
+} {info fobar}
+
+test log-13.2 {logging} {
+ set _log_ [list]
+ ::log::logError buz
+ set _log_
+} {error buz}
+
+test log-13.3 {log error} {
+ if {![catch {::log::log e foobar} msg]} {
+ error "e is an unique abbreviation of a level name"
+ }
+ set msg
+} {"e" is no unique abbreviation of a level name}
+
+
+
+::tcltest::cleanupTests
+return
Index: modules/log/pkgIndex.tcl
===================================================================
RCS file: pkgIndex.tcl
diff -N pkgIndex.tcl
--- /dev/null Mon Dec 11 17:26:27 2000
+++ pkgIndex.tcl Tue Mar 20 16:15:09 2001
@@ -0,0 +1,11 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded log 1.0 [list source [file join $dir log.tcl]]
