From: kennykb@dssv01.crd.ge.com (Kevin B. Kenny)
Newsgroups: comp.lang.tcl
Subject: Re: Tcl interaction in my own window
Date: 22 Jul 92 21:47:08 GMT
Reply-To: kennykb@crd.ge.com
Organization: GE R&D, Information Architectures & Management Program


In article <PRZEMEK.92Jul21120718@rrdstrad.nist.gov>, przemek@rrdstrad.nist.gov
(Przemek Klosowski) writes:
>  Now, the problem is that the errors are still
>printed to the shell window.  Is there a way of intercepting Tcl error
>messages/printouts to put them, let say, in a separate message window?

I think that the following widget does everything you're trying to
accomplish, including trapping and handling all the errors.  Printouts
can't be caught readily, but you can use `commandwindow.print' rather
than `puts stdout' to print in the command window.

If I left out any proc's that you need, drop me a line and I'll send
them to you.

proc commandwindow {{w .commandwindow}} {
	global commandwindow
	set commandwindow $w
	toplevel $w -class CommandWindow
	wm group $w .
	wm withdraw $w
	wm deiconify $w
	wm title $w [option get $w title Title]
	frame $w.top
	label $w.top.label -text "Command:"
	entry $w.top.entry -relief sunken
	bindentry $w.top.entry "commandwindow.eval $w"
	pack append $w.top $w.top.label {left} \
		$w.top.entry {right expand fillx}
	label $w.vallabel -text Value
	frame $w.mid
	scrollbar $w.mid.scroll -command "$w.mid.value view"
	listbox $w.mid.value -scroll "$w.mid.scroll set" -relief sunken
	pack append $w.mid $w.mid.value {left expand fill} \
		$w.mid.scroll {right filly frame e}
	label $w.scriptlabel -text Transcript
	frame $w.bot
	scrollbar $w.bot.scroll -command "$w.bot.transcript view"
	listbox $w.bot.transcript -scroll "$w.bot.scroll set" -relief sunken
	pack append $w.bot $w.bot.transcript {left expand fill} \
		$w.bot.scroll {right filly frame e}
	pack append $w $w.top {top frame n} \
			$w.vallabel {top fillx} \
			$w.mid {top} \
			$w.scriptlabel {top fillx} \
			$w.bot {bottom frame s}

	# Focusing in response to the Enter event is wrong for the
	# active focus model, but the Tk 1.3 library does not reliably return
	# FocusIn events.

	bind $w <Any-Enter> "focus $w.top.entry"
	bind $w <Any-FocusIn> "focus $w.top.entry"
}

# commandwindow.eval -- evaluate the command typed in $w's entry box

proc commandwindow.eval {w command} {
	global errorInfo
	$w.bot.transcript view end
	$w.bot.transcript insert end "$command"
	catch { $w.top.entry delete 0 end }
	catch {$w.mid.value delete 0 end}
	set erreur [catch {uplevel #0 $command} value]
	foreach line [split $value \n] {
		$w.mid.value insert end $line
	}
	if $erreur {
		foreach line [split $errorInfo \n] {
			$w.bot.transcript insert end [format ":   %s" $line]
		}
	} else {
		foreach line [split $value \n] {
			$w.bot.transcript insert end [format "=   %s" $line]
		}
	}
}

# commandwindow.print -- print a message in the most recently created command
# window.

proc commandwindow.print args {
	global commandwindow
	$commandwindow.bot.transcript view end
	foreach line [split [join $args " "] \n] {
		$commandwindow.bot.transcript insert end [format "-  %s" $line]
	}
}

# commandwindow.trace -- trace a variable in the command window

proc commandwindow.trace {name {ops wu}} {
	uplevel trace variable $name $ops commandwindow.showtrace
}

# commandwindow.untrace --untrace a variable in the command window.

proc commandwindow.untrace {name {ops wu}} {
	uplevel trace vdelete $name $ops commandwindow.showtrace
}

# commandwindow.showtrace -- format trace output in command window

proc commandwindow.showtrace {name sub op} {
	set msg [\
		case $op in {
			r "Reading"
			w "Writing"
			u "Unsetting"
			default [format "Performing unknown operation %s on" \
					op]
		}\
	]
	append msg " $name"
	if {$sub != ""} {
		append msg "($sub)"
		catch { uplevel set $name($sub) } val
	} else {
		catch { uplevel set $name } val
	}
	if {$op != "u"} {
		append msg " = $val"
	}
	commandwindow.print $msg
}

option add *CommandWindow*entry.font fixed widgetDefault
option add *CommandWindow*value.font fixed widgetDefault
option add *CommandWindow*transcript.font fixed widgetDefault
option add *CommandWindow*entry.width 72 widgetDefault
option add *CommandWindow*value.geometry 80x5 widgetDefault
option add *CommandWindow*transcript.geometry 80x10 widgetDefault

# Do keyboard and mouse bindings for an entry box.

proc bindentry {w {command eval}} {
	bind $w <Any-KeyPress> {%W insert cursor "%A"; entry.cursor %W}
	bind $w <space> {%W insert cursor " "; entry.cursor %W}
	bind $w <Control-a> {%W cursor 0; %W view 0}
	bind $w <Control-b> {entry.cursorleft %W}
	bind $w <Control-d> {entry.deleteright %W}
	bind $w <Control-e> {%W cursor end; entry.cursor %W}
	bind $w <Control-f> {entry.cursorright %W}
	bind $w <Control-h> {entry.deleteleft %W}
	bind $w <Control-j> "$command \[%W get\]"
	bind $w <Control-k> {%W delete cursor end; entry.cursor %W}
	bind $w <Control-l> {entry.center %W}
	bind $w <Control-m> "$command \[%W get\]"
# Anyone volunteer to write the next one?
#	bind $w <Control-t> {entry.twiddle %W}
	bind $w <Control-u> {%W delete 0 end; %W view 0}
	bind $w <Control-w> {%W delete sel.first sel.last; entry.cursor %W}
	bind $w <Control-y> {%W insert cursor [selection get]; entry.cursor %W}
	bind $w <BackSpace> {entry.deleteleft %W}
	bind $w <Delete> {entry.deleteleft %W}
	bind $w <Linefeed> "$command \[%W get\]"
	bind $w <Return> "$command \[%W get\]"
    # quote, backslash, and left bracket need
    # to be handled specially.
        bind $w <quotedbl> {%W insert cursor "\""; entry.cursor %W}
        bind $w <backslash> {%W insert cursor "\\"; entry.cursor %W}
        bind $w <bracketleft> {%W insert cursor "\["; entry.cursor %W}
    # left, right arrows move cursor
        bind $w <Left>  {entry.cursorleft %W}
        bind $w <Right> {entry.cursorright %W}
	bind $w <ButtonPress-1> {%W cursor @%x; focus %W; %W select from @%x}
	bind $w <Button1-Motion> {%W select to @%x}
	bind $w <Shift-ButtonPress-1> {%W select adjust @%x}
	bind $w <Shift-Button1-Motion> {%W select to @%x}
	bind $w <Double-Button-1> {%W select from 0; %W select to end}
	bind $w <ButtonPress-2> {%W insert cursor [selection get]; entry.cursor %W}
	bind $w <Control-ButtonPress-2> {entry.rpl %W}
	bind $w <ButtonPress-3> {%W scan mark %x}
	bind $w <Button3-Motion> {%W scan dragto %x}
}

# Cursor left

proc entry.cursorleft {w} {
	set x [expr {[$w index cursor] - 1}]
	if {$x >= 0} {$w cursor $x}
	entry.cursor $w
}

# Cursor right

proc entry.cursorright {w} {
	set x [expr {[$w index cursor] + 1}]
	set xm [$w index end]
	if {$x <= $xm} {$w cursor $x}
	entry.cursor $w
}

# Delete left

proc entry.deleteleft {w} {
	set x [expr {[$w index cursor] - 1}]
	if {$x >= 0} {$w delete $x}
	entry.cursor $w
}

# Delete character right

proc entry.deleteright {w} {
	set x [$w index cursor]
	set xm [$w index end]
	if {$x < $xm} {$w delete $x}
	entry.cursor $w
}

# Center the cursor in the window

proc entry.center {win} {
	set cursor_position [$win index cursor]
	$win view 0
	set left_extent [$win index @0]
	set right_extent [$win index @[winfo width $win]]
	set entry_length [expr {$right_extent - $left_extent}]
	set text_length [expr [$win index end]]
	if {$text_length > $entry_length} {
		$win view [expr {$cursor_position - $entry_length/2 + 1}]
	}
}

# Move the view in the entry box to place cursor on screen

proc entry.cursor {win} {
	set left_extent [$win index @0]
	set right_extent [$win index @[winfo width $win]]
	set cursor_position [$win index cursor]
	set entry_length [expr {$right_extent - $left_extent}]
	if {$cursor_position >= $right_extent \
	 || $cursor_position <= $left_extent} {
		entry.center $win
	}
}

# Replace the entire entry with the selection

proc entry.rpl {win} {
	set a [selection get]
	$win delete 0 end
	$win insert cursor $a
	entry.cursor $win
}



73 de ke9tv/2, Kevin          There isn't any .signature virus, is there?