#! /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]]



