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

Last change on this file since 3177 was 3177, checked in by mmc, 12 years ago

Updated all of the copyright notices to reference the transfer to
the new HUBzero Foundation, LLC.
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-2012  HUBzero Foundation, LLC
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 tcl_platform
59
60    # this sequence gets things started...
61    if {$tcl_platform(os) == "Darwin"} {
62        # this works better on the Mac
63        bind $itk_component(hull) <Control-Button-1><Control-Button-1> \
64            [itcl::code $this activate on]
65    } else {
66        bind $itk_component(hull) <Button-1><Button-1><Button-3><Button-3> \
67            [itcl::code $this activate on]
68    }
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.