proc getputs body {
variable putsbuffer ""
if {[info commands puts_] eq ""} {
rename puts puts_
}
proc puts args {
set str [lindex $args end]
set arg1 [lindex $args 0]
set nonew [string equal $arg1 -nonewline]
switch -glob [llength $args],$nonew {
1,* {set chan stdout; append str \n}
2,0 {set chan $arg1; append str \n}
2,1 {set chan stdout}
3,1 {set chan [lindex $args 1]}
default {
error {wrong \# args: should be "puts ?-nonewline? ?channelId? string"}
}
}
if {$chan ne "stdout"} {
puts_ -nonewline $chan $str
} else {append ::putsbuffer $str}
return
}
set code [catch {uplevel 1 $body} res]
if {$code} {append putsbuffer $code:$res}
rename puts {}
rename puts_ puts
return -code $code $putsbuffer
}#--- Testing: puts before
set var [getputs {
puts -nonewline hello,
puts world
puts stdout inside!
puts stderr stderr...
#expr 1/0
}]
puts after:[string toupper $var]which shows on stdout:before stderr... after:HELLO,WORLD INSIDE!
Category Example | Arts and crafts of Tcl-Tk programming