Posted to tcl by hypnotoad at Wed Jun 09 11:17:16 GMT 2010view raw
- catch {rename puts console:oldputs$w}
- proc puts args [format {
- if {![winfo exists %s]} {
- rename puts {}
- rename console:oldputs%s puts
- return [uplevel #0 puts $args]
- }
- switch -glob -- "[llength $args] $args" {
- {1 *} {
- set msg [lindex $args 0]\n
- set tag ok
- }
- {2 stdout *} {
- set msg [lindex $args 1]\n
- set tag ok
- }
- {2 stderr *} {
- set msg [lindex $args 1]\n
- set tag err
- }
- {2 green *} {
- set msg [lindex $args 1]\n
- set tag grn
- }
- {2 purple *} {
- set msg [lindex $args 1]\n
- set tag purple
- }
- {2 lightblue *} {
- set msg [lindex $args 1]\n
- set tag lblue
- }
- {2 orange *} {
- set msg [lindex $args 1]\n
- set tag orange
- }
- {2 -nonewline *} {
- set msg [lindex $args 1]
- set tag ok
- }
- {3 -nonewline stdout *} {
- set msg [lindex $args 2]
- set tag ok
- }
- {3 -nonewline stderr *} {
- set msg [lindex $args 2]
- set tag err
- }
- default {
- uplevel #0 console:oldputs%s $args
- return
- }
- }
- console:Puts %s $msg $tag
- } $w $w $w $w.t]