ET Here is an enhanced console for windows, to be used mostly with tclkits. It uses the existing console but adds some buttons, some simple debugging commands and a widget tree inspection tool.
Normally, if you have a tclkit.exe program, you might use it on windows to run a script using a command line as such,
> tclkit.exe aprogram.tcl ?args...?
It's likely you'll need to supply the path, but for simplicity, I'll leave that out here. With a windows command console, you can drag/drop files into the command window and it will place the full paths to your files in the console window, though you might need to quote them.
You can also create shortcuts in the same way to run a tcl script.
To use this enhanced console, one would do this instead, just slipping in myconsole.tcl between the program and the tcl source file, as so:
> tclkit.exe myconsole.tcl aprogram.tcl ?args...?
This lets the myconsole.tcl program run first and it will do the following
The lh command will output to the console the following small help. The word aproc was used here just so my syntax editor won't confuse it as a proc.
aproc {ls} {{namepat *}} # list directory
aproc {lt} {file} # list text of file
aproc {lp} {{namepat *}} # list procedure(s)
aproc {lw} {widget} # list a widget
aproc {la} {array_name {pattern *} {rev 0} {xp 0}} # list an array
aproc {lg} {pat {delimeter /} {max 50}} # list globals
aproc {ll} {name {max 50} {sort 0}} # list lists
These commands are all optional and easily removed or changed if desired. However, the lw command is used also by the widget tree procedures used to display the configure attributes to the console.
In order for this to work, the bwidgets package must be available, either built in to the tclkit or the auto_path global variable must have an element pointing to the lib directory of bwidgets. For example,
lappend auto_path {C:\tcl\kits\lib}This is invoked using the Extra2 menu added to the right of the Help menu.
The widget tree proc has 2 buttons to open or close the bwidget tree fully. It has the usual + and - for opening and closing individual elements. A left click on any widget in the tree will produce a 2 column output of the configure attributes of the widget in the console window and also the packing information if pack is used (does not support place or grid however).
It also places the full widget path into the clipboard so it can be pasted into the console for debugging uses.
The cputs command works like a puts command except that the first argument would be a color argument. There are several defined in the cputs proc itself, which tests for a first time use and defines them one time. It's easy to add more, just look at some of the example ones. The tree display widget uses one.
It's called, as
cputs <color> <string to output>
Unlike the normal puts, cputs does not output a newline. Here are a few examples,
cputs green "text green on black " ; cputs yellowonblack "and yellow on black\n"
This lets you have as many color combinations on a single line as you wish. Some background colors will fill the entire line. You can mix these with regular puts commands.
The console will also include a column of buttons on the left side. Several are just a button version of the menu commands, such as clear, and the font increase and decrease commands, plus exit. The bottom command will move to the bottom after scrolling. The next 2 are -x and +x which just quickly increase and decrease the width of the console. There's one last item, a checkbox which will disable scrolling of the console window.
In the below code, you may want to modify the console size with the line wm geom . or from your own script, using the console eval command, like so,
console eval {wm geom . 80x24+0+0}Here's the myconsole.tcl code:
namespace eval myconsole {
}
proc myconsole::myapp-shift {} {
#puts "argc=$::argc argv = $::argv"
#puts "::argv0= |$::argv0| "
set ::argv0 [lindex $::argv 1]
set ::argv [lreplace $::argv 1 1]
incr ::argc -1
#puts "argc=$::argc argv = $::argv"
#update
}
proc lh {} { ;# list help
puts {
aproc {ls} {{namepat *}} # list directory
aproc {lt} {file} # list text of file
aproc {lp} {{namepat *}} # list procedure(s)
aproc {lw} {widget} # list a widget
aproc {la} {array_name {pattern *} {rev 0} {xp 0}} # list an array
aproc {lg} {pat {delimeter /} {max 50}} # list globals
aproc {ll} {name {max 50} {sort 0}} # list lists
}
}
proc {ls} {{namepat *}} { # list directory
set files [glob $namepat]
#puts $files
for {set n 0} {$n < 2} {incr n} {
foreach file [lsort $files] {
if {[file isdirectory $file] && $n == 0} {
set d directory
set s ""
} elseif {![file isdirectory $file] && $n == 1} {
set d file
set s [file size $file]
} else {
continue
}
puts "[format {%10s %12s %s} $d $s $file]" ;#with each file in the list
}
}
}
proc {lt} {file} { # list text of file
set io [open $file]
fcopy $io stdout
close $io
}
proc {lp} {{namepat *}} { # list procedure(s)
foreach proc [info procs $namepat] {
set space ""
puts -nonewline "---------------------\nproc $proc {"
foreach arg [info args $proc] {
if [info default $proc $arg value] {
puts -nonewline "$space{$arg $value}"
} else {
puts -nonewline $space$arg
}
set space " "
}
# No newline needed because info body may return a
# value that starts with a newline
puts -nonewline "} {"
puts -nonewline [info body $proc]
puts "}"
}
}
proc {lw} {widget} { # list a widget
set w [$widget configure]
foreach item $w {
set opt [lindex $item 0]
set val "---"
catch {set val [$widget cget $opt]}
set wid($opt) $val
}
#la wid
set names [lsort -dictionary [array names wid]]
set n [llength $names]
set n2 [expr ( $n/2 )]
set odd [expr ( $n % 2 )]
#puts "odd=$odd n=$n n2=$n2"
if { $odd } {
incr n2 ;# so this one is 1 more than half
}
#puts "Odd=$odd n=$n n2=$n2"
if { $odd } {
for {set m 0;set m2 [expr ( $m+$n2 )]} {$m < $n2} {incr m;incr m2} {
if { $m == $n2-1 } {
#puts "m = $m"
set left [lindex $names $m]
#puts "l $left $wid($left)"
set leftt [format {%-20s %-20s} $left $wid($left)]
puts "$leftt|"
} else {
#puts "m = $m, m2 = $m2"
set left [lindex $names $m]
set right [lindex $names $m2]
#puts "l $left $wid($left)"
#puts "r $right $wid($right)"
set leftt [format {%-20s %-20s} $left $wid($left)]
set rightt [format {%-20s %-20s} $right $wid($right)]
puts "$leftt|[string trimright $rightt]"
}
}
} else {
for {set m 0;set m2 [expr ( $m+$n2 )]} {$m < $n2} {incr m;incr m2} {
#puts "m = $m, m2 = $m2"
set left [lindex $names $m]
set right [lindex $names $m2]
#puts "l $left $wid($left)"
#puts "r $right $wid($right)"
set leftt [format {%-20s %-20s} $left $wid($left)]
set rightt [format {%-20s %-20s} $right $wid($right)]
puts "$leftt|[string trimright $rightt]"
}
}
}
proc {la} {array_name {pattern *} {rev 0} {xp 0}} { # list an array
upvar 1 $array_name array
if {![array exists array]} {
error "\"$array_name\" isn't an array"
}
set maxl 0
foreach name [lsort [array names array $pattern]] {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + [string length $array_name] + 2}]
if {$rev == 0} {
foreach name [lsort -dictionary [array names array $pattern]] {
set nameString [format %s(%s) $array_name $name]
if {$xp} {
xputs [format "%-*s = %s" $maxl $nameString $array($name)]
} else {
puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
}
}
} else {
foreach name [lsort [array names array]] {
#puts stdout "compare pattern $pattern with $name - $array($name)"
if {[string match "*$pattern*" $array($name)]} {
set nameString [format %s(%s) $array_name $name]
if {$xp} {
xputs [format "%-*s = %s" $maxl $nameString $array($name)]
} else {
puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
}
}
}
}
}
###########################################################
## Procedure: lg
proc {lg} {{pat *} {delimeter /} {max 50}} { # list globals
set a [lsort -dictionary [info global ${pat}*]]
foreach _the_var_ $a {
#global $_the_var_
set that ""
set this "set that \[array names ::$_the_var_\]"
#puts "this1=$this"
eval $this
#puts "that=$that"
if {$that != ""} {
set this "set val \[lsort -dictionary \[array names ::$_the_var_\]\]"
#puts "---$this"
} else {
set this "set val $delimeter\$::$_the_var_$delimeter"
}
#puts "this2=$this"
catch {
eval $this
set foo [format "--- %-20s = %s" $_the_var_ [string range $val 0 $max]]
puts $foo
#puts "$_the_var_ \t= $val"
}
}
}
###########################################################
## Procedure: ll
proc {ll} {name {max 50} {sort 0}} { # list lists
if { [info exist $name] } {
upvar $name v
} else {
set v $name
}
if { $sort } {
foreach {i} [lsort -dictionary $v] {
puts [lrange $i 0 $max]
}
} else {
foreach {i} $v {
puts [lrange $i 0 $max]
}
}
}
###########################################################
## Procedure: myconsole::wtree
proc myconsole::wtree_node_puts {args} {
puts ""
puts ""
cputs green "$args\n"
lw $args
catch {cputs green "[pack info $args]\n"}
clipboard clear ; clipboard append $args
}
proc myconsole::wtree_node_openclose {which} {
set nodes [.wtree_top.sw.t nodes root]
#puts "which - $which - $nodes"
if { $which == "open" } {
foreach item $nodes {
.wtree_top.sw.t opentree $item
}
} else {
foreach item $nodes {
.wtree_top.sw.t closetree $item
}
}
}
proc myconsole::wtree {{root .} {level 0}} {
set top .wtree_top
if { $level == 0} {
package require BWidget
catch {
$top.sw.t delete [$top.sw.t nodes root]
destroy $top
}
toplevel $top
frame $top.f
button $top.f.b1 -text open -command {myconsole::wtree_node_openclose open}
button $top.f.b2 -text close -command {myconsole::wtree_node_openclose close}
pack $top.f -side top -fill x
pack $top.f.b1 $top.f.b2 -side left -expand yes -fill both
ScrolledWindow $top.sw
pack $top.sw -fill both -expand 1 -side top
Tree $top.sw.t -deltay 25 -deltax 25 -padx 5 -borderwidth 8 -linesfill orange -padx 5
#pack $top.sw.t
$top.sw setwidget $top.sw.t ;# Make ScrolledWindow manage the Tree widget
update ;# Process all UI events before moving on.
$top.sw.t bindText <1> +myconsole::wtree_node_puts
set ::wtree_queued_inserts {}
wm geom $top 466x326+52+52
}
set children [winfo children $root]
set class [winfo class $root]
set info ""
if { $class == "Button" } {
set info [split [$root cget -text] \n]
} elseif { $class == "TLabelframe" } {
set info [split [$root cget -text] \n]
} elseif { $class == "TButton" } {
set info [split [$root cget -text] \n]
} elseif { $class == "TEntry" } {
set info "var: [$root cget -textvariable]"
} elseif { $class == "TCheckbutton" } {
set info [split [$root cget -text] \n]
} elseif { $class == "TButton2" } {
set info [split [$root cget -text] \n]
} else {
}
#cputs normal "[string repeat " | " $level]"
#cputs green "$root"
#cputs red [split $root .]
#cputs normal " - $class $info\n"
set root [regsub -all : $root _]
set parts [split [string range $root 1 end] .]
#puts "parts = $parts"
if { $parts == "" } {
set parent root
} else {
set parent {}
foreach item [lrange $parts 0 end-1] {
append parent .$item
}
}
#puts "parent = /$parent/"
if { $parent == "" } {
set parent root
}
set cmd "$top.sw.t insert end \{$parent\} \{$root\} -font {courier 12} -text \{$root - $class $info\}"
#puts "cmd = $cmd"
lappend ::wtree_queued_inserts $cmd
if { $children == "" } {
return $root
} else {
foreach child $children {
set tout [myconsole::wtree $child [expr ( $level + 1 )]]
}
}
if { $level == 0 } {
#puts "\n\ndone here\n\n"
foreach item $::wtree_queued_inserts {
#puts "do - $item"
eval $item
}
}
}
proc cputs {dest string} {
if { ! [info exist ::tk::my_color_set] } {
set ::tk::my_color_set 1
console eval {
.console tag configure green -foreground \#00ff00 -background black
.console tag configure yellowonblack -foreground yellow -background black -font {ariel 14 bold}
.console tag configure yellow -foreground yellow
.console tag configure whiteonred -foreground white -background red
.console tag configure red -foreground red
}
}
console eval [list ::tk::ConsoleOutput $dest $string]
}
# proc script start
package require Tk
set ::argv [linsert $::argv 0 [info nameof]]
incr argc
if { $::tcl_platform(platform) != "windows" } {
#source [file join [info nameof] lib/app-tst/console.tclkit]
#use the console code that allows one to use a console on linux etc.
} else {
if [catch {
console eval {
if { ![info exist ::tk::do_scroll] } {
# proc console stuff
set vers [split [info patch] .]
if { [string compare [info patch] "8.6"] >= 0 } {
set menuincr 1
} else {
set menuincr 0
}
.console config -inactiveselectbackground SystemInactiveBorder -tabs {32 left} -tabstyle wordprocessor -width 30
wm geom . 87x24+0+0
# optional, if you want right click to do a paste
# bind all <Button-3> {.menubar.edit invoke 2}
bind all <Control-Button-3> {.menubar.edit invoke 1;.menubar.edit invoke 2}
pack forget .console .sb .consoleframe
pack [frame .frame -bg black] -side left -fill y -ipady 10 -pady 10
#pack [button .frame.eval -text Cev -command {clipboard clear; clipboard append "console eval \{\}"; .menubar.edit invoke 2}] -side top -fill x
pack [button .frame.clear -bg white -fg black -text Clear -command {.menubar.file invoke 2}] -side top -fill x
pack [button .frame.smaller -bg white -text {font -} -command {.menubar.edit invoke [expr ( $menuincr+6 )];after 100 {.frame.repos invoke}}] -side top -fill x
pack [button .frame.bigger -bg white -text {font +} -command {.menubar.edit invoke [expr ( $menuincr+5 )];after 100 {.frame.repos invoke}}] -side top -fill x
pack [button .frame.exit -bg white -text Exit -command {exit}] -side top -fill x
pack [button .frame.repos -bg white -text BottOM -command {.console see end; .console mark set insert end}] -side top -fill x
pack [frame .frame.frame -bg black] -side top -fill x
pack [button .frame.frame.pm20 -bg gray -text -x -command {wm geom . [expr [lindex [split [wm geom .] x] 0]-10]x[lindex [split [wm geom .] x] 1]}] -side left -fill x -expand 1
pack [button .frame.frame.pp20 -bg gray -text +x -command {wm geom . [expr [lindex [split [wm geom .] x] 0]+10]x[lindex [split [wm geom .] x] 1]}] -side left -fill x -expand 1
.frame.bigger invoke;.frame.bigger invoke;.frame.bigger invoke;.frame.bigger invoke
pack [checkbutton .frame.scroll -bg white -fg black -text scroll -variable ::tk::do_scroll] -side top -fill x
pack .consoleframe -in . -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 -side left
pack .console -in .consoleframe -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 -padx 1 -pady 1 -side left
pack .sb -in .consoleframe -anchor center -expand 0 -fill both -ipadx 0 -ipady 0 -padx 1 -pady 1 -side right
set ::tk::console::maxLines 10000
.menubar add casc -label Extra2 -menu [menu .menubar.extra -tearoff 0]
proc menu+ {head label cmd} {
set cmd2 [list consoleinterp eval $cmd]
.menubar.$head add command -label $label -command $cmd2
}
menu+ extra {Widget Tree} {myconsole::wtree}
proc ::tk::ConsoleOutput {dest string} {
set w .console
$w insert output $string $dest
::tk::console::ConstrainBuffer $w $::tk::console::maxLines
if {$::tk::do_scroll} {$w see insert}
}
set ::tk::do_scroll 1
}
}
} errstr ] {
puts stderr "error = $errstr"
}
}
if { $::argc > 1 } {
set myconsole::theprog [lindex $argv 1]
myconsole::myapp-shift
incr ::argc -1
set ::argv [lrange $::argv 1 end]
source $myconsole::theprog
#unset myconsole::theprog
}
Just paste this into a windows console and it will replace one internal proc. Runs in 8.6.9 9/8/2019. This is useful if you want to lean on the enter key and very rapidly repeat the last command.
console eval {
namespace eval tk { ; # replace this so we can capture a null command and repeat the last one
proc ::tk::ConsoleInvoke {args} {
set ranges [.console tag ranges input]
set cmd ""
if {[llength $ranges]} {
set pos 0
while {[lindex $ranges $pos] ne ""} {
set start [lindex $ranges $pos]
set end [lindex $ranges [incr pos]]
append cmd [.console get $start $end]
incr pos
}
}
if {$cmd eq ""} {
ConsolePrompt
} elseif {[info complete $cmd]} {
if { $cmd == "\n" } { #patch starts here, just this one if block
set cmd_next [consoleinterp eval {history nextid}]
set cmd_event [consoleinterp eval "history event [expr {( $cmd_next - 1 )}]"]
if { $cmd_event != "" } {
set cmd $cmd_event
consoleinterp eval {namespace eval ::tcl {incr history(nextid) -1;incr history(oldest) -1}} ;# don't store this one again in history
}
}
.console mark set output end
.console tag delete input
set result [consoleinterp record $cmd]
if {$result ne ""} {
puts $result
}
ConsoleHistory reset
ConsolePrompt
} else {
ConsolePrompt partial
}
.console yview -pickplace insert
}
}
}