source: trunk/gui/scripts/postern.tcl @ 3899

Last change on this file since 3899 was 3454, checked in by gah, 11 years ago

add KP_Enter to Return bindings. Implement OK handler in visviewer base class. Fix setting # of isolines while running a sequence of heightmaps/contours
File size: 11.3 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2# ----------------------------------------------------------------------
3#  COMPONENT: postern - a back door for debugging
4#
5#  This utility gives you a console that you can use to debug any
6#  live application.  You have to click and type the proper magic
7#  in the right spot, and a console area will appear to handle
8#  your requests.
9# ======================================================================
10#  AUTHOR:  Michael McLennan, Purdue University
11#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
12#
13#  See the file "license.terms" for information on usage and
14#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15# ======================================================================
16package require BLT
17package require Itk
18
19option add *Postern.size 2 widgetDefault
20option add *Postern.activeColor gray widgetDefault
21option add *Postern.popup above widgetDefault
22option add *Postern*Text.font \
23    -*-courier-medium-r-normal-*-12-* widgetDefault
24option add *Postern*Text.errorFont \
25    -*-courier-medium-o-normal-*-12-* widgetDefault
26
27itcl::class Rappture::Postern {
28    inherit itk::Widget
29
30    itk_option define -size size Size 1
31    itk_option define -activecolor activeColor ActiveColor ""
32    itk_option define -popup popup Popup ""
33
34    constructor {args} { # defined below }
35    destructor { # defined below }
36    public method open {}
37    public method close {}
38    public method activate {args}
39    public method command {option}
40
41    public method _fake_puts {args}
42
43    private variable _active 0    ;# true when active and able to open
44    private variable _focus ""    ;# focus before this widget took over
45    private variable _afterid ""  ;# id for after event that clears activate
46
47    private variable _history ""  ;# list of recent commands
48    private variable _hpos 0      ;# current index in _history
49}
50
51itk::usual Postern {
52    keep -cursor -background
53}
54
55# ----------------------------------------------------------------------
56# CONSTRUCTOR
57# ----------------------------------------------------------------------
58itcl::body Rappture::Postern::constructor {args} {
59    global env tcl_platform
60
61    # this sequence gets things started...
62    if {$tcl_platform(os) == "Darwin"} {
63        # this works better on the Mac
64        bind $itk_component(hull) <Control-Button-1><Control-Button-1> \
65            [itcl::code $this activate on]
66    } else {
67        bind $itk_component(hull) <Button-1><Button-1><Button-3><Button-3> \
68            [itcl::code $this activate on]
69    }
70
71    #
72    # Get the magic word from the environment.
73    #
74    if {[info exists env(RAPPTURE_POSTERN)]} {
75        set event ""
76        foreach letter [split $env(RAPPTURE_POSTERN) ""] {
77            append event "<Key-$letter>"
78        }
79        bind $itk_component(hull) $event [itcl::code $this open]
80    }
81
82    #
83    # Build the debug dialog.
84    #
85    Rappture::Balloon $itk_component(hull).popup \
86        -title "Secret Command Console" \
87        -deactivatecommand [itcl::code $this activate off]
88    set inner [$itk_component(hull).popup component inner]
89
90    Rappture::Scroller $inner.area
91    pack $inner.area -expand yes -fill both
92    text $inner.area.text
93    $inner.area contents $inner.area.text
94
95    $inner.area.text tag configure error -foreground red \
96        -font [option get $inner.area.text errorFont Font]
97    $inner.area.text tag configure stderr -foreground red \
98        -font [option get $inner.area.text errorFont Font]
99    $inner.area.text tag configure stdout -foreground blue \
100        -font [option get $inner.area.text errorFont Font]
101
102    bind $inner.area.text <KeyPress> \
103        [itcl::code $this command key]
104    bind $inner.area.text <KeyPress-BackSpace> \
105        [itcl::code $this command backspace]
106    bind $inner.area.text <Control-KeyPress-h> \
107        [itcl::code $this command backspace]
108
109    bind $inner.area.text <KeyPress-Return> \
110        [itcl::code $this command execute]
111    bind $inner.area.text <KP_Enter> \
112        [itcl::code $this command execute]
113
114    bind $inner.area.text <KeyPress-Up> \
115        "[itcl::code $this command previous]; break"
116    bind $inner.area.text <Control-KeyPress-p> \
117        "[itcl::code $this command previous]; break"
118
119    bind $inner.area.text <KeyPress-Down> \
120        "[itcl::code $this command next]; break"
121    bind $inner.area.text <Control-KeyPress-n> \
122        "[itcl::code $this command next]; break"
123
124    command prompt
125
126    eval itk_initialize $args
127
128    # this makes it easier to find the magic spot
129    bind $itk_component(hull) <Alt-Enter> [list $itk_component(hull) configure -background $itk_option(-activecolor)]
130    bind $itk_component(hull) <Leave> [list $itk_component(hull) configure -background $itk_option(-background)]
131}
132
133# ----------------------------------------------------------------------
134# DESTRUCTOR
135# ----------------------------------------------------------------------
136itcl::body Rappture::Postern::destructor {} {
137    if {"" != $_afterid} {
138        after cancel $_afterid
139        set _afterid ""
140    }
141}
142
143# ----------------------------------------------------------------------
144# USAGE: active ?on|off?
145#
146# Used to query or set the activation state of this widget.  When
147# the widget is "active", it changes color and accepts the magic
148# pass phrase that will open up the debug panel.  A short delay after
149# being activated, it deactivates itself.
150# ----------------------------------------------------------------------
151itcl::body Rappture::Postern::activate {args} {
152    if {[llength $args] == 0} {
153        return $_active
154    }
155
156    if {"" != $_afterid} {
157        after cancel $_afterid
158        set _afterid ""
159    }
160
161    if {$args} {
162        component hull configure -background $itk_option(-activecolor)
163        set _focus [focus]
164        focus $itk_component(hull)
165        set _active 1
166        set _afterid [after 3000 [itcl::code $this activate off]]
167    } else {
168        focus $_focus
169        set _focus ""
170        component hull configure -background $itk_option(-background)
171
172        if {[info commands _tcl_puts] != ""} {
173            # set puts back to normal
174            rename ::puts ""
175            rename ::_tcl_puts ::puts
176        }
177        set _active 0
178    }
179}
180
181# ----------------------------------------------------------------------
182# USAGE: open
183#
184# Used to open the debug area.  If the widget is active, then the
185# debug area pops up near it.  Otherwise, this method does nothing.
186# ----------------------------------------------------------------------
187itcl::body Rappture::Postern::open {} {
188    if {$_active} {
189        if {"" != $_afterid} {
190            # don't deactivate until we close
191            after cancel $_afterid
192            set _afterid ""
193        }
194
195        $itk_component(hull).popup activate \
196            $itk_component(hull) $itk_option(-popup)
197
198        set text [$itk_component(hull).popup component inner].area.text
199        focus $text
200
201        # make puts send output to this display
202        rename ::puts ::_tcl_puts
203        proc ::puts {args} [format {%s _fake_puts $args} $this]
204    }
205}
206
207itcl::body Rappture::Postern::close {} {
208    $itk_component(hull).popup deactivate
209}
210
211# ----------------------------------------------------------------------
212# USAGE: command prompt
213# USAGE: command execute
214# USAGE: command next
215# USAGE: command previous
216# USAGE: command key
217#
218# Used to handle various editing operations in the text area.
219# ----------------------------------------------------------------------
220itcl::body Rappture::Postern::command {option} {
221    set text [$itk_component(hull).popup component inner].area.text
222
223    switch -- $option {
224        prompt {
225            if {[lindex [split [$text index end-1char] .] 1] != 0} {
226                $text insert end "\n"
227            }
228            $text insert end "% "
229            $text mark set command end-1char
230            $text mark gravity command left
231            $text mark set insert end
232            $text see insert
233        }
234        key {
235            if {[$text compare insert < command]} {
236                $text mark set insert end
237                $text see insert
238            }
239        }
240        backspace {
241            if {[catch {$text index sel.first}] == 0} {
242                if {[$text compare sel.first < command]
243                      || [$text compare sel.last < command]} {
244                    $text tag remove sel 1.0 end
245                }
246            }
247            if {[$text compare insert < command]} {
248                $text mark set insert end
249                $text see insert
250            }
251            if {[$text compare insert == command]} {
252                return -code break  ;# don't erase past start of command
253            }
254        }
255        execute {
256            set cmd [string trim [$text get command end]]
257            if {"" == $cmd} {
258                command prompt
259            } else {
260                lappend _history $cmd
261                if {[llength $_history] > 100} {
262                    set _history [lrange $_history end-100 end]
263                }
264                set _hpos [llength $_history]
265
266                $text insert end "\n"
267                if {[catch {uplevel #0 $cmd} result]} {
268                    $text insert end $result error
269                } else {
270                    $text insert end $result
271                }
272                command prompt
273            }
274            return -code break
275        }
276        next {
277            if {$_hpos < [llength $_history]} {
278                incr _hpos
279                set cmd [lindex $_history $_hpos]
280                $text delete command end
281                $text insert command $cmd
282                $text mark set insert end
283                $text see insert
284            }
285        }
286        previous {
287            if {$_hpos > 0} {
288                incr _hpos -1
289                set cmd [lindex $_history $_hpos]
290                $text delete command end
291                $text insert command $cmd
292                $text mark set insert end
293                $text see insert
294            }
295        }
296        default {
297            error "bad option \"$option\""
298        }
299    }
300}
301
302# ----------------------------------------------------------------------
303# USAGE: _fake_puts {?-nonewline? ?<channel>? <string>}
304#
305# This method acts as a replacement for puts.  It sends output
306# to the postern screen, itstead of stdin/stdout.
307# ----------------------------------------------------------------------
308itcl::body Rappture::Postern::_fake_puts {arglist} {
309    Rappture::getopts arglist params {
310        flag group -nonewline
311    }
312    switch -- [llength $arglist] {
313        1 {
314            set channel stdout
315            set string [lindex $arglist 0]
316        }
317        2 {
318            set channel [lindex $arglist 0]
319            set string [lindex $arglist 1]
320        }
321        default {
322            error "wrong # args: should be \"puts ?-nonewline? ?channel? string\""
323        }
324    }
325
326    set text [$itk_component(hull).popup component inner].area.text
327    if {$channel == "stdout" || $channel == "stderr"} {
328        $text insert end $string $channel
329        if {!$params(-nonewline)} {
330            $text insert end "\n"
331        }
332    } else {
333        eval _tcl_puts $arglist
334    }
335}
336
337# ----------------------------------------------------------------------
338# CONFIGURATION OPTION: -size
339# ----------------------------------------------------------------------
340itcl::configbody Rappture::Postern::size {
341    component hull configure \
342        -width $itk_option(-size) \
343        -height $itk_option(-size)
344}
Note: See TracBrowser for help on using the repository browser.