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

Last change on this file since 742 was 676, checked in by mmc, 17 years ago

Fixed all fonts to set pixelsize instead of pointsize, so that fonts in
the latest X distribution look right.

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