NetNews Usenet Archive 1992 #16/NN_1992_16.iso/spool/comp/lang/tcl/1030

Internet Message Format | 1992-07-22 | 8.0 KB

Path: sparky!uunet!crdgw1!rdsunx.crd.ge.com!dssv01!kennykb
From: [e-mail] (Kevin B. Kenny)
Newsgroups: comp.lang.tcl
Subject: Re: Tcl interaction in my own window
Message-ID: <[e-mail]>
Date: 22 Jul 92 21:47:08 GMT
References: <[e-mail]> <[e-mail]>
Sender: [e-mail] (Required for NNTP)
Reply-To: [e-mail]
Organization: GE R&D, Information Architectures & Management Program
Lines: 249
Nntp-Posting-Host: dssv01.crd.ge.com


In article <[e-mail]>, [e-mail]
(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?