19 Tk by Example

Logging the output of a program run with exec.

#!/usr/local/bin/wish

# execlog - run a program with exec and log the output

# Set window title

wm title . ExecLog

# Create a frame for buttons and entry.

frame .top -borderwidth 10

pack .top -side top -fill x

# Create the command buttons.

button .top.quit -text Quit -command exit

set but [button .top.run -text "Run it" -command Run]

pack .top.quit .top.run -side right

# Create a labeled entry for the command

label .top.l -text Command: -padx 0

entry .top.cmd -width 20 -relief sunken \

	-textvariable command

pack .top.l -side left

pack .top.cmd -side left -fill x -expand true

# Set up key binding equivalents to the buttons

bind .top.cmd <Return> Run

bind .top.cmd <Control-c> Stop

focus .top.cmd

# Create a text widget to log the output

frame .t

set log [text .t.log -width 80 -height 10 \

	-borderwidth 2 -relief raised -setgrid true \

	-yscrollcommand {.t.scroll set}]

scrollbar .t.scroll -command {.t.log yview}

pack .t.scroll -side right -fill y

pack .t.log -side left -fill both -expand true

pack .t -side top -fill both -expand true

# Run the program and arrange to read its input

proc Run {} {

	global command input log but

	if [catch {open "|$command |& cat"} input] {

		$log insert end $input\n

	} else {

		fileevent $input readable Log

		$log insert end $command\n

		$but config -text Stop -command Stop

	}

}

# Read and log output from the program

proc Log {} {

	global input log

	if [eof $input] {

		Stop

	} else {

		gets $input line

		$log insert end $line\n

		$log see end

	}

}

# Stop the program and fix up the button

proc Stop {} {

	global input but

	catch {close $input}

	$but config -text "Run it" -command Run

}

wm title . ExecLog

A Frame for Buttons

frame .top -borderwidth 10

pack .top -side top -fill x

button .top.quit -text Quit -command exit

set but [button .top.run -text "Run it" \

	-command Run]

pack .top.quit .top.run -side right

label .top.l -text Command: -padx 0

entry .top.cmd -width 20 -relief sunken \

The label and entry are positioned to the left inside the .top frame. The additional packing parameters to the entry allow it to expand its packing space and fill up that extra area with its display. The difference between packing space and display space is discussed in Chapter 20 on page 255:

pack .top.l -side left

pack .top.cmd -side left -fill x -expand true

bind .top.cmd <Return> Run

bind .top.cmd <Control-c> Stop

focus .top.cmd

The scrollbar is a separate widget in Tk, and it can be connected to different widgets using the same setup as is used here. The text's yscrollcommand updates the display of the scrollbar when the text widget is modified, and the scrollbar's command scrolls the associated widget when the user manipulates the scrollbar:

frame .t

set log [text .t.log -width 80 -height 10 \

	-borderwidth 2 -relief raised -setgrid true\

	-yscrollcommand {.t.scroll set}]

scrollbar .t.scroll -command {.t.log yview}

pack .t.scroll -side right -fill y

pack .t.log -side left -fill both -expand true

A side effect of creating a Tk widget is the creation of a new Tcl command that operates on that widget. The name of the Tcl command is the same as the Tk pathname of the widget. In this script, the text widget command, .t.log, is needed in several places. However, it is a good idea to put the Tk pathname of an important widget into a variable because that pathname can change if you reorganize your user interface. The disadvantage of this is that you must declare the variable with global inside procedures. The variable log is used for this purpose in this example to demonstrate this style.

The Run Procedure

if [catch {open "|$command |& cat"} input] {

Trapping errors from pipelines.

The pipeline diverts error output from the command through the cat program. If you do not use cat like this, then the error output from the pipeline, if any, shows up as an error message when the pipeline is closed. In this example it turns out to be awkward to distinguish between errors generated from the program and errors generated because of the way the Stop procedure is implemented. Furthermore, some programs interleave output and error output, and you might want to see the error output in order instead of all at the end.

If the pipeline is opened successfully, then a callback is set up using the fileevent command. Whenever the pipeline generates output, then the script can read data from it. The Log procedure is registered to be called whenever the pipeline is readable:

fileevent $input readable Log

$log insert end $command\n

The run button is changed into a stop button after the program begins. This avoids a cluttered interface and demonstrates the dynamic nature of a Tk interface. Again, because this button is used in a few different places in the script, its pathname has been stored in the variable but:

$but config -text Stop -command Stop

if [eof $input] {

	Stop

} else {

	gets $input line

	$log insert end $line\n

	$log see end

}

catch {close $input}

$but config -text "Run it" -command Run

In most cases, closing the pipeline is adequate to kill the job. On UNIX, this results in a signal, SIGPIPE, being delivered to the program the next time it does a write to its standard output. There is no built-in way to kill a process, but you can exec the UNIX kill program. The pid command returns the process IDs from the pipeline:

foreach pid [pid $input] {

	catch {exec kill $pid}

If you need more sophisticated control over another process, you should check out the expect Tcl extension, which is described in the book Exploring Expect (Don Libes, O'Reilly & Associates, Inc., 1995). Expect provides powerful control over interactive programs. You can write Tcl scripts that send interactive programs input and pattern match on their output. Expect is designed to automate the use of programs that were designed for interactive use.

Cross-Platform Issues

proc Platform_CancelEvent {} {

	global tcl_platform

	switch $tcl_platform {

		unix {

			event add <<Cancel>> <Control-c>

		}

		windows {

			event add <<Cancel>> <Escape>

		}

		macintosh {

			event add <<Cancel>> <Command-.>

		}

	}

}

bind .top.entry <<Cancel>> Stop

The Example Browser

#!/usr/local/bin/wish

#	Browser for the Tcl and Tk examples in the book.

# browse(dir) is the directory containing all the tcl files

# Please edit to match your system configuration.

switch $tcl_platform(platform) {

	"unix" {set browse(dir) /cdrom/tclbook2/exsource}

	"windows" {set browse(dir) D:/exsource}

	"macintosh" {set browse(dir) /tclbook2/exsource}

}

wm minsize . 30 5

wm title . "Tcl Example Browser"

# Create a row of buttons along the top

set f [frame .menubar]

pack $f -fill x

button $f.quit -text Quit -command exit

button $f.next -text Next -command Next

button $f.prev -text Previous -command Previous

# The Run and Reset buttons use EvalEcho that

# is defined by the Tcl shell in Example 19-4 on page 245

button $f.load -text Run -command Run

button $f.reset -text Reset -command Reset

pack $f.quit $f.reset $f.load $f.next $f.prev -side right

# A label identifies the current example

label $f.label -textvariable browse(current)

pack $f.label -side right -fill x -expand true

# Create the menubutton and menu

menubutton $f.ex -text Examples -menu $f.ex.m

pack $f.ex -side left

set m [menu $f.ex.m]

# Create the text to display the example

# Scrolled_Text is defined in Example 27-1 on page 346

set browse(text) [Scrolled_Text .body \

	-width 80 -height 10\

	-setgrid true]

pack .body -fill both -expand true

# Look through the example files for their ID number.

foreach f [lsort -dictionary [glob [file join $browse(dir) *]]] {

	if [catch {open $f} in] {

		puts stderr "Cannot open $f: $in"

		continue

	}

	while {[gets $in line] >= 0} {

		if [regexp {^# Example ([0-9]+)-([0-9]+)} $line \

				x chap ex] {

			lappend examples($chap) $ex

			lappend browse(list) $f

			# Read example title

			gets $in line

			set title($chap-$ex) [string trim $line "# "]

			set file($chap-$ex) $f

			close $in

			break

		}

	}

}

# Create two levels of cascaded menus.

# The first level divides up the chapters into chunks.

# The second level has an entry for each example.

option add *Menu.tearoff 0

set limit 8

set c 0; set i 0

foreach chap [lsort -integer [array names examples]] {

	if {$i == 0} {

		$m add cascade -label "Chapter $chap..." \

			-menu $m.$c

		set sub1 [menu $m.$c]

		incr c

	}

	set i [expr ($i +1) % $limit]

	$sub1 add cascade -label "Chapter $chap" -menu $sub1.sub$i

	set sub2 [menu $sub1.sub$i ]

	foreach ex [lsort -integer $examples($chap)] {

		$sub2 add command -label "$chap-$ex $title($chap-$ex)" \

			-command [list Browse $file($chap-$ex)]

	}

}

# Display a specified file. The label is updated to

# reflect what is displayed, and the text is left

# in a read-only mode after the example is inserted.

proc Browse { file } {

	global browse

	set browse(current) [file tail $file]

	set browse(curix) [lsearch $browse(list) $file]

	set t $browse(text)

	$t config -state normal

	$t delete 1.0 end

	if [catch {open $file} in] {

		$t insert end $in

	} else {

		$t insert end [read $in]

		close $in

	}

	$t config -state disabled

}

# Browse the next and previous files in the list

set browse(curix) -1

proc Next {} {

	global browse

	if {$browse(curix) < [llength $browse(list)] - 1} {

		incr browse(curix)

	}

	Browse [lindex $browse(list) $browse(curix)]

}

proc Previous {} {

	global browse

	if {$browse(curix) > 0} {

		incr browse(curix) -1

	}

	Browse [lindex $browse(list) $browse(curix)]

}

# Run the example in the shell

proc Run {} {

	global browse

	EvalEcho [list source \

		[file join $browse(dir) $browse(current)]]

}

# Reset the slave in the eval server

proc Reset {} {

	EvalEcho reset

}

wm minsize . 30 5

Managing Global State

Searching through Files

foreach f [lsort -dictionary [glob [file join $browse(dir) *]]] {

	if [catch {open $f} in] {

		puts stderr "Cannot open $f: $in"

		continue

	}

	while {[gets $in line] >= 0} {

		if [regexp {^# Example ([0-9]+)-([0-9]+)} $line \

				x chap ex] {

			lappend examples($chap) $ex

			lappend browse(list) $f

			# Read example title

			gets $in line

			set title($chap-$ex) [string trim $line "# "]

			set file($chap-$ex) $f

			close $in

			break

		}

	}

The example files contain lines like this:

# Example 1-1

# The Hello, World! program

The regexp picks out the example numbers with the ([0-9]+)-([0-9]+) part of the pattern, and these are assigned to the chap and ex variables. The x variable is assigned the value of the whole match, which is more than we are interested in. Once the example number is found, the next line is read to get the description of the example. At the end of the foreach loop the examples array has an element defined for each chapter, and the value of each element is a list of the examples for that chapter.

Cascaded Menus

menubutton $f.ex -text Examples -menu $f.ex.m

set m [menu $f.ex.m]

There are too many chapters to put them all into one menu. The main menu has a cascade entry for each group of 8 chapters. Each of these submenus has a cascade entry for each chapter in the group. Finally, each chapter has a menu of all its examples. Once again, the submenus are defined as a child of their parent menu. Note the inconsistency between menu entries and buttons. Their text is defined with the -label option, not -text. Other than this they are much like buttons. Chapter 24 describes menus in more detail. The code is repeated here:

set limit 8 ; set c 0 ; set i 0

foreach key [lsort -integer [array names examples]] {

	if {$i == 0} {

		$m add cascade -label "Chapter $key..." \

			-menu $m.$c

		set sub1 [menu $m.$c]

		incr c

	}

	set i [expr ($i +1) % $limit]

	$sub1 add cascade -label "Chapter $key" -menu $sub1.sub$i

	set sub2 [menu $sub1.sub$i]

	foreach ex [lsort -integer $examples($key)] {

		$sub2 add command -label "$key-$ex $title($key-$ex)" \

			-command [list Browse $file($key-$ex)]

	}

A Read-Only Text Widget

global browse

set browse(current) [file tail $file]

$t config -state normal

$t insert end [read $in]

A Tcl Shell

Example 19-4 is written to be used with the browser from Example 19-3 in the same application. The browser's Run button runs the current example in the shell. An alternative is to have the shell run as a separate process and use the send command to communicate Tcl commands between separate applications. That alternative is shown in Example on page 481.

#!/usr/local/bin/wish

# Simple evaluator. It executes Tcl in a slave interpreter

set t [Scrolled_Text .eval -width 80 -height 10]

pack .eval -fill both -expand true

# Text tags give script output, command errors, command

# results, and the prompt a different appearance

$t tag configure prompt -underline true

$t tag configure result -foreground purple

$t tag configure error -foreground red

$t tag configure output -foreground blue

# Insert the prompt and initialize the limit mark

set eval(prompt) "tcl> "

$t insert insert $eval(prompt) prompt

$t mark set limit insert

$t mark gravity limit left

focus $t

set eval(text) $t

# Key bindings that limit input and eval things. The break in

# the bindings skips the default Text binding for the event.

bind $t <Return> {EvalTypein ; break}

bind $t <BackSpace> {

	if {[%W tag nextrange sel 1.0 end] != ""} {

		%W delete sel.first sel.last

	} elseif {[%W compare insert > limit]} {

		%W delete insert-1c

		%W see insert

	}

	break

}

bind $t <Key> {

	if [%W compare insert < limit] {

		%W mark set insert end

	}

}

# Evaluate everything between limit and end as a Tcl command

proc EvalTypein {} {

	global eval

	$eval(text) insert insert \n

	set command [$eval(text) get limit end]

	if [info complete $command] {

		$eval(text) mark set limit insert

		Eval $command

	}

}

# Echo the command and evaluate it

proc EvalEcho {command} {

	global eval

	$eval(text) mark set insert end

	$eval(text) insert insert $command\n

	Eval $command

}

# Evaluate a command and display its result

proc Eval {command} {

	global eval

	$eval(text) mark set insert end

	if [catch {$eval(slave) eval $command} result] {

		$eval(text) insert insert $result error

	} else {

		$eval(text) insert insert $result result

	}

	if {[$eval(text) compare insert != "insert linestart"]} {

		$eval(text) insert insert \n

	}

	$eval(text) insert insert $eval(prompt) prompt

	$eval(text) see insert

	$eval(text) mark set limit insert

	return

}

# Create and initialize the slave interpreter

proc SlaveInit {slave} {

	interp create $slave

	load {} Tk $slave

	interp alias $slave reset {} ResetAlias $slave

	interp alias $slave puts {} PutsAlias $slave

	return $slave

}

# The reset alias deletes the slave and starts a new one

proc ResetAlias {slave} {

	interp delete $slave

	SlaveInit $slave

}

# The puts alias puts stdout and stderr into the text widget

proc PutsAlias {slave args} {

	if {[llength $args] > 3} {

		error "invalid arguments"

	}

	set newline "\n"

	if {[string match "-nonewline" [lindex $args 0]]} {

		set newline ""

		set args [lreplace $args 0 0]

	}

	if {[llength $args] == 1} {

		set chan stdout

		set string [lindex $args 0]$newline

	} else {

		set chan [lindex $args 0]

		set string [lindex $args 1]$newline

	}

	if [regexp (stdout|stderr) $chan] {

		global eval

		$eval(text) mark gravity limit right

		$eval(text) insert limit $string output

		$eval(text) see limit

		$eval(text) mark gravity limit left

	} else {

		puts -nonewline $chan $string

	}

}

set eval(slave) [SlaveInit shell]

The <Key> binding checks to see where the insert mark is and bounces it to the end if the user tries to input text before the limit mark. The puts alias sets right gravity on limit so the mark is pushed along when program output is inserted right at limit. Otherwise, the left gravity on limit means that the mark does not move when the user inserts right at limit.

Text tags are used to give different regions of text difference appearances. A tag applies to a range of text. The tags are configured at the beginning of the script and they are applied when text is inserted.

Chapter 30 describes the text widget in more detail.

Multiple Interpreters

The shell interpreter is not created with the -safe flag, so it can do anything. For example, if you type exit, it will exit the whole application. The SlaveInit procedure installs an alias, reset, that just deletes the slave interpreter and creates a new one. You can use this to clean up after working in the shell for a while. Chapter 17 describes the interp command in detail.

Native Look and Feel