console.tcl

# 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"