#! /bin/env tclsh
package require {ycl interp info}
namespace import [yclprefix]::interp::info
rename info iinfo
package require {ycl shelf shelf}
package require {ycl text}
namespace import [yclprefix]::text::ftclp
[yclprefix] shelf shelf .spawn [namespace current]
proc msg {_ levelname args} {
namespace upvar $_ leveldefault leveldefault levelmap levelmap \
chan chan threshold threshold
set level [dict get $levelmap $levelname]
if {$level > $threshold} {
return
}
set size 0
foreach arg $args[set args {}] {
set remainder [expr {$size - 1000}]
if {$remainder <= 0} {
break
}
if {[string length $arg] > $remainder} {
set arg [string range $arg[set args {}] 0 $remainder]...
}
incr size [string length $arg]
lappend args $arg
}
set args [string range $args[set args {}] 0 1000]
# This retain the list format if it is a list
set us [clock microseconds]
set info [uplevel 1 [list [namespace which iinfo] source]]
dict set info pid [pid]
dict set info time [clock format [expr {$us / 1000000}] \
-format "%Y %m %d %H %M %S [expr {$us % 1000000}]" -timezone :UTC]
set args [list {*}$args[set args {}] $info]
set msg [ftclp $args]
puts -nonewline $chan "$levelname "
puts $chan $args
}
[namespace current] .method msg
proc level {_ args} {
namespace upvar $_ levelmap levelmap threshold threshold
if {[llength $args] == 1} {
lassign $args level
if {$level in [dict values $levelmap]} {
set threshold $level
} elseif {[dict exists $levelmap $level]} {
set threshold [dict get $levelmap $level]
} else {
error [list {bad level value} $args]
}
} elseif {[llength $args]} {
error [list {too man args}]
}
return $threshold
}
[namespace current] .method level
[namespace current] $ chan stderr
[namespace current] $ threshold 7
[namespace current] $ levelmap [dict create {*}{
emergency 1
alert 2
critical 3
error 4
warning 5
notice 6
info 7
debug 8
debug2 9
debug3 10
}]
apply [list {} {
foreach name [dict keys [[namespace current] $ levelmap]] {
[namespace current] .method $name msg $name
}
} [namespace current]]