From: Pat Thoyts Date: Tue, 23 Feb 2010 21:52:05 +0000 (+0000) Subject: Add unix console support ala tk windows console. X-Git-Url: http://privyetmir.co.uk/gitweb?a=commitdiff_plain;h=a2397db859bfbd3b09ba85e1d09a5e0f7db6fd01;p=Bullfrog Add unix console support ala tk windows console. Signed-off-by: Pat Thoyts --- diff --git a/bin/bullfrog.tcl b/bin/bullfrog.tcl index b838c84..a7fe920 100644 --- a/bin/bullfrog.tcl +++ b/bin/bullfrog.tcl @@ -29,6 +29,11 @@ set root [file dirname [info script]] ::msgcat::mcload [file join $root msgs] source [file join $root message.tcl] source [file join $root tab.tcl] +source [file join $root console.tcl] + +if {[info commands ::console] eq {}} { + after idle [list console::ConsoleInit] +} # Load the transport specific files... source [file join $root bf_irc.tcl] @@ -132,6 +137,7 @@ proc Main {args} { ttk::notebook::enableTraversal $app.nb bind $app {console show} + if {[tk windowingsystem] eq "x11"} {bind $app {console show}} bind $app.nb <> [namespace code "OnTabSelected %W"] wm geometry .chat 600x400 diff --git a/bin/console.tcl b/bin/console.tcl new file mode 100644 index 0000000..9c26757 --- /dev/null +++ b/bin/console.tcl @@ -0,0 +1,202 @@ +# +# Create the Tk console on unix or optionally on Windows we can +# create a console that is embedded in some other window +# See the notepad demo code at the end. +# +# Original unix console from the wiki. + +namespace eval ::console {} + +proc ::console::ConsoleInit {{parent {}} {name ::console}} { + + # This file is evaluated to provide a console window interface to the + # root Tcl interpreter of an OOMMF application. It calls on a script + # included with the Tk script library to do most of the work, making use + # of Tk interface details which are only semi-public. For this reason, + # there is some risk that future versions of Tk will no longer support + # this script. That is why this script has been isolated in a file of + # its own. + + set _ [file join $::tk_library console.tcl] + if {![file readable $_]} { + return -code error "File not readable: $_" + } + + ######################################################################## + # Provide the support which the Tk library script console.tcl assumes + ######################################################################## + # 1. Create an interpreter for the console window widget and load Tk + set consoleInterp [interp create] + $consoleInterp eval [list set ::tk_library $::tk_library] + $consoleInterp alias exit $name hide + + if {$parent ne {}} { + if {[string match ".*" $parent]} { set parent [winfo id $parent] } + $consoleInterp eval lappend argv -use $parent + } + + load "" Tk $consoleInterp + + # 2. A command 'console' in the application interpreter + proc $name {sub {optarg {}}} [subst -nocommands { + switch -exact -- \$sub { + title { + $consoleInterp eval wm title . [list \$optarg] + } + hide { + $consoleInterp eval wm withdraw . + } + show { + $consoleInterp eval wm deiconify . + } + eval { + $consoleInterp eval \$optarg + } + default { + error "bad option \\\"\$sub\\\": should be hide, show, or title" + } + } + }] + + # 3. Alias a command 'consoleinterp' in the console window interpreter + # to cause evaluation of the command 'consoleinterp' in the + # application interpreter. + proc ::consoleinterp {sub cmd} { + switch -exact -- $sub { + eval { + uplevel #0 $cmd + } + record { + history add $cmd + catch {uplevel #0 $cmd} retval + return $retval + } + default { + error "bad option \"$sub\": should be eval or record" + } + } + } + $consoleInterp alias consoleinterp consoleinterp + + # 4. Bind the event of the application interpreter's main + # window to kill the console (via tkConsoleExit) + bind . [list +if {[string match . %W]} [list catch \ + [list $consoleInterp eval tkConsoleExit]]] + + # 5. Redefine the Tcl command 'puts' in the application interpreter + # so that messages to stdout and stderr appear in the console. + rename ::puts ::tcl_puts + proc ::puts {args} [subst -nocommands { + switch -exact -- [llength \$args] { + 1 { + if {[string match -nonewline \$args]} { + if {[catch {uplevel 1 [linsert \$args 0 tcl_puts]} msg]} { + regsub -all tcl_puts \$msg puts msg + return -code error \$msg + } + } else { + $consoleInterp eval [list tkConsoleOutput stdout \ + "[lindex \$args 0]\n"] + } + } + 2 { + if {[string match -nonewline [lindex \$args 0]]} { + $consoleInterp eval [list tkConsoleOutput stdout \ + [lindex \$args 1]] + } elseif {[string match stdout [lindex \$args 0]]} { + $consoleInterp eval [list tkConsoleOutput stdout \ + "[lindex \$args 1]\n"] + } elseif {[string match stderr [lindex \$args 0]]} { + $consoleInterp eval [list tkConsoleOutput stderr \ + "[lindex \$args 1]\n"] + } else { + if {[catch {uplevel 1 [linsert \$args 0 tcl_puts]} msg]} { + regsub -all tcl_puts \$msg puts msg + return -code error \$msg + } + } + } + 3 { + if {![string match -nonewline [lindex \$args 0]]} { + if {[catch {uplevel 1 [linsert \$args 0 tcl_puts]} msg]} { + regsub -all tcl_puts \$msg puts msg + return -code error \$msg + } + } elseif {[string match stdout [lindex \$args 1]]} { + $consoleInterp eval [list tkConsoleOutput stdout \ + [lindex \$args 2]] + } elseif {[string match stderr [lindex \$args 1]]} { + $consoleInterp eval [list tkConsoleOutput stderr \ + [lindex \$args 2]] + } else { + if {[catch {uplevel 1 [linsert \$args 0 tcl_puts]} msg]} { + regsub -all tcl_puts \$msg puts msg + return -code error \$msg + } + } + } + default { + if {[catch {uplevel 1 [linsert \$args 0 tcl_puts]} msg]} { + regsub -all tcl_puts \$msg puts msg + return -code error \$msg + } + } + } + }] + $consoleInterp alias puts puts + + # 6. No matter what Tk_Main says, insist that this is an interactive shell + set ::tcl_interactive 1 + + ######################################################################## + # Evaluate the Tk library script console.tcl in the console interpreter + ######################################################################## + $consoleInterp eval source [list [file join $::tk_library console.tcl]] + $consoleInterp eval { + if {![llength [info commands ::tkConsoleExit]]} { + tk::unsupported::ExposePrivateCommand tkConsoleExit + } + } + $consoleInterp eval { + if {![llength [info commands ::tkConsoleOutput]]} { + tk::unsupported::ExposePrivateCommand tkConsoleOutput + } + } + if {[string match 8.3.4 $::tk_patchLevel]} { + # Workaround bug in first draft of the tkcon enhancments + $consoleInterp eval { + bind Console {} + } + } + # Restore normal [puts] if console widget goes away... + proc ::Oc_RestorePuts {slave} { + rename ::puts {} + rename ::tcl_puts ::puts + interp delete $slave + } + $consoleInterp alias Oc_RestorePuts Oc_RestorePuts $consoleInterp + $consoleInterp eval { + bind Console +Oc_RestorePuts + } + + unset consoleInterp + $name title "[wm title .] Console" + $name hide +} + +proc ::console::EmbeddedConsoleDemo {parent} { + set dlg [toplevel [join [list $parent embedconsoledemo] .] -class Dialog] + set nb [ttk::notebook $dlg.nb] + frame $nb.page0 -container 1 + ConsoleInit $nb.page0 ::firstconsole + + frame $nb.page1 -container 0 -background blue + + $nb add $nb.page0 -text Console + $nb add $nb.page1 -text Second + grid $nb -sticky news + grid rowconfigure $dlg 0 -weight 1 + grid columnconfigure $dlg 0 -weight 1 + + bind $dlg {interp delete ::firstconsole} +}