source: branches/blt4/gui/scripts/postern.tcl @ 1710

Last change on this file since 1710 was 1710, checked in by gah, 14 years ago
File size: 9.8 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}
53itk::usual Scrollset {
54}
55
56# ----------------------------------------------------------------------
57# CONSTRUCTOR
58# ----------------------------------------------------------------------
59itcl::body Rappture::Postern::constructor {args} {
60    global env
61
62    # this sequence gets things started...
63    bind $itk_component(hull) \
64        <Button-1><Button-1><Button-3><Button-3> \
65        [itcl::code $this activate on]
66
67    #
68    # Get the magic word from the environment.
69    #
70    if {[info exists env(RAPPTURE_POSTERN)]} {
71        set event ""
72        foreach letter [split $env(RAPPTURE_POSTERN) ""] {
73            append event "<Key-$letter>"
74        }
75        bind $itk_component(hull) $event [itcl::code $this open]
76    }
77
78    #
79    # Build the debug dialog.
80    #
81    Rappture::Balloon $itk_component(hull).popup \
82        -title "Secret Command Console" \
83        -deactivatecommand [itcl::code $this activate off]
84    set inner [$itk_component(hull).popup component inner]
85
86    blt::scrollset $inner.area  -window $inner.area.text
87    pack $inner.area -expand yes -fill both
88    text $inner.area.text
89
90    $inner.area.text tag configure error -foreground red \
91        -font [option get $inner.area.text errorFont Font]
92    $inner.area.text tag configure stderr -foreground red \
93        -font [option get $inner.area.text errorFont Font]
94    $inner.area.text tag configure stdout -foreground blue \
95        -font [option get $inner.area.text errorFont Font]
96
97    bind $inner.area.text <KeyPress> \
98        [itcl::code $this command key]
99    bind $inner.area.text <KeyPress-BackSpace> \
100        [itcl::code $this command backspace]
101    bind $inner.area.text <Control-KeyPress-h> \
102        [itcl::code $this command backspace]
103
104    bind $inner.area.text <KeyPress-Return> \
105        [itcl::code $this command execute]
106
107    bind $inner.area.text <KeyPress-Up> \
108        "[itcl::code $this command previous]; break"
109    bind $inner.area.text <Control-KeyPress-p> \
110        "[itcl::code $this command previous]; break"
111
112    bind $inner.area.text <KeyPress-Down> \
113        "[itcl::code $this command next]; break"
114    bind $inner.area.text <Control-KeyPress-n> \
115        "[itcl::code $this command next]; break"
116
117    command prompt
118
119    eval itk_initialize $args
120
121    # this makes it easier to find the magic spot
122    bind $itk_component(hull) <Alt-Enter> [list $itk_component(hull) configure -background $itk_option(-activecolor)]
123    bind $itk_component(hull) <Leave> [list $itk_component(hull) configure -background $itk_option(-background)]
124}
125
126# ----------------------------------------------------------------------
127# DESTRUCTOR
128# ----------------------------------------------------------------------
129itcl::body Rappture::Postern::destructor {} {
130    if {"" != $_afterid} {
131        after cancel $_afterid
132        set _afterid ""
133    }
134}
135
136# ----------------------------------------------------------------------
137# USAGE: active ?on|off?
138#
139# Used to query or set the activation state of this widget.  When
140# the widget is "active", it changes color and accepts the magic
141# pass phrase that will open up the debug panel.  A short delay after
142# being activated, it deactivates itself.
143# ----------------------------------------------------------------------
144itcl::body Rappture::Postern::activate {args} {
145    if {[llength $args] == 0} {
146        return $_active
147    }
148
149    if {"" != $_afterid} {
150        after cancel $_afterid
151        set _afterid ""
152    }
153
154    if {$args} {
155        component hull configure -background $itk_option(-activecolor)
156        set _focus [focus]
157        focus $itk_component(hull)
158        set _active 1
159        set _afterid [after 3000 [itcl::code $this activate off]]
160    } else {
161        focus $_focus
162        set _focus ""
163        component hull configure -background $itk_option(-background)
164
165        if {[info commands _tcl_puts] != ""} {
166            # set puts back to normal
167            rename ::puts ""
168            rename ::_tcl_puts ::puts
169        }
170        set _active 0
171    }
172}
173
174# ----------------------------------------------------------------------
175# USAGE: open
176#
177# Used to open the debug area.  If the widget is active, then the
178# debug area pops up near it.  Otherwise, this method does nothing.
179# ----------------------------------------------------------------------
180itcl::body Rappture::Postern::open {} {
181    if {$_active} {
182        if {"" != $_afterid} {
183            # don't deactivate until we close
184            after cancel $_afterid
185            set _afterid ""
186        }
187
188        $itk_component(hull).popup activate \
189            $itk_component(hull) $itk_option(-popup)
190
191        set text [$itk_component(hull).popup component inner].area.text
192        focus $text
193
194        # make puts send output to this display
195        rename ::puts ::_tcl_puts
196        proc ::puts {args} [format {%s _fake_puts $args} $this]
197    }
198}
199
200itcl::body Rappture::Postern::close {} {
201    $itk_component(hull).popup deactivate
202}
203
204# ----------------------------------------------------------------------
205# USAGE: command prompt
206# USAGE: command execute
207# USAGE: command next
208# USAGE: command previous
209# USAGE: command key
210#
211# Used to handle various editing operations in the text area.
212# ----------------------------------------------------------------------
213itcl::body Rappture::Postern::command {option} {
214    set text [$itk_component(hull).popup component inner].area.text
215
216    switch -- $option {
217        prompt {
218            if {[lindex [split [$text index end-1char] .] 1] != 0} {
219                $text insert end "\n"
220            }
221            $text insert end "% "
222            $text mark set command end-1char
223            $text mark gravity command left
224            $text mark set insert end
225            $text see insert
226        }
227        key {
228            if {[$text compare insert < command]} {
229                $text mark set insert end
230                $text see insert
231            }
232        }
233        backspace {
234            if {[catch {$text index sel.first}] == 0} {
235                if {[$text compare sel.first < command]
236                      || [$text compare sel.last < command]} {
237                    $text tag remove sel 1.0 end
238                }
239            }
240            if {[$text compare insert < command]} {
241                $text mark set insert end
242                $text see insert
243            }
244            if {[$text compare insert == command]} {
245                return -code break  ;# don't erase past start of command
246            }
247        }
248        execute {
249            set cmd [string trim [$text get command end]]
250            if {"" == $cmd} {
251                command prompt
252            } else {
253                lappend _history $cmd
254                if {[llength $_history] > 100} {
255                    set _history [lrange $_history end-100 end]
256                }
257                set _hpos [llength $_history]
258
259                $text insert end "\n"
260                if {[catch {uplevel #0 $cmd} result]} {
261                    $text insert end $result error
262                } else {
263                    $text insert end $result
264                }
265                command prompt
266            }
267            return -code break
268        }
269        next {
270            if {$_hpos < [llength $_history]} {
271                incr _hpos
272                set cmd [lindex $_history $_hpos]
273                $text delete command end
274                $text insert command $cmd
275                $text mark set insert end
276                $text see insert
277            }
278        }
279        previous {
280            if {$_hpos > 0} {
281                incr _hpos -1
282                set cmd [lindex $_history $_hpos]
283                $text delete command end
284                $text insert command $cmd
285                $text mark set insert end
286                $text see insert
287            }
288        }
289        default {
290            error "bad option \"$option\""
291        }
292    }
293}
294
295# ----------------------------------------------------------------------
296# USAGE: _fake_puts {?-nonewline? ?<channel>? <string>}
297#
298# This method acts as a replacement for puts.  It sends output
299# to the postern screen, itstead of stdin/stdout.
300# ----------------------------------------------------------------------
301itcl::body Rappture::Postern::_fake_puts {arglist} {
302    Rappture::getopts arglist params {
303        flag group -nonewline
304    }
305    switch -- [llength $arglist] {
306        1 {
307            set channel stdout
308            set string [lindex $arglist 0]
309        }
310        2 {
311            set channel [lindex $arglist 0]
312            set string [lindex $arglist 1]
313        }
314        default {
315            error "wrong # args: should be \"puts ?-nonewline? ?channel? string\""
316        }
317    }
318
319    set text [$itk_component(hull).popup component inner].area.text
320    if {$channel == "stdout" || $channel == "stderr"} {
321        $text insert end $string $channel
322        if {!$params(-nonewline)} {
323            $text insert end "\n"
324        }
325    } else {
326        eval _tcl_puts $arglist
327    }
328}
329
330# ----------------------------------------------------------------------
331# CONFIGURATION OPTION: -size
332# ----------------------------------------------------------------------
333itcl::configbody Rappture::Postern::size {
334    component hull configure \
335        -width $itk_option(-size) \
336        -height $itk_option(-size)
337}
Note: See TracBrowser for help on using the repository browser.