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

Last change on this file since 1444 was 1342, checked in by gah, 15 years ago

preliminary HQ output from molvisviewer; unexpand tabs; all jpeg generation at 100%
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}
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.