1#!/usr/local/bin/wish8.6
2#
3# A Tcl shell in a text widget
4# Brent Welch, from "Practical Programming in Tcl and Tk"
5#
6
7package provide tkshell 1.0
8
9# "namespace eval" is needed to force the creation of the namespace,
10# even if it doesn't actually evaluate anything.  Otherwise, the use
11# of "proc tkshell::..." generates an undefined namespace error.
12
13namespace eval tkshell {
14   variable tkhist
15   variable tkpos
16   variable tkprompt
17}
18
19#-----------------------------------------------
20# Create a simple text widget with a Y scrollbar
21#-----------------------------------------------
22
23proc tkshell::YScrolled_Text { f args } {
24	frame $f
25	eval {text $f.text -wrap none \
26		-yscrollcommand [list $f.yscroll set]} $args
27	scrollbar $f.yscroll -orient vertical \
28		-command [list $f.text yview]
29	grid $f.text $f.yscroll -sticky news
30	grid rowconfigure $f 0 -weight 1
31	grid columnconfigure $f 0 -weight 1
32	return $f.text
33}
34
35#---------------------------------------------------------
36# Window command history management
37#---------------------------------------------------------
38
39proc tkshell::history {win dir} {
40  variable tkhist
41  variable tkpos
42
43  set hlen [llength $tkhist($win)]
44  set pos [expr $tkpos($win) + $dir]
45
46  set hidx [expr $hlen - $pos - 1]
47
48  if {$hidx < 0} {return}
49  if {$hidx > $hlen} {return}
50
51  set tkpos($win) $pos
52
53  $win delete limit insert
54  $win insert insert [lindex $tkhist($win) $hidx]
55}
56
57#---------------------------------------------------------
58# Create the shell window in Tk
59#---------------------------------------------------------
60
61proc tkshell::MakeEvaluator {{t .eval} {prompt "tcl>"} {prefix ""}} {
62  variable tkhist
63  variable tkpos
64  variable tkprompt
65
66  # Create array for command history
67  set tkhist($t) {}
68  set tkpos($t) -1
69  set tkprompt($t) $prompt
70
71  # Text tags give script output, command errors, command
72  # results, and the prompt a different appearance
73
74  $t tag configure prompt -foreground brown3
75  $t tag configure result -foreground purple
76  $t tag configure stderr -foreground red
77  $t tag configure stdout -foreground blue
78
79  # Insert the prompt and initialize the limit mark
80
81  $t insert insert "${prompt} " prompt
82  $t mark set limit insert
83  $t mark gravity limit left
84
85  # Key bindings that limit input and eval things. The break in
86  # the bindings skips the default Text binding for the event.
87
88  bind $t <Return> "tkshell::EvalTypein $t $prefix $prompt; break"
89  bind $t <BackSpace> {
90	if {[%W tag nextrange sel 1.0 end] != ""} {
91		%W delete sel.first sel.last
92	} elseif {[%W compare insert > limit]} {
93		%W delete insert-1c
94		%W see insert
95	}
96	break
97  }
98  bind $t <Up> {
99	tkshell::history %W 1
100	break
101  }
102  bind $t <Down> {
103	tkshell::history %W -1
104	break
105
106  }
107  bind $t <Key> {
108	if [%W compare insert < limit] {
109		%W mark set insert end
110	}
111  }
112}
113
114#-----------------------------------------------------------
115# Evaluate everything between limit and end as a Tcl command
116#-----------------------------------------------------------
117
118proc tkshell::EvalTypein {t prefix prompt} {
119	variable tkhist
120	set savecommand [$t get limit end-1c]
121	$t insert insert \n
122	set command [$t get limit end]
123	if [info complete $command] {
124		lappend tkhist($t) $savecommand
125	        set tkshell::tkpos($t) -1
126		$t mark set limit insert
127		tkshell::Eval $t $prefix $prompt $command
128	}
129}
130
131#-----------------------------------------------------------
132# Evaluate a command and display its result
133#-----------------------------------------------------------
134
135proc tkshell::Eval {t prefix prompt command} {
136	global Opts
137	$t mark set insert end
138	set fullcommand "${prefix} "
139	append fullcommand $command
140	if [catch {eval $fullcommand} result] {
141		$t insert insert $result error
142	} else {
143		$t insert insert $result result
144	}
145	if {[$t compare insert != "insert linestart"]} {
146		$t insert insert \n
147	}
148	$t insert insert "${prompt} " prompt
149	$t see insert
150	$t mark set limit insert
151        if {"$prefix" != ""} {
152	    catch {if {$Opts(redirect) == 1} {focus $prefix ; \
153			unset Opts(redirect)}}
154	    magic::macro XK_period "$fullcommand"
155	}
156	return
157}
158
159#--------------------------------------------------------------
160# This "puts" alias puts stdout and stderr into the text widget
161#--------------------------------------------------------------
162
163proc tkshell::PutsTkShell {args} {
164        global Opts
165	variable tkprompt
166        set t ${Opts(focus)}.pane.bot.eval
167	if {[llength $args] > 3} {
168		error "invalid arguments"
169	}
170	set newline "\n"
171	if {[string match "-nonewline" [lindex $args 0]]} {
172		set newline ""
173		set args [lreplace $args 0 0]
174	}
175	if {[llength $args] == 1} {
176		set chan stdout
177		set string [lindex $args 0]$newline
178	} else {
179		set chan [lindex $args 0]
180		set string [lindex $args 1]$newline
181	}
182	if [regexp (stdout|stderr) $chan] {
183		# ${t}.text delete "current linestart+1c" limit-1c	;# testing!
184		${t}.text mark gravity limit right
185		${t}.text insert limit $string $chan
186		${t}.text see limit
187		${t}.text mark gravity limit left
188		# if {![catch {set prompt $tkprompt(${t}.text)}]} {
189		#     ${t}.text insert insert "${prompt} " prompt	;# testing!
190		# }
191	} else {
192		::tkcon_puts -nonewline $chan $string
193	}
194}
195
196#--------------------------------------------------------------
197# A few lines is all that's needed to run this thing.
198#--------------------------------------------------------------
199# tkshell::YScrolled_Text .eval -width 90 -height 5
200# pack .eval -fill both -expand true
201# tkshell::MakeEvaluator .eval.text "magic> "
202#--------------------------------------------------------------
203