Add unix console support ala tk windows console.

Signed-off-by: Pat Thoyts <patthoyts@users.sourceforge.net>

diff --git a/bin/bullfrog.tcl b/bin/bullfrog.tcl
index b838c84a060c8de3be35291073beff7822bdb61b..a7fe9200345bda712d7097c6aef1ae5e45a582e5 100644 (file)
--- 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 <Control-F2> {console show}
+    if {[tk windowingsystem] eq "x11"} {bind $app <F2> {console show}}
     bind $app.nb <<NotebookTabChanged>> [namespace code "OnTabSelected %W"]
 
     wm geometry .chat 600x400

diff --git a/bin/console.tcl b/bin/console.tcl
new file mode 100644 (file)
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 <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
+        $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 <Destroy> {interp delete ::firstconsole}
+}