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

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