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

Last change on this file since 154 was 115, checked in by mmc, 19 years ago

Updated all copyright notices.
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
18blt::bitmap define Postern-dismiss {
19#define dismiss_width 10
20#define dismiss_height 8
21static unsigned char dismiss_bits[] = {
22   0x87, 0x03, 0xce, 0x01, 0xfc, 0x00, 0x78, 0x00, 0x78, 0x00, 0xfc, 0x00,
23   0xce, 0x01, 0x87, 0x03};
24}
25
26option add *Postern.size 2 widgetDefault
27option add *Postern.activeColor gray widgetDefault
28option add *Postern.popup above widgetDefault
29option add *Postern*Text.font \
30    -*-courier-medium-r-normal-*-*-120-* widgetDefault
31option add *Postern*Text.errorFont \
32    -*-courier-medium-o-normal-*-*-120-* widgetDefault
33
34itcl::class Rappture::Postern {
35    inherit itk::Widget
36
37    itk_option define -size size Size 1
38    itk_option define -activecolor activeColor ActiveColor ""
39    itk_option define -popup popup Popup ""
40
41    constructor {args} { # defined below }
42    destructor { # defined below }
43    public method open {}
44    public method close {}
45    public method activate {args}
46    public method command {option}
47
48    public method _fake_puts {args}
49
50    private variable _active 0    ;# true when active and able to open
51    private variable _focus ""    ;# focus before this widget took over
52    private variable _afterid ""  ;# id for after event that clears activate
53
54    private variable _history ""  ;# list of recent commands
55    private variable _hpos 0      ;# current index in _history
56}
57
58itk::usual Postern {
59    keep -cursor -background
60}
61
62# ----------------------------------------------------------------------
63# CONSTRUCTOR
64# ----------------------------------------------------------------------
65itcl::body Rappture::Postern::constructor {args} {
66    global env
67
68    # this sequence gets things started...
69    bind $itk_component(hull) \
70        <Button-1><Button-1><Button-3><Button-3> \
71        [itcl::code $this activate on]
72
73    #
74    # Get the magic word from the environment.
75    #
76    if {[info exists env(RAPPTURE_POSTERN)]} {
77        set event ""
78        foreach letter [split $env(RAPPTURE_POSTERN) ""] {
79            append event "<Key-$letter>"
80        }
81        bind $itk_component(hull) $event [itcl::code $this open]
82    }
83
84    #
85    # Build the debug dialog.
86    #
87    Rappture::Balloon $itk_component(hull).popup \
88        -deactivatecommand [itcl::code $this activate off]
89
90    set inner [$itk_component(hull).popup component inner]
91    set inner [frame $inner.bd -borderwidth 4 -relief flat]
92    pack $inner -expand yes -fill both
93
94    button $inner.dismiss -bitmap Postern-dismiss \
95        -relief flat -overrelief raised \
96        -command [itcl::code $this close]
97    pack $inner.dismiss -anchor e
98
99    Rappture::Scroller $inner.area
100    pack $inner.area -expand yes -fill both
101    text $inner.area.text
102    $inner.area contents $inner.area.text
103
104    $inner.area.text tag configure error -foreground red \
105        -font [option get $inner.area.text errorFont Font]
106    $inner.area.text tag configure stderr -foreground red \
107        -font [option get $inner.area.text errorFont Font]
108    $inner.area.text tag configure stdout -foreground blue \
109        -font [option get $inner.area.text errorFont Font]
110
111    bind $inner.area.text <KeyPress> \
112        [itcl::code $this command key]
113    bind $inner.area.text <KeyPress-BackSpace> \
114        [itcl::code $this command backspace]
115    bind $inner.area.text <Control-KeyPress-h> \
116        [itcl::code $this command backspace]
117
118    bind $inner.area.text <KeyPress-Return> \
119        [itcl::code $this command execute]
120
121    bind $inner.area.text <KeyPress-Up> \
122        "[itcl::code $this command previous]; break"
123    bind $inner.area.text <Control-KeyPress-p> \
124        "[itcl::code $this command previous]; break"
125
126    bind $inner.area.text <KeyPress-Down> \
127        "[itcl::code $this command next]; break"
128    bind $inner.area.text <Control-KeyPress-n> \
129        "[itcl::code $this command next]; break"
130
131    command prompt
132
133    eval itk_initialize $args
134}
135
136# ----------------------------------------------------------------------
137# DESTRUCTOR
138# ----------------------------------------------------------------------
139itcl::body Rappture::Postern::destructor {} {
140    if {"" != $_afterid} {
141        after cancel $_afterid
142        set _afterid ""
143    }
144}
145
146# ----------------------------------------------------------------------
147# USAGE: active ?on|off?
148#
149# Used to query or set the activation state of this widget.  When
150# the widget is "active", it changes color and accepts the magic
151# pass phrase that will open up the debug panel.  A short delay after
152# being activated, it deactivates itself.
153# ----------------------------------------------------------------------
154itcl::body Rappture::Postern::activate {args} {
155    if {[llength $args] == 0} {
156        return $_active
157    }
158
159    if {"" != $_afterid} {
160        after cancel $_afterid
161        set _afterid ""
162    }
163
164    if {$args} {
165        component hull configure -background $itk_option(-activecolor)
166        set _focus [focus]
167        focus $itk_component(hull)
168        set _active 1
169        set _afterid [after 3000 [itcl::code $this activate off]]
170    } else {
171        focus $_focus
172        set _focus ""
173        component hull configure -background $itk_option(-background)
174
175        if {[info commands _tcl_puts] != ""} {
176            # set puts back to normal
177            rename ::puts ""
178            rename ::_tcl_puts ::puts
179        }
180        set _active 0
181    }
182}
183
184# ----------------------------------------------------------------------
185# USAGE: open
186#
187# Used to open the debug area.  If the widget is active, then the
188# debug area pops up near it.  Otherwise, this method does nothing.
189# ----------------------------------------------------------------------
190itcl::body Rappture::Postern::open {} {
191    if {$_active} {
192        if {"" != $_afterid} {
193            # don't deactivate until we close
194            after cancel $_afterid
195            set _afterid ""
196        }
197
198        $itk_component(hull).popup activate \
199            $itk_component(hull) $itk_option(-popup)
200
201        set text [$itk_component(hull).popup component inner].bd.area.text
202        focus $text
203
204        # make puts send output to this display
205        rename ::puts ::_tcl_puts
206        proc ::puts {args} [format {%s _fake_puts $args} $this]
207    }
208}
209
210itcl::body Rappture::Postern::close {} {
211    $itk_component(hull).popup deactivate
212}
213
214# ----------------------------------------------------------------------
215# USAGE: command prompt
216# USAGE: command execute
217# USAGE: command next
218# USAGE: command previous
219# USAGE: command key
220#
221# Used to handle various editing operations in the text area.
222# ----------------------------------------------------------------------
223itcl::body Rappture::Postern::command {option} {
224    set text [$itk_component(hull).popup component inner].bd.area.text
225
226    switch -- $option {
227        prompt {
228            if {[lindex [split [$text index end-1char] .] 1] != 0} {
229                $text insert end "\n"
230            }
231            $text insert end "% "
232            $text mark set command end-1char
233            $text mark gravity command left
234            $text mark set insert end
235            $text see insert
236        }
237        key {
238            if {[$text compare insert < command]} {
239                $text mark set insert end
240                $text see insert
241            }
242        }
243        backspace {
244            if {[catch {$text index sel.first}] == 0} {
245                if {[$text compare sel.first < command]
246                      || [$text compare sel.last < command]} {
247                    $text tag remove sel 1.0 end
248                }
249            }
250            if {[$text compare insert < command]} {
251                $text mark set insert end
252                $text see insert
253            }
254            if {[$text compare insert == command]} {
255                return -code break  ;# don't erase past start of command
256            }
257        }
258        execute {
259            set cmd [string trim [$text get command end]]
260            if {"" == $cmd} {
261                command prompt
262            } else {
263                lappend _history $cmd
264                if {[llength $_history] > 100} {
265                    set _history [lrange $_history end-100 end]
266                }
267                set _hpos [llength $_history]
268
269                $text insert end "\n"
270                if {[catch {uplevel #0 $cmd} result]} {
271                    $text insert end $result error
272                } else {
273                    $text insert end $result
274                }
275                command prompt
276            }
277            return -code break
278        }
279        next {
280            if {$_hpos < [llength $_history]} {
281                incr _hpos
282                set cmd [lindex $_history $_hpos]
283                $text delete command end
284                $text insert command $cmd
285                $text mark set insert end
286                $text see insert
287            }
288        }
289        previous {
290            if {$_hpos > 0} {
291                incr _hpos -1
292                set cmd [lindex $_history $_hpos]
293                $text delete command end
294                $text insert command $cmd
295                $text mark set insert end
296                $text see insert
297            }
298        }
299        default {
300            error "bad option \"$option\""
301        }
302    }
303}
304
305# ----------------------------------------------------------------------
306# USAGE: _fake_puts {?-nonewline? ?<channel>? <string>}
307#
308# This method acts as a replacement for puts.  It sends output
309# to the postern screen, itstead of stdin/stdout.
310# ----------------------------------------------------------------------
311itcl::body Rappture::Postern::_fake_puts {arglist} {
312    Rappture::getopts arglist params {
313        flag group -nonewline
314    }
315    switch -- [llength $arglist] {
316        1 {
317            set channel stdout
318            set string [lindex $arglist 0]
319        }
320        2 {
321            set channel [lindex $arglist 0]
322            set string [lindex $arglist 1]
323        }
324        default {
325            error "wrong # args: should be \"puts ?-nonewline? ?channel? string\""
326        }
327    }
328
329    set text [$itk_component(hull).popup component inner].bd.area.text
330    if {$channel == "stdout" || $channel == "stderr"} {
331        $text insert end $string $channel
332        if {!$params(-nonewline)} {
333            $text insert end "\n"
334        }
335    } else {
336        eval _tcl_puts $arglist
337    }
338}
339
340# ----------------------------------------------------------------------
341# CONFIGURATION OPTION: -size
342# ----------------------------------------------------------------------
343itcl::configbody Rappture::Postern::size {
344    component hull configure \
345        -width $itk_option(-size) \
346        -height $itk_option(-size)
347}
Note: See TracBrowser for help on using the repository browser.