*** empty log message ***
[dyninst.git] / paradyn / tcl / status.tcl
1 # $Id: status.tcl,v 1.7 1998/05/20 19:55:31 wylie Exp $
2 #
3 # status line configuration variables and associated commands.
4 # C++ status lines can be used after proper initialization.
5 # check `UIthread/UImain.C' for details.
6 #
7
8 set status_parent_g      .parent.status                 ;# generic status lines
9 set status_parent_p      .parent.procstatus.canvas.f    ;# process status lines
10 set procstatus_parent    .parent.procstatus
11
12 set status_title_fg       black
13 set status_title_font     { Courier 10 bold }    ;# 8x13bold
14 set status_mesg_font      { Courier 10 normal }  ;# 8x13
15 set status_mesg_fg_normal blue
16 set status_mesg_fg_urgent red
17
18 set indent_chars   3    ;# indentation of process status lines to fit scrollbar
19 set min_processes  3    ;# minimum reasonable displayed scrollable lines
20 set max_processes  4    ;# default maximum displayed lines (adjusts on resize!)
21 set num_processes  0    ;# current number of process status lines
22
23
24 # ProcCanvasResize %h
25 #
26 # should be bound to canvas Configure events such that it provides the new
27 # height whenever the canvas (window) resized, allowing a calculation of
28 # the appropriate number of process status lines to display (or scroll)
29 # and tidy-up the window height so that only entire lines are shown.
30 # The limit min_processes ensures that the canvas (scrollbar) doesn't get too
31 # small, whereas max_processes controls when to show the scrollbar
32 # (and this variable adjusts according to explicit window resize actions).
33 # Recalculating things explicitly, the height value provided is not used.
34 #
35
36 proc ProcCanvasResize {height} {
37     global num_processes min_processes max_processes
38     global procstatus_canvas procstatus_container
39
40     set curr_height [ expr [ winfo height $procstatus_canvas ] - 2 ]
41     set canv_height [ winfo reqheight $procstatus_container ]
42     set bbox [ grid bbox $procstatus_container 0 0 ]
43     set incr [ lindex $bbox 3 ]
44     if { $incr == 0 } { return }
45     set curr_lines [ expr $canv_height / $incr ]
46     set drawable_lines [ expr round (double ($curr_height) / $incr) ]
47     set draw_height [ expr $incr * $drawable_lines ]
48
49 #   puts stderr "Heights: Canvas=$canv_height, Window=$curr_height, Drawable=$draw_height"
50 #   puts stderr "#procs=$num_processes, #drawn=$curr_lines, #drawable=$drawable_lines"
51
52     if { $drawable_lines > $max_processes } {
53         # set max_processes to number drawable in explicitly enlarged window
54 #       puts stderr "Max_processes: $max_processes->$drawable_lines (+)"
55         set max_processes $drawable_lines
56     }
57
58     if { $drawable_lines < $min_processes } {
59         # fix-up resizes which would be too small (to scroll effectively)
60 #       puts stderr "Drawable_lines: $drawable_lines->$min_processes"
61         set drawable_lines $min_processes
62     } else {
63         if { ($drawable_lines < $max_processes) && 
64              ($curr_lines > $drawable_lines) } {
65             # set max_processes to number drawable in explicitly shrunk window
66 #           puts stderr "Max_processes: $max_processes->$drawable_lines (-)"
67             set max_processes $drawable_lines
68         }
69     }
70
71     set disp_lines $num_processes       ;# initialize to reasonable default
72
73     if { $num_processes > $min_processes } {
74         set disp_lines $drawable_lines
75 #       puts stderr "Modify display to current drawable_lines=$disp_lines"
76     }
77
78     if { $disp_lines > $num_processes } {
79         set disp_lines $num_processes
80 #       puts stderr "Truncate display to current num_processes=$disp_lines"
81     }
82
83     set disp_height [ expr $incr * $disp_lines ]
84
85     if { $disp_height != $curr_height } {
86 #       puts stderr "ProcCanvasResize from ${curr_height}($curr_lines) to ${disp_height}($disp_lines)"
87         $procstatus_canvas config -height $disp_height
88         wm geometry . {}        ;# no idea why this is necessary!
89     }
90
91 }
92
93 #
94 # ProcCanvasScroll offset size
95 #
96 # called whenever the canvas view changes by scrolling or resizing, enables
97 # a decision on whether to actually display the scrollbar or its placeholder.
98 # Since the scrollbar/placeholder and canvas need to be re-packed on a switch
99 # (to ensure that they remain correctly left-packed and the canvas (text) is 
100 # right-truncated) and this can be expensive (for large/complex canvases) the
101 # scrollbarVisible state variable is also needed.
102 #
103
104 proc ProcCanvasScroll {offset size} {
105     global num_processes min_processes max_processes
106     global procstatus_canvas procstatus_scrollbar procstatus_placeholder
107     global scrollbarVisible 
108     # puts stderr "ProcCanvasScroll ($offset,$size) #p=$num_processes/$max_processes"
109
110     if { ($num_processes > $max_processes) &&
111          ($offset != 0.0 || $size != 1.0) } {
112         if { $scrollbarVisible } {
113             # puts stderr "showing scrollbar (skipped)"
114         } else {
115             # puts stderr "showing scrollbar..."
116             pack forget $procstatus_canvas              ;# temporarily
117             pack forget $procstatus_placeholder         ;# hide it
118             pack $procstatus_scrollbar -side left -fill y
119             pack $procstatus_canvas -side left -fill both -expand true
120             set scrollbarVisible true
121         }
122         $procstatus_scrollbar set $offset $size
123     } else {
124         if { $scrollbarVisible } {
125             # puts stderr "hiding scrollbar..."
126             pack forget $procstatus_canvas              ;# temporarily
127             pack forget $procstatus_scrollbar           ;# hide it
128             pack $procstatus_placeholder -side left -fill y
129             pack $procstatus_canvas -side left -fill both -expand true
130             set scrollbarVisible false
131         } else {
132             # puts stderr "hiding scrollbar (skipped)"
133         }
134     }
135 }
136
137 #
138 # ProcCanvasCreate frame_widget
139 #
140 # creates a new canvas with (vertical) scrollbar for the process status lines,
141 # with the scrollbar replaced with a placeholder (of equivalent size) when
142 # less than a reasonable number of lines are present.  Note that the size of
143 # the scrollbar (and placeholder) have been chosen to match the status text
144 # font, such that they occupy $indent_chars (of the process status line title)
145 # and ensure that the message text is reasonably aligned.
146 #
147
148 proc ProcCanvasCreate { procstatus } {
149     global procstatus_canvas procstatus_container
150     global procstatus_scrollbar procstatus_placeholder scrollbarVisible
151     global status_title_font indent_chars
152     set procstatus_canvas $procstatus.canvas
153     set procstatus_container $procstatus_canvas.f
154     set procstatus_scrollbar $procstatus.scrollbar
155     set procstatus_placeholder $procstatus.placeholder
156     set scrollbarVisible false
157
158     #puts stderr "ProcCanvasCreate..."
159     set ch_width [font measure $status_title_font "X"]
160     set indwidth [expr $ch_width * $indent_chars - 2]
161     set barwidth [expr $indwidth - 6]
162
163     frame $procstatus_placeholder -width $indwidth -background DimGray
164     scrollbar $procstatus_scrollbar -orient vertical -width $barwidth \
165         -command [ list $procstatus_canvas yview ]
166     canvas $procstatus_canvas -height 0 -yscrollcommand "ProcCanvasScroll"
167     pack $procstatus_placeholder -side left -fill y
168     pack $procstatus_scrollbar -side left -fill y
169     pack forget $procstatus_scrollbar           ;# hide the scrollbar for now
170     pack $procstatus_canvas -side left -fill both -expand true
171     pack $procstatus -fill both -expand true
172
173     frame $procstatus_container
174     $procstatus_canvas create window 0 0 -anchor nw \
175         -window $procstatus_container
176
177     # ensure that window "resize" events are caught and handled appropriately
178     bind $procstatus_canvas <Configure> { ProcCanvasResize %h }
179 }
180
181 #
182 # status_create type id title
183 #
184 # create a status line object, referenced by `type' and integer id `id' and
185 # having title `title'.  `type' is "g" for generic status lines and "p" for
186 # process status lines which are to appear in a separate scrollable canvas.
187 # It is assumed that the title is formatted to an appropriate constant width.
188 # A `: ' is appended to all title names before the status message is printed.
189 # Process titles are truncated by $indent_chars to allow for the scrollbar.
190 #
191
192 proc status_create {type id title} {
193
194 #   puts stderr "status_create ($type, $id, $title)"
195
196     global procstatus_parent
197     global indent_chars
198     global num_processes min_processes max_processes
199     if { $type == "p" && $num_processes == 0 } { 
200         # create separate canvas for process status list
201         ProcCanvasCreate $procstatus_parent
202     }
203
204     global status_parent_g
205     global status_parent_p              ;# NB: process canvas must exist!
206
207     set parent [set status_parent_$type]
208     set widget $parent.status_$id
209
210     set tag    status_tag_$type$id
211     set mark   status_mark_$type$id
212
213     text $widget -relief raised -padx 4
214
215     set titlelen [ string length $title ]
216
217     if { $type == "p" } {
218         incr num_processes
219         $widget config -width 200       ;# wide width to be truncated when drawn
220         # uncompromisingly strip last three characters from title string 
221         # corresponding to the width of the additional process canvas scrollbar
222         set title [ string range $title 0 [ expr $titlelen-$indent_chars-1 ] ]
223     }
224
225     $widget insert end "$title: "
226     set tmark [expr [string length $title] + 1]
227
228     $widget tag  add $tag  1.0 1.$tmark
229     $widget mark set $mark     1.$tmark
230
231     global status_title_fg
232     global status_title_font
233     global status_mesg_font
234     global status_mesg_fg_normal
235
236     wm geometry . {}
237
238     $widget tag configure $tag       \
239         -foreground $status_title_fg \
240         -font       $status_title_font
241     $widget configure                      \
242         -foreground $status_mesg_fg_normal \
243         -font       $status_mesg_font      \
244         -height     1                      \
245         -wrap       none                   \
246         -state      disabled \
247         -highlightthickness 0 \
248         -borderwidth 1
249        # the default borderwidth is a much larger number
250
251     if { $type == "p" } {
252         global procstatus_canvas        ;# $parent = $procstatus_container
253         grid $widget -in $parent -sticky we
254         # reconfigure the canvas to take account of the new addition
255         tkwait visibility $widget
256         set bbox [ grid bbox $parent 0 0 ]
257         set incr [ lindex $bbox 3 ]
258         set reqwidth [ winfo reqwidth $parent ]
259         set reqheight [ winfo reqheight $parent ]
260         $procstatus_canvas config -scrollregion "0 0 $reqwidth $reqheight"
261         $procstatus_canvas config -yscrollincrement $incr
262         # expand the process canvas to show our new addition,
263         # ... truncating at our desired maximum size
264         set new_proc $num_processes
265         if { $new_proc > $max_processes } { set new_proc $max_processes }
266         set height [ expr $incr * $new_proc ]
267         $procstatus_canvas config -height $height
268         if { $num_processes > $max_processes } {
269             # currently scrolling (or soon will be) therefore let's
270             # scroll down the canvas to show the newly added line
271             $procstatus_canvas yview moveto 1.0
272         }
273     } else {
274         pack $widget -in $parent -side top -fill x
275     }
276
277     update
278     #
279     # Need to use  "update" commands sparingly because they
280     # seem to produce a problem (or make it worse as Ari mentioned) when  
281     # the user "grab" the main window for long enough, making some widgets
282     # "invisibles" (e.g. status line). We also had to add the command
283     # wm geometry . {} because the previous solution does not always 
284     # work. It just reduces the interval of time when the user could
285     # grab the main window and affect the display of the widgets (i.e.
286     # it makes the height so small that we cannot see the widget on the
287     # screen. That is why we set this value again). Any better solution
288     # will be welcome! - naim
289     #
290 }
291
292
293 #
294 # status_message type id message
295 #
296 # make `message' the new text in status line `type'.`id'.
297 # the status line must already exist.
298 #
299
300 proc status_message {type id message} {
301     global status_parent_g
302     global status_parent_p
303
304     set parent [set status_parent_$type]
305     set widget $parent.status_$id
306     set tag    status_tag_$type$id
307     set mark   status_mark_$type$id
308
309     $widget configure -state normal
310     $widget delete [list $mark +1 chars] end
311     $widget insert end $message
312     $widget configure -state disabled
313
314     # The paradyn UI freezes when starting paradynd and at other times.
315     # At such times, it is advantageous for us to ensure that every
316     # status line is updated before the freeze.  When paradyn stops freezing,
317     # we can remove this line, which slows things down quite a bit.
318     #update
319 }
320
321
322 #
323 # status_state type id urgent
324 #
325 # set the state of status line `type'.`id' based on the boolean flag `urgent'
326 #
327
328 proc status_state {type id urgent} {
329     global status_parent_g
330     global status_parent_p
331
332     set parent [set status_parent_$type]
333     set widget $parent.status_$id
334
335     global status_mesg_fg_normal
336     global status_mesg_fg_urgent
337
338     if $urgent {
339         $widget configure -foreground $status_mesg_fg_urgent
340     } {
341         $widget configure -foreground $status_mesg_fg_normal
342     }
343     
344     # See the argument in the above routine...
345     update
346 }
347
348
349 #
350 # status_destroy type id
351 #
352 # destroy status line `type'.`id' and release associated resources
353 #
354
355 proc status_destroy {type id} {
356     global status_parent_g
357     global status_parent_p
358
359     global num_processes
360
361     set parent [set status_parent_$type]
362     set widget $parent.status_$id
363
364     destroy $widget
365     incr num_processes -1
366     if { $num_processes == 0 } { 
367         puts stderr "Unpacking procframe: #p=$num_processes"
368         pack forget .parent.procstatus
369     }
370
371     #update
372 }