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

Last change on this file since 1909 was 1909, checked in by mmc, 14 years ago

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