log.tcl

Go to the documentation of this file.

/*  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 ::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  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  cmdMap =  {}

    variable lv
    foreach  lv $levels { cmdMap = ($lv) ::log::Puts}
    un    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  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  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  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  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  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.*/

ret  ::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.*/

ret  ::log::lv2longform (type 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.*/

ret  ::log::lv2color (type 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.*/

ret  ::log::lv2priority (type 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.*/

ret  ::log::lv2cmd (type 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.*/

ret  ::log::lv2channel (type 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.*/

ret  ::log::lvCompare (type level1 , type 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.*/

ret  ::log::lvSuppress (type level , optional 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.*/

ret  ::log::lvSuppressLE (type level , optional 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.*/

ret  ::log::lvIsSuppressed (type 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.*/

ret  ::log::lvCmd (type level , type 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.*/

ret  ::log::lvCmdForall (type 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.*/

ret  ::log::lvChannel (type level , type 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.*/

ret  ::log::lvChannelForall (type 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.*/

ret  ::log::lvColor (type level , type 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.*/

ret  ::log::lvColorForall (type 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.*/

ret  ::log::logarray (type level , type arrayvar , optional 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.*/

ret  ::log::loghex (type level , type text , type 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.*/

ret  ::log::log (type level , type 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.*/

ret  ::log::logMsg (type 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.*/

ret  ::log::logError (type 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.*/

ret  ::log::Puts (type level , type 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