Initial revision

FossilOrigin-Name: 2bf55ca9aa942b581137b9f474da5ad9c1480de4

1 files changed, 481 insertions, 0 deletions

diff --git a/library/console.tcl b/library/console.tcl
new file mode 100644
index 0000000..d2c28b2
--- /dev/null
+++ b/library/console.tcl
@@ -0,0 +1,481 @@
+# console.tcl --
+#
+# This code constructs the console window for an application.  It
+# can be used by non-unix systems that do not have built-in support
+# for shells.
+#
+# SCCS: @(#) console.tcl 1.45 97/09/17 16:52:40
+#
+# Copyright (c) 1995-1997 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+# TODO: history - remember partially written command
+
+# tkConsoleInit --
+# This procedure constructs and configures the console windows.
+#
+# Arguments:
+# 	None.
+
+proc tkConsoleInit {} {
+    global tcl_platform
+
+    if {! [consoleinterp eval {set tcl_interactive}]} {
+	wm withdraw .
+    }
+
+    if {"$tcl_platform(platform)" == "macintosh"} {
+	set mod "Cmd"
+    } else {
+	set mod "Ctrl"
+    }
+
+    menu .menubar
+    .menubar add cascade -label File -menu .menubar.file -underline 0
+    .menubar add cascade -label Edit -menu .menubar.edit -underline 0
+
+    menu .menubar.file -tearoff 0
+    .menubar.file add command -label "Source..." -underline 0 \
+	-command tkConsoleSource
+    .menubar.file add command -label "Hide Console" -underline 0 \
+	-command {wm withdraw .}
+    if {"$tcl_platform(platform)" == "macintosh"} {
+	.menubar.file add command -label "Quit" -command exit -accel Cmd-Q
+    } else {
+	.menubar.file add command -label "Exit" -underline 1 -command exit
+    }
+
+    menu .menubar.edit -tearoff 0
+    .menubar.edit add command -label "Cut" -underline 2 \
+	-command { event generate .console <<Cut>> } -accel "$mod+X"
+    .menubar.edit add command -label "Copy" -underline 0 \
+	-command { event generate .console <<Copy>> } -accel "$mod+C"
+    .menubar.edit add command -label "Paste" -underline 1 \
+	-command { event generate .console <<Paste>> } -accel "$mod+V"
+
+    if {"$tcl_platform(platform)" == "windows"} {
+	.menubar.edit add command -label "Delete" -underline 0 \
+	    -command { event generate .console <<Clear>> } -accel "Del"
+
+	.menubar add cascade -label Help -menu .menubar.help -underline 0
+	menu .menubar.help -tearoff 0
+	.menubar.help add command -label "About..." -underline 0 \
+	    -command tkConsoleAbout
+    } else {
+	.menubar.edit add command -label "Clear" -underline 2 \
+	    -command { event generate .console <<Clear>> }
+    }
+
+    . conf -menu .menubar
+
+    text .console  -yscrollcommand ".sb set" -setgrid true 
+    scrollbar .sb -command ".console yview"
+    pack .sb -side right -fill both
+    pack .console -fill both -expand 1 -side left
+    if {$tcl_platform(platform) == "macintosh"} {
+        .console configure -font {Monaco 9 normal} -highlightthickness 0
+    }
+
+    tkConsoleBind .console
+
+    .console tag configure stderr -foreground red
+    .console tag configure stdin -foreground blue
+
+    focus .console
+    
+    wm protocol . WM_DELETE_WINDOW { wm withdraw . }
+    wm title . "Console"
+    flush stdout
+    .console mark set output [.console index "end - 1 char"]
+    tkTextSetCursor .console end
+    .console mark set promptEnd insert
+    .console mark gravity promptEnd left
+}
+
+# tkConsoleSource --
+#
+# Prompts the user for a file to source in the main interpreter.
+#
+# Arguments:
+# None.
+
+proc tkConsoleSource {} {
+    set filename [tk_getOpenFile -defaultextension .tcl -parent . \
+		      -title "Select a file to source" \
+		      -filetypes {{"Tcl Scripts" .tcl} {"All Files" *}}]
+    if {"$filename" != ""} {
+    	set cmd [list source $filename]
+	if [catch {consoleinterp eval $cmd} result] {
+	    tkConsoleOutput stderr "$result\n"
+	}
+    }
+}
+
+# tkConsoleInvoke --
+# Processes the command line input.  If the command is complete it
+# is evaled in the main interpreter.  Otherwise, the continuation
+# prompt is added and more input may be added.
+#
+# Arguments:
+# None.
+
+proc tkConsoleInvoke {args} {
+    set ranges [.console tag ranges input]
+    set cmd ""
+    if {$ranges != ""} {
+	set pos 0
+	while {[lindex $ranges $pos] != ""} {
+	    set start [lindex $ranges $pos]
+	    set end [lindex $ranges [incr pos]]
+	    append cmd [.console get $start $end]
+	    incr pos
+	}
+    }
+    if {$cmd == ""} {
+	tkConsolePrompt
+    } elseif [info complete $cmd] {
+	.console mark set output end
+	.console tag delete input
+	set result [consoleinterp record $cmd]
+	if {$result != ""} {
+	    .console insert insert "$result\n"
+	}
+	tkConsoleHistory reset
+	tkConsolePrompt
+    } else {
+	tkConsolePrompt partial
+    }
+    .console yview -pickplace insert
+}
+
+# tkConsoleHistory --
+# This procedure implements command line history for the
+# console.  In general is evals the history command in the
+# main interpreter to obtain the history.  The global variable
+# histNum is used to store the current location in the history.
+#
+# Arguments:
+# cmd -	Which action to take: prev, next, reset.
+
+set histNum 1
+proc tkConsoleHistory {cmd} {
+    global histNum
+    
+    switch $cmd {
+    	prev {
+	    incr histNum -1
+	    if {$histNum == 0} {
+		set cmd {history event [expr [history nextid] -1]}
+	    } else {
+		set cmd "history event $histNum"
+	    }
+    	    if {[catch {consoleinterp eval $cmd} cmd]} {
+    	    	incr histNum
+    	    	return
+    	    }
+	    .console delete promptEnd end
+    	    .console insert promptEnd $cmd {input stdin}
+    	}
+    	next {
+	    incr histNum
+	    if {$histNum == 0} {
+		set cmd {history event [expr [history nextid] -1]}
+	    } elseif {$histNum > 0} {
+		set cmd ""
+		set histNum 1
+	    } else {
+		set cmd "history event $histNum"
+	    }
+	    if {$cmd != ""} {
+		catch {consoleinterp eval $cmd} cmd
+	    }
+	    .console delete promptEnd end
+	    .console insert promptEnd $cmd {input stdin}
+    	}
+    	reset {
+    	    set histNum 1
+    	}
+    }
+}
+
+# tkConsolePrompt --
+# This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
+# exists in the main interpreter it will be called to generate the 
+# prompt.  Otherwise, a hard coded default prompt is printed.
+#
+# Arguments:
+# partial -	Flag to specify which prompt to print.
+
+proc tkConsolePrompt {{partial normal}} {
+    if {$partial == "normal"} {
+	set temp [.console index "end - 1 char"]
+	.console mark set output end
+    	if [consoleinterp eval "info exists tcl_prompt1"] {
+    	    consoleinterp eval "eval \[set tcl_prompt1\]"
+    	} else {
+    	    puts -nonewline "% "
+    	}
+    } else {
+	set temp [.console index output]
+	.console mark set output end
+    	if [consoleinterp eval "info exists tcl_prompt2"] {
+    	    consoleinterp eval "eval \[set tcl_prompt2\]"
+    	} else {
+	    puts -nonewline "> "
+    	}
+    }
+    flush stdout
+    .console mark set output $temp
+    tkTextSetCursor .console end
+    .console mark set promptEnd insert
+    .console mark gravity promptEnd left
+}
+
+# tkConsoleBind --
+# This procedure first ensures that the default bindings for the Text
+# class have been defined.  Then certain bindings are overridden for
+# the class.
+#
+# Arguments:
+# None.
+
+proc tkConsoleBind {win} {
+    bindtags $win "$win Text . all"
+
+    # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
+    # Otherwise, if a widget binding for one of these is defined, the
+    # <KeyPress> class binding will also fire and insert the character,
+    # which is wrong.  Ditto for <Escape>.
+
+    bind $win <Alt-KeyPress> {# nothing }
+    bind $win <Meta-KeyPress> {# nothing}
+    bind $win <Control-KeyPress> {# nothing}
+    bind $win <Escape> {# nothing}
+    bind $win <KP_Enter> {# nothing}
+
+    bind $win <Tab> {
+	tkConsoleInsert %W \t
+	focus %W
+	break
+    }
+    bind $win <Return> {
+	%W mark set insert {end - 1c}
+	tkConsoleInsert %W "\n"
+	tkConsoleInvoke
+	break
+    }
+    bind $win <Delete> {
+	if {[%W tag nextrange sel 1.0 end] != ""} {
+	    %W tag remove sel sel.first promptEnd
+	} else {
+	    if [%W compare insert < promptEnd] {
+		break
+	    }
+	}
+    }
+    bind $win <BackSpace> {
+	if {[%W tag nextrange sel 1.0 end] != ""} {
+	    %W tag remove sel sel.first promptEnd
+	} else {
+	    if [%W compare insert <= promptEnd] {
+		break
+	    }
+	}
+    }
+    foreach left {Control-a Home} {
+	bind $win <$left> {
+	    if [%W compare insert < promptEnd] {
+		tkTextSetCursor %W {insert linestart}
+	    } else {
+		tkTextSetCursor %W promptEnd
+            }
+	    break
+	}
+    }
+    foreach right {Control-e End} {
+	bind $win <$right> {
+	    tkTextSetCursor %W {insert lineend}
+	    break
+	}
+    }
+    bind $win <Control-d> {
+	if [%W compare insert < promptEnd] {
+	    break
+	}
+    }
+    bind $win <Control-k> {
+	if [%W compare insert < promptEnd] {
+	    %W mark set insert promptEnd
+	}
+    }
+    bind $win <Control-t> {
+	if [%W compare insert < promptEnd] {
+	    break
+	}
+    }
+    bind $win <Meta-d> {
+	if [%W compare insert < promptEnd] {
+	    break
+	}
+    }
+    bind $win <Meta-BackSpace> {
+	if [%W compare insert <= promptEnd] {
+	    break
+	}
+    }
+    bind $win <Control-h> {
+	if [%W compare insert <= promptEnd] {
+	    break
+	}
+    }
+    foreach prev {Control-p Up} {
+	bind $win <$prev> {
+	    tkConsoleHistory prev
+	    break
+	}
+    }
+    foreach prev {Control-n Down} {
+	bind $win <$prev> {
+	    tkConsoleHistory next
+	    break
+	}
+    }
+    bind $win <Insert> {
+	catch {tkConsoleInsert %W [selection get -displayof %W]}
+	break
+    }
+    bind $win <KeyPress> {
+	tkConsoleInsert %W %A
+	break
+    }
+    foreach left {Control-b Left} {
+	bind $win <$left> {
+	    if [%W compare insert == promptEnd] {
+		break
+	    }
+	    tkTextSetCursor %W insert-1c
+	    break
+	}
+    }
+    foreach right {Control-f Right} {
+	bind $win <$right> {
+	    tkTextSetCursor %W insert+1c
+	    break
+	}
+    }
+    bind $win <F9> {
+	eval destroy [winfo child .]
+	if {$tcl_platform(platform) == "macintosh"} {
+	    source -rsrc Console
+	} else {
+	    source [file join $tk_library console.tcl]
+	}
+    }
+    bind $win <<Cut>> {
+        # Same as the copy event
+ 	if {![catch {set data [%W get sel.first sel.last]}]} {
+	    clipboard clear -displayof %W
+	    clipboard append -displayof %W $data
+	}
+	break
+    }
+    bind $win <<Copy>> {
+ 	if {![catch {set data [%W get sel.first sel.last]}]} {
+	    clipboard clear -displayof %W
+	    clipboard append -displayof %W $data
+	}
+	break
+    }
+    bind $win <<Paste>> {
+	catch {
+	    set clip [selection get -displayof %W -selection CLIPBOARD]
+	    set list [split $clip \n\r]
+	    tkConsoleInsert %W [lindex $list 0]
+	    foreach x [lrange $list 1 end] {
+		%W mark set insert {end - 1c}
+		tkConsoleInsert %W "\n"
+		tkConsoleInvoke
+		tkConsoleInsert %W $x
+	    }
+	}
+	break
+    }
+}
+
+# tkConsoleInsert --
+# Insert a string into a text at the point of the insertion cursor.
+# If there is a selection in the text, and it covers the point of the
+# insertion cursor, then delete the selection before inserting.  Insertion
+# is restricted to the prompt area.
+#
+# Arguments:
+# w -		The text window in which to insert the string
+# s -		The string to insert (usually just a single character)
+
+proc tkConsoleInsert {w s} {
+    if {$s == ""} {
+	return
+    }
+    catch {
+	if {[$w compare sel.first <= insert]
+		&& [$w compare sel.last >= insert]} {
+	    $w tag remove sel sel.first promptEnd
+	    $w delete sel.first sel.last
+	}
+    }
+    if {[$w compare insert < promptEnd]} {
+	$w mark set insert end	
+    }
+    $w insert insert $s {input stdin}
+    $w see insert
+}
+
+# tkConsoleOutput --
+#
+# This routine is called directly by ConsolePutsCmd to cause a string
+# to be displayed in the console.
+#
+# Arguments:
+# dest -	The output tag to be used: either "stderr" or "stdout".
+# string -	The string to be displayed.
+
+proc tkConsoleOutput {dest string} {
+    .console insert output $string $dest
+    .console see insert
+}
+
+# tkConsoleExit --
+#
+# This routine is called by ConsoleEventProc when the main window of
+# the application is destroyed.  Don't call exit - that probably already
+# happened.  Just delete our window.
+#
+# Arguments:
+# None.
+
+proc tkConsoleExit {} {
+    destroy .
+}
+
+# tkConsoleAbout --
+#
+# This routine displays an About box to show Tcl/Tk version info.
+#
+# Arguments:
+# None.
+
+proc tkConsoleAbout {} {
+    global tk_patchLevel
+    tk_messageBox -type ok -message "Tcl for Windows
+Copyright \251 1996 Sun Microsystems, Inc.
+
+Tcl [info patchlevel]
+Tk $tk_patchLevel"
+}
+
+# now initialize the console
+
+tkConsoleInit