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

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