diff options
Diffstat (limited to 'tcllib/support/devel/sak/util/feedback.tcl')
| -rw-r--r-- | tcllib/support/devel/sak/util/feedback.tcl | 182 |
1 files changed, 182 insertions, 0 deletions
diff --git a/tcllib/support/devel/sak/util/feedback.tcl b/tcllib/support/devel/sak/util/feedback.tcl new file mode 100644 index 0000000..557ea50 --- /dev/null +++ b/tcllib/support/devel/sak/util/feedback.tcl @@ -0,0 +1,182 @@ +# -*- tcl -*- +# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +## +# ### + +# Feedback modes +# +# [short] Animated short feedback on stdout, no logging +# [log] Animated short feedback on stdout, logging to multiple files. +# [verbose] Logging to stdout +# +# Output commands for various destinations: +# +# <v> Verbose Log +# <s> Short Log +# +# Handling of the destinations per mode +# +# <s> <v> +# [short] stdout, /dev/null +# [log] stdout, file +# [verbose] /dev/null, stdout + +# Log files for different things are opened on demand, i.e. on the +# first write to them. We can configure (per possible log) a string to +# be written before the first write. Reconfiguring that string for a +# log clears the flag for that log and causes the string to be +# rewritten on the next write. + +package require sak::animate + +namespace eval ::sak::feedback { + namespace import ::sak::animate::next ; rename next aNext + namespace import ::sak::animate::last ; rename last aLast +} + +# ### + +proc ::sak::feedback::init {mode stem} { + variable prefix "" + variable short [expr {$mode ne "verbose"}] + variable verbose [expr {$mode ne "short"}] + variable tofile [expr {$mode eq "log"}] + variable lstem $stem + variable dst "" + variable lfirst + unset lfirst + array set lfirst {} + # Note: lchan is _not_ reset. We keep channels, allowing us to + # merge output from different modules, if they are run as + # one unit (Example: validate and its various parts, which + # can be run separately, and together). + return +} + +proc ::sak::feedback::first {dst string} { + variable lfirst + set lfirst($dst) $string + return +} + +### + +proc ::sak::feedback::summary {text} { + #=| $text + #log $text + + variable short + variable verbose + if {$short} { puts $text } + if {$verbose} { puts [_channel log] $text } + return +} + + +proc ::sak::feedback::log {text {ext log}} { + variable verbose + if {!$verbose} return + set c [_channel $ext] + puts $c $text + flush $c + return +} + +### + +proc ::sak::feedback::! {} { + variable short + if {!$short} return + variable prefix "" + sak::animate::init + return +} + +proc ::sak::feedback::+= {string} { + variable short + if {!$short} return + variable prefix + append prefix " " $string + aNext $prefix + return +} + +proc ::sak::feedback::= {string} { + variable short + if {!$short} return + variable prefix + aNext "$prefix $string" + return +} + +proc ::sak::feedback::=| {string} { + variable short + if {!$short} return + + variable prefix + aLast "$prefix $string" + + variable verbose + if {$verbose} { + variable dst + if {[string length $dst]} { + # inlined 'log' + set c [_channel $dst] + puts $c "$prefix $string" + flush $c + set dst "" + } + } + + set prefix "" + return +} + +proc ::sak::feedback::>> {string} { + variable dst $string + return +} + +# ### + +proc ::sak::feedback::_channel {dst} { + variable tofile + if {!$tofile} { return stdout } + variable lchan + if {[info exists lchan($dst)]} { + set c $lchan($dst) + } else { + variable lstem + set c [open ${lstem}.$dst w] + set lchan($dst) $c + } + variable lfirst + if {[info exists lfirst($dst)]} { + puts $c $lfirst($dst) + unset lfirst($dst) + } + return $c +} + +# ### + +namespace eval ::sak::feedback { + namespace export >> ! += = =| init log summary + + variable dst "" + variable prefix "" + variable short "" + variable verbose "" + variable tofile "" + variable lstem "" + variable lchan + array set lchan {} + + variable lfirst + array set lfirst {} +} + +## +# ### + +package provide sak::feedback 1.0 |