Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
200 lines (186 sloc) 6.94 KB
# FILE: console.tcl
#
# Provides a console window.
#
# Last modified on: $Date: 2006-01-28 17:42:17 -0500 (Sat, 28 Jan 2006) $
# Last modified by: $Author: redacted $
#
# 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.
########################################################################
# If the Tcl command 'console' is already in the interpreter, our work
# is done.
########################################################################
if {![catch {console show}]} {
return
}
########################################################################
# Check Tcl/Tk support
########################################################################
if {[catch {package require Tcl 8}]} {
package require Tcl 7.5
}
if {[catch {package require Tk 8}]} {
if {[catch {package require Tk 4.1}]} {
return -code error "Tk required but not loaded."
}
}
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 exit
load "" Tk $consoleInterp
# 2. A command 'console' in the application interpreter
;proc console {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"
}
}
}
if {[package vsatisfies [package provide Tk] 4]} {
$consoleInterp alias interp consoleinterp
} else {
$consoleInterp alias consoleinterp consoleinterp
}
# 4. Bind the <Destroy> event of the application interpreter's main
# window to kill the console (via tkConsoleExit)
bind . <Destroy> [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 <Control-Key-v> {}
}
}
# 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 <Destroy> +Oc_RestorePuts
}
unset consoleInterp
console title "[wm title .] Console"