Adding error message when shmat fails - naim
[dyninst.git] / paradyn / tcl / shg.tcl
1 # shg.tcl
2 # Ariel Tamches
3
4 #
5 # $Log: shg.tcl,v $
6 # Revision 1.15  1996/04/01 22:35:57  tamches
7 # fixed colors of the information text widget s.t. selecting a piece of
8 # text is readable
9 #
10 # Revision 1.14  1996/03/25 21:50:33  tamches
11 # fixed some layout bugs w.r.t. shg-key & shg-tips
12 #
13 # Revision 1.13  1996/03/08 00:24:42  tamches
14 # added 2d entry point
15 #
16 # Revision 1.12  1996/02/15 23:04:52  tamches
17 # shgInitialize puts up error 88 if an appl hasn't been defined yet.
18
19 #
20 # Revision 1.11  1996/02/12 18:32:07  tamches
21 # shgInitialize now takes 3 params
22 #
23 # Revision 1.10  1996/02/11 18:28:26  tamches
24 # "Current Phase" --> "Current Search"
25 #
26 # Revision 1.9  1996/02/07 19:16:30  tamches
27 # removed shgHack
28 #
29 # Revision 1.8  1996/02/02 18:57:22  tamches
30 # added key & tips areas
31 # cleaner search/resume button code
32 # no more "paradyn shg start global" in window startup
33 #
34 # Revision 1.7  1996/01/23 07:14:30  tamches
35 # now 7 eval states, divided among 4 eval states & an active flag
36 #
37 # Revision 1.6  1996/01/11 23:43:49  tamches
38 # there are now 6 node styles instead of 4
39 #
40 # Revision 1.5  1996/01/11 00:53:59  tamches
41 # removed resize1ScrollBar (now in generic.tcl)
42 # removed iconify menu
43 #
44 # Revision 1.4  1996/01/09 01:09:00  tamches
45 # the label area at the bottom of the shg window can now be 1 or
46 # 4 lines in height, depending on the status of the devel mode tc
47 #
48 # Revision 1.3  1995/11/29 00:21:56  tamches
49 # removed refs to PdBitmapDir; we now call makeLogo (pdLogo.C)
50 #
51 # Revision 1.2  1995/11/20 04:06:02  tamches
52 # fixed activeBackground/activeForeground colors that were making for ugly
53 # menu highlighting.
54 #
55 # Revision 1.1  1995/10/17 22:25:14  tamches
56 # First version of new search history graph
57 #
58 #
59
60 proc shgChangeCurrLabelHeight {numlines} {
61    if {[winfo exists .shg.nontop.labelarea.current]} {
62       .shg.nontop.labelarea.current config -height $numlines
63       pack .shg.nontop.labelarea.current -side left -fill both -expand true
64    }
65 }
66
67 proc redrawKeyAndTipsAreas {drawkeychange drawtipschange} {
68    if {![winfo exists .shg]} {
69       return
70    }
71
72    set keyArea .shg.nontop.keyarea
73    set tipArea .shg.nontop.tiparea
74
75    set keyIsUp [winfo exists $keyArea.left]
76    set tipsAreUp [winfo exists $tipArea.tip0]
77
78    set drawKey false
79    if {$drawkeychange=="on"} {
80       set drawKey true
81    }
82    if {$drawkeychange=="nc" && $keyIsUp} {
83       set drawKey true
84    }
85  
86    set drawTips false
87    if {$drawtipschange=="on"} {
88       set drawTips true
89    }
90    if {$drawtipschange=="nc" && $tipsAreUp} {
91       set drawTips true
92    }
93
94    # Note: the following can be optimized for a single case:
95    # if the key was already up and is staying up, then don't erase & redraw it:
96    set dontTouchTheKey 0
97    if {$keyIsUp && $drawkeychange=="nc"} {
98       set dontTouchTheKey 1
99    }
100
101    # erase em both; important to erase the key first so its base is redrawn first
102    # (i.e. above the base window for tips)!
103    # The following routines will erase and then redraw the respective bases:
104
105    if {!$dontTouchTheKey} {
106       shgDrawKeyBase
107    }
108    shgDrawTipsBase
109
110    # and redraw, as appropriate
111    if {$drawKey} {
112       if {! $dontTouchTheKey} {
113           shgDrawKey
114       }
115    }
116
117    if {$drawTips} {
118       shgDrawTips
119    }
120 }
121
122 proc shgDrawKeyBase {} {
123    # Erases (if necessary) and redraws the base
124    set keyArea .shg.nontop.keyarea
125    if {[winfo exists $keyArea]} {
126        destroy $keyArea
127    }
128
129    frame $keyArea
130    pack  $keyArea -side top -fill both
131 }
132
133 proc shgDrawKey {} {
134    set leftLabels ".shg.nontop.keyarea.left"
135    set rightLabels ".shg.nontop.keyarea.right"
136
137    frame $leftLabels 
138    pack  $leftLabels -side left -fill both -expand true
139
140    frame $rightLabels 
141    pack  $rightLabels -side right -fill both -expand true
142
143    label $leftLabels.key0 -relief groove \
144            -text "Never Evaluated" -anchor c \
145            -font "*-Helvetica-*-r-*-12-*" \
146            -background grey
147    pack   $leftLabels.key0 -side top -fill x -expand false
148
149    label $leftLabels.key1 -relief groove \
150            -text "Unknown" -anchor c \
151            -font "*-Helvetica-*-r-*-12-*" \
152            -background #60c0a0
153            # a nice green...
154    pack   $leftLabels.key1 -side top -fill x -expand false
155 #          -background "#e9fbb57aa3c9"
156
157    label $leftLabels.key2 -relief groove \
158            -text "True" -anchor c \
159            -font "*-Helvetica-*-r-*-12-*" \
160            -background cornflowerblue
161 #          -background "#acbff48ff6c8"
162                 # yuck --ari
163    pack   $leftLabels.key2 -side top -fill x -expand false
164
165    label $leftLabels.key3 -relief groove \
166            -text "False" -anchor c \
167            -font "*-Helvetica-*-r-*-12-*" \
168            -background pink
169 #          -background "#cc85d5c2777d" 
170                 # yuck --ari
171    pack   $leftLabels.key3 -side top -fill x -expand false
172
173    frame $leftLabels.key4 -relief groove -borderwidth 2
174    pack  $leftLabels.key4 -side top -fill x -expand false
175
176    canvas $leftLabels.key4.canvas -height 20 -width 90 -relief flat -highlightthickness 0
177    pack   $leftLabels.key4.canvas -side left -fill y -expand false
178    $leftLabels.key4.canvas create line 10 5  80 15 \
179            -fill palegoldenrod -width 2
180
181    label  $leftLabels.key4.label -relief flat \
182            -text "Why Axis Refinement" -anchor c \
183            -font "*-Helvetica-*-r-*-12-*"
184    pack   $leftLabels.key4.label -side right -fill y -expand true
185
186
187
188    label $rightLabels.key0 -relief groove \
189            -font "*-Helvetica-*-r-*-12-*" \
190            -text "instrumented" \
191            -foreground ivory \
192            -background gray
193    pack  $rightLabels.key0 -side top -fill x
194
195    label $rightLabels.key1 -relief groove \
196            -font "*-Helvetica-*-r-*-12-*" \
197            -text "uninstrumented" \
198            -foreground black \
199            -background gray
200    pack  $rightLabels.key1 -side top -fill x
201
202    label $rightLabels.key2 -relief groove \
203            -font "*-Helvetica-*-o-*-12-*" \
204            -text "instrumented; shadow node" \
205            -foreground ivory \
206            -background gray
207    pack  $rightLabels.key2 -side top -fill x
208
209    label $rightLabels.key3 -relief groove \
210            -font "*-Helvetica-*-o-*-12-*" \
211            -text "uninstrumented; shadow node" \
212            -foreground black \
213            -background gray
214    pack  $rightLabels.key3 -side top -fill x
215
216    frame $rightLabels.key4 -relief groove -borderwidth 2
217    pack  $rightLabels.key4 -side top -fill x -expand false
218
219    canvas $rightLabels.key4.canvas -height 20 -width 90 -relief flat -highlightthickness 0
220    pack   $rightLabels.key4.canvas -side left -fill y -expand false
221    $rightLabels.key4.canvas create line 10 5  80 15 \
222            -fill orchid -width 2
223
224    label  $rightLabels.key4.label -relief flat \
225            -text "Where Axis Refinement" -anchor c \
226            -font "*-Helvetica-*-r-*-12-*"
227    pack   $rightLabels.key4.label -side right -fill y -expand true
228
229 }
230
231 # ####################################################################
232
233 proc shgDrawTipsBase {} {
234    # Erases (if necessary) and redraws the base
235    set tipArea .shg.nontop.tiparea
236    if {[winfo exists $tipArea]} {
237        destroy $tipArea
238    }
239
240    frame $tipArea
241    pack  $tipArea -side top -fill x
242 }
243
244 proc shgDrawTips {} {
245    set tipArea .shg.nontop.tiparea
246
247    label $tipArea.tip0 -relief groove \
248            -text "Hold down Alt and move the mouse to scroll freely" \
249            -font "*-Helvetica-*-r-*-12-*"
250    pack $tipArea.tip0 -side top -fill both
251       # fill both prevents shrinking when window is made shorter
252
253    label $tipArea.tip1 -relief groove \
254            -text "Click middle button on a node to obtain more info on it" \
255            -font "*-Helvetica-*-r-*-12-*"
256    pack $tipArea.tip1 -side top -fill both
257       # fill both prevents shrinking when window is made shorter
258
259 }
260
261 # ####################################################################
262
263 proc shgClickOnSearch {} {
264    set buttonarea .shg.nontop.buttonarea
265    if {[shgSearchCommand]} {
266       $buttonarea.left.search config -state disabled -text "Resume"
267       $buttonarea.middle.pause config -state normal
268    }
269 }
270
271 proc shgClickOnPause {} {
272    set buttonarea .shg.nontop.buttonarea
273    if {[shgPauseCommand]} {
274       $buttonarea.left.search config -state normal
275       $buttonarea.middle.pause config -state disabled
276    }
277 }
278
279 # ####################################################################
280
281 proc shgInitialize {iDeveloperMode iDrawKey iDrawTips} {
282    # paradyn's entry point should be here; the shg test program
283    # will call shgInitialize2 directly, since the paradyn command (next line)
284    # would bomb it
285    if {![paradyn applicationDefined]} {
286       # No application has been started yet!!!
287       # Put up an error dialog:
288       showError 88 {}
289       return
290    }
291
292    return [shgInitialize2 $iDeveloperMode $iDrawKey $iDrawTips]
293 }
294
295 proc shgInitialize2 {iDeveloperMode iDrawKey iDrawTips} {
296    if {[winfo exists .shg]} {
297 #      puts stderr "(shg window already exists; not creating)"
298       wm deiconify .shg
299       raise .shg
300       return
301    }
302
303    toplevel .shg -class "Shg"
304    option add *shg*Background grey
305    option add *shg*activeBackground LightGrey
306    option add *shg*activeForeground black
307    wm protocol .shg WM_DELETE_WINDOW {wm iconify .shg}
308
309    # area for title, menubar, logo
310    frame .shg.titlearea
311    pack  .shg.titlearea -side top -fill x -expand false -anchor n
312
313    frame .shg.titlearea.right
314    pack  .shg.titlearea.right -side right -fill y -expand false
315
316    makeLogo .shg.titlearea.right.logo paradynLogo raised 2 mediumseagreen
317    pack  .shg.titlearea.right.logo -side top
318
319    frame .shg.titlearea.left
320    pack  .shg.titlearea.left -side left -fill both -expand true
321
322    label .shg.titlearea.left.title -text "The Performance Consultant" \
323            -foreground white -anchor c \
324            -font *-New*Century*Schoolbook-Bold-R-*-14-* \
325            -relief raised \
326            -background mediumseagreen
327    pack  .shg.titlearea.left.title -side top -fill both -expand true
328
329    # area for menubar:
330    frame .shg.titlearea.left.menu
331    pack  .shg.titlearea.left.menu -side top -fill x -expand false -anchor n
332
333    frame .shg.titlearea.left.menu.mbar -borderwidth 2 -relief raised
334    pack  .shg.titlearea.left.menu.mbar -side top -fill both -expand false
335
336    menubutton .shg.titlearea.left.menu.mbar.phase -text Searches -menu .shg.titlearea.left.menu.mbar.phase.m
337    menu .shg.titlearea.left.menu.mbar.phase.m -selectcolor cornflowerblue
338
339    pack .shg.titlearea.left.menu.mbar.phase -side left -padx 4
340
341    # -----------------------------------------------------------
342
343    frame .shg.nontop
344    pack  .shg.nontop -side bottom -fill both -expand true
345
346    # -----------------------------------------------------------
347
348    frame .shg.nontop.currphasearea
349    pack  .shg.nontop.currphasearea -side top -fill x -expand false
350
351    label .shg.nontop.currphasearea.label1 -text "Current Search: " \
352            -font "*-Helvetica-*-r-*-12-*" -anchor e
353    pack  .shg.nontop.currphasearea.label1 -side left -fill both -expand true
354
355    label .shg.nontop.currphasearea.label2 -text "" \
356            -font "*-Helvetica-*-r-*-12-*" -anchor w
357    pack  .shg.nontop.currphasearea.label2 -side left -fill both -expand true
358
359    # -----------------------------------------------------------
360
361    frame .shg.nontop.textarea
362    pack  .shg.nontop.textarea -side top -fill x -expand false
363
364    text .shg.nontop.textarea.text -borderwidth 2 -width 40 -height 5 -relief sunken \
365            -font "*-Helvetica-*-r-*-12-*" \
366            -yscrollcommand ".shg.nontop.textarea.sb set" \
367            -selectbackground black
368    pack .shg.nontop.textarea.text -side left -fill both -expand true
369
370    scrollbar .shg.nontop.textarea.sb -relief sunken \
371            -command ".shg.nontop.textarea.text yview"
372    pack .shg.nontop.textarea.sb -side right -fill y -expand false
373
374    # -----------------------------------------------------------
375
376    frame .shg.nontop.main -width 4i -height 3.5i
377    pack  .shg.nontop.main -side top -fill both -expand true
378
379    scrollbar .shg.nontop.main.leftsb -orient vertical -width 16 \
380            -background gray \
381            -activebackground gray \
382            -command "shgNewVertScrollPosition"
383
384    pack .shg.nontop.main.leftsb -side left -fill y -expand false
385
386    scrollbar .shg.nontop.main.bottsb -orient horizontal -width 16 \
387         -activebackground gray \
388         -command "shgNewHorizScrollPosition"
389
390    pack .shg.nontop.main.bottsb -side bottom -fill x -expand false
391
392    frame .shg.nontop.main.all -relief flat -width 3i -height 2i
393    pack .shg.nontop.main.all -side left -fill both -expand true
394
395    # -----------------------------------------------------------
396
397    frame .shg.nontop.labelarea
398    pack  .shg.nontop.labelarea -side top -fill x -expand false
399
400    text .shg.nontop.labelarea.current -relief sunken -height 1 \
401            -font "*-Helvetica-*-r-*-12-*" \
402            -wrap none
403    if {$iDeveloperMode} {
404       set numlines 4
405    } else {
406       set numlines 1
407    }
408    shgChangeCurrLabelHeight $numlines
409
410    # -----------------------------------------------------------
411
412    frame .shg.nontop.buttonarea
413    pack  .shg.nontop.buttonarea -side top -fill x -expand false
414
415    frame .shg.nontop.buttonarea.left
416    pack  .shg.nontop.buttonarea.left -side left -fill y -expand true
417
418    # Note: the search button doubles as a "Resume" button when appropriate
419    button .shg.nontop.buttonarea.left.search -text "Search" -anchor c \
420            -command shgClickOnSearch
421    pack   .shg.nontop.buttonarea.left.search -side left -ipadx 10 -fill y -expand false
422
423    frame .shg.nontop.buttonarea.middle
424    pack  .shg.nontop.buttonarea.middle -side left -fill y -expand true
425
426    button .shg.nontop.buttonarea.middle.pause -text "Pause" -state disabled -anchor c \
427            -command shgClickOnPause
428    pack   .shg.nontop.buttonarea.middle.pause -side left -fill y -expand false
429
430    # -----------------------------------------------------------
431
432    shgDrawKeyBase
433    if {$iDrawKey} {
434       shgDrawKey
435    }
436
437    shgDrawTipsBase
438    if {$iDrawTips} {
439       shgDrawTips
440    }
441
442    # -----------------------------------------------------------
443
444    bind .shg.nontop.main.all <Configure> {shgConfigureHook}
445    bind .shg.nontop.main.all <Expose>    {shgExposeHook %c}
446    bind .shg.nontop.main.all <Button-1>  {shgSingleClickHook %x %y}
447    bind .shg.nontop.main.all <Button-2>  {shgMiddleClickHook %x %y}
448    bind .shg.nontop.main.all <Double-Button-1> {shgDoubleClickHook %x %y}
449 #   bind .shg.nontop.main.all <Shift-Double-Button-1> {shgShiftDoubleClickHook %x %y}
450 #   bind .shg.nontop.main.all <Control-Double-Button-1> {shgCtrlDoubleClickHook %x %y}
451    bind .shg.nontop.main.all <Alt-Motion> {shgAltPressHook %x %y}
452    bind .shg.nontop.main.all <Motion> {shgAltReleaseHook}
453 }