Adding error message when shmat fails - naim
[dyninst.git] / paradyn / tcl / status.tcl
1 #
2 # status.tcl
3 #
4 # status line configuration variables and associated commands.
5 # C++ status lines can be used after proper initialization.
6 # check `UIthread/UImain.C' for details.
7 #
8
9 set status_parent         .parent.status
10 set status_title_fg       black
11 set status_title_font     8x13bold
12 set status_mesg_font      8x13
13 set status_mesg_fg_normal blue
14 set status_mesg_fg_urgent red
15
16
17 #
18 # status_create id title
19 #
20 # create a status line object, to be named by the integer id `id' and
21 # having title `title'.  it is assumed that the title is formatted
22 # to an appropriate constant width.  a `: ' is appended to all title
23 # names before the status message is printed.
24 #
25
26 proc status_create {id title} {
27     global status_parent
28     set widget $status_parent.status_$id
29     set tag    status_tag_$id
30     set mark   status_mark_$id
31
32     text $widget -relief raised
33
34     $widget insert end " $title:"
35
36     set tmark [expr [string length $title] + 1]
37
38     $widget tag  add $tag  1.0 1.$tmark
39     $widget mark set $mark     1.$tmark
40
41     global status_title_fg
42     global status_title_font
43     global status_mesg_font
44     global status_mesg_fg_normal
45
46     wm geometry . {}
47
48     $widget tag configure $tag       \
49         -foreground $status_title_fg \
50         -font       $status_title_font
51     $widget configure                      \
52         -foreground $status_mesg_fg_normal \
53         -font       $status_mesg_font      \
54         -height     1                      \
55         -wrap       none                   \
56         -state      disabled \
57         -highlightthickness 0 \
58         -borderwidth 1
59        # the default borderwidth is a much larger number
60
61     pack $widget -in $status_parent -side top -fill x
62
63     update
64     #
65     # Need to use  "update" commands sparingly because they
66     # seem to produce a problem (or make it worse as Ari mentioned) when  
67     # the user "grab" the main window for long enough, making some widgets
68     # "invisibles" (e.g. status line). We also had to add the command
69     # wm geometry . {} because the previous solution does not always 
70     # work. It just reduces the interval of time when the user could
71     # grab the main window and affect the display of the widgets (i.e.
72     # it makes the height so small that we cannot see the widget on the
73     # screen. That is why we set this value again). Any better solution
74     # will be welcome! - naim
75     #
76 }
77
78
79 #
80 # status_message id message
81 #
82 # make `message' the new message in status line with id `id'.
83 # the status line must already exist.
84 #
85
86 proc status_message {id message} {
87     global status_parent
88     set widget $status_parent.status_$id
89     set tag    status_tag_$id
90     set mark   status_mark_$id
91
92     $widget configure -state normal
93     $widget delete [list $mark +1 chars] end
94     $widget insert end $message
95     $widget configure -state disabled
96
97     # The paradyn UI freezes when starting paradynd and at other times.
98     # At such times, it is advantageous for us to ensure that every
99     # status line is updated before the freeze.  When paradyn stops freezing,
100     # we can remove this line, which slows things down quite a bit.
101     #update
102 }
103
104
105 #
106 # status_state id urgent
107 #
108 # set the state of status line `id' based on the boolean flag `urgent'
109 #
110
111 proc status_state {id urgent} {
112     global status_parent
113     set widget $status_parent.status_$id
114     set tag    status_tag_$id
115     set mark   status_mark_$id
116
117     global status_mesg_fg_normal
118     global status_mesg_fg_urgent
119
120     if $urgent {
121         $widget configure -foreground $status_mesg_fg_urgent
122     } {
123         $widget configure -foreground $status_mesg_fg_normal
124     }
125     
126     # See the argument in the above routine...
127     update
128 }
129
130
131 #
132 # status_destroy id
133 #
134 # destroy status line with id `id'.  all associated resources
135 # are released
136 #
137
138 proc status_destroy {id} {
139     global status_parent
140     set widget $status_parent.status_$id
141     set tag    status_tag_$id
142     set mark   status_mark_$id
143
144     destroy $widget
145     #update
146 }