1
2 # Configuration parameters
3 #
4 # IGNORE_UNUSED_CLASSES --
5 # 0 to show all classes, 1 shows only classes with instances.
6 # DISPLAY_WIDTH --
7 # DISPLAY_HEIGHT --
8 # width and heigth of the item list.
9 # MAX_VALUE_LENGTH --
10 # A string whose length is longer than this value will be clipped.
11 # SCROLL_SPEED --
12 # The period in ms between updates of scrolling labels. (larger -> slower)
13 # BACKGROUND_COLOR --
14 # GRID_COLOR --
15 # The background and grid colors of items in the display.
16
17 #-----------------------------------------------------------
18 # Class:
19 # MashInspector
20 # Description:
21 # A GUI for examining the inner workings of any Mash program.
22 # To use, just "import MashInspector" and "new MashInspector"
23 #-----------------------------------------------------------
24 Class MashInspector
25
26 global the_curr_class the_curr_inst the_curr_instproc
27 set the_curr_class ""
28 set the_curr_inst ""
29 set the_curr_instproc ""
30
31 MashInspector instproc init { } {
32 global tk_version
33 if ![info exists tk_version] {
34 error "MashInspector requires Tk."
35 }
36 $self instvar the_labels
37 $self instvar scroll_offset config
38
39 set config(IGNORE_UNUSED_CLASSES) 1
40 set config(DISPLAY_WIDTH) 180
41 set config(DISPLAY_HEIGHT) 400
42 set config(BACKGROUND_COLOR) white
43 set config(GRID_COLOR) #dddddd
44 set config(MAX_VALUE_LENGTH) 25
45 set config(SCROLL_SPEED) 200
46
47 set the_labels() ""
48 set scroll_offset 0
49
50 option add *font {lucida 8 normal}
51 option add *Label.font {lucida 8 bold}
52 option add *InspectorDisplay*Label.font {lucida 8 normal}
53 option add *Text.font {lucidatypewriter 8 normal}
54
55 # Create a huge frame with several scrollable canvas.
56 set top [toplevel .mi[pid]]
57 wm title $top "MashInspector v1.0"
58 set main [frame $top.main]
59 set disp [frame $top.disp]
60 set ctrl [frame $top.ctrl]
61 pack $main $disp -side top -fill both -expand 1
62 pack $ctrl -side top -fill both -expand 1
63 $self init_main $main
64 $self init_disp $disp
65 $self init_ctrl $ctrl
66 }
67
68 MashInspector instproc create_display {parent id} {
69 $self instvar the_option the_frame the_canvas config
70
71 set w $config(DISPLAY_WIDTH)
72 set h $config(DISPLAY_HEIGHT)
73 set bg $config(BACKGROUND_COLOR)
74
75 # tf is the overall frame. it contains 3 sub frames -
76 # 1 for label, 1 for canvas and 1 for options
77 set tf [frame $parent.tf${id}]
78 pack $tf -side left -fill both -pady 4
79
80 set lf [frame $tf.lf]
81 set l [label $lf.l -text $id -anchor nw]
82 pack $lf $l -fill x
83
84 set cf [frame $tf.cf -relief sunken -class InspectorDisplay]
85 set sb [scrollbar $cf.sb -width 15]
86 set c [canvas $cf.c -width $w -height $h -bg $bg -scrollregion "0 0 $w $h"]
87 set the_canvas($id) $c
88 $sb configure -command "$c yview"
89 $c configure -yscrollcommand "$sb set"
90 pack $sb -side right -fill both
91 pack $cf -fill both
92
93 set the_option($id) [frame $tf.op]
94 pack $the_option($id) -fill both
95
96
97 set f [frame $c.finit -background $bg -width $w -height $h]
98 set the_frame($id) $f
99
100 pack $c $f -fill both
101 $c create window 0 0 -window $f -anchor nw -tags f
102 }
103
104 MashInspector instproc init_main {parent} {
105 foreach id {Classes Instprocs Heritage Instances Members} {
106 $self create_display $parent $id
107 }
108 $self init_class
109
110 # This should go somewhere else.
111 $self instvar the_option
112 set b [button $the_option(Classes).all \
113 -command "$self toggle_all_classes" -text "Show Unused Classes"]
114 pack $b -fill x -expand 1
115 }
116
117 MashInspector instproc init_class {} {
118 $self instvar config the_labels the_frame the_canvas the_option
119 set c $the_canvas(Classes)
120 set f $the_frame(Classes)
121 destroy $f
122
123 set bg $config(GRID_COLOR)
124 set w $config(DISPLAY_WIDTH)
125 set h $config(DISPLAY_HEIGHT)
126 set f [frame $c.finit -bg $bg -width $w -height $h -class InspectorDisplay]
127 set the_frame(Classes) $f
128 unset the_labels
129 set row 0
130
131 set l [$self create_clickable_label $f.call "ALL INSTANCES" "show_all_instances"]
132 set the_labels(Classes,all) $l
133
134 foreach cls [lsort [Class info instances]] {
135 set num_of_instances [llength [$cls info instances]]
136 if {($num_of_instances != 0 && $config(IGNORE_UNUSED_CLASSES) == 1) ||
137 $config(IGNORE_UNUSED_CLASSES) == 0} {
138 set l [$self create_clickable_label $f.c$row \
139 "$cls ($num_of_instances)" "select_class $cls"]
140 set the_labels(Classes,$cls) $l
141 incr row
142 }
143 }
144 $self pack_display $f $c
145
146 return $f
147 }
148
149
150 MashInspector instproc pack_display {f canvas} {
151 $self instvar config
152 $canvas yview moveto 0
153 pack $f -fill both -expand 1
154 if {[lindex [$canvas itemconfig f -window] 4] == ""} {
155 $canvas create window 0 0 -window $f -anchor nw -tags f
156 }
157 if [catch {tkwait visibility $f}] {
158 return
159 }
160 set width [winfo width $f]
161 set height [winfo height $f]
162 set w $config(DISPLAY_WIDTH)
163 set h $config(DISPLAY_HEIGHT)
164 set maxh [expr {$height > $h} ? $height : $h]
165 set maxw [expr {$width > $w} ? $width : $w]
166 $canvas config -width $maxw -scrollregion "0 0 $maxw $maxh"
167 $canvas itemconfig f -width $maxw
168 pack $canvas -fill both -expand 1
169 }
170
171 MashInspector instproc create_clickable_label {name text action} {
172 $self instvar config
173 if ![winfo exists $name] {
174 set l [label $name -text "$text" -anchor nw -bg $config(BACKGROUND_COLOR) -fg black]
175 pack $l -fill x -pady 1
176 } else {
177 set l $name
178 $l config -text $text -bg $config(BACKGROUND_COLOR) -fg black
179 }
180 bind $l <Any-Enter> "$l config -bg #cfcfcf -fg black"
181 bind $l <Any-Leave> "$l config -bg $config(BACKGROUND_COLOR) -fg black"
182 bind $l <Button-1> "$self $action"
183 return $l
184 }
185
186 MashInspector instproc create_scrolling_label {name text} {
187 $self instvar config
188 set diff [expr [string length $text] - $config(MAX_VALUE_LENGTH)]
189 if {$diff > 0} {
190 set svalue [string replace $text 10 [expr $diff + 10] " ... "]
191 set mvalue $text
192 } else {
193 set l2 [label $name -text $text -background $config(BACKGROUND_COLOR) -anchor nw]
194 return $l2
195 }
196 if ![winfo exists $name] {
197 set l [label $name -text "$svalue" -anchor nw -bg $config(BACKGROUND_COLOR) -fg black]
198 pack $l -fill x -pady 1
199 } else {
200 set l $name
201 $l config -text $svalue -bg $config(BACKGROUND_COLOR) -fg black
202 }
203 bind $l <Any-Enter> "$self scroll_label $l \"$mvalue\""
204 bind $l <Any-Leave> "$self unscroll_label $l \"$svalue\""
205 return $l
206 }
207
208 MashInspector instproc create_member_labels { parent row mname mvalue } {
209 $self instvar config
210 set l1 [$self create_scrolling_label $parent.n$row $mname]
211 $l1 config -anchor ne
212 if {[string match "_o*" $mvalue] && [llength $mvalue] == 1} {
213 set l2 [$self create_clickable_label $parent.v$row $mvalue "select_instance $mvalue"]
214 } else {
215 set l2 [$self create_scrolling_label $parent.v$row $mvalue]
216 }
217 pack $l1 $l2
218 grid $l1 -row $row -column 0 -pady 1 -padx 1 -sticky news
219 grid $l2 -row $row -column 1 -padx 1 -pady 1 -sticky news
220 }
221
222 MashInspector instproc show_all_instances { } {
223 global the_curr_class the_curr_inst
224 $self instvar the_text
225
226 # Delete all memebers and instproc display
227 $self unhighlight_label Classes $the_curr_class
228 set the_curr_class "ALL INSTANCES"
229 $self highlight_label Classes $the_curr_class
230 set the_curr_inst ""
231 $self show_members ""
232 $the_text delete 1.0 end
233
234 $self show_class_data Instprocs "" ""
235 $self show_class_data Heritage "" ""
236 $self show_class_data Instances [lsort -dictionary [info commands _o*]] select_instance
237 }
238
239 MashInspector instproc show_class_data {type list action} {
240 $self instvar the_canvas the_frame the_labels config
241 # Display instprocs
242 set canvas $the_canvas($type)
243 set f $the_frame($type)
244 $f config -bg $config(BACKGROUND_COLOR)
245
246 $self instvar the_labels
247 foreach key [array name the_labels $type,*] {
248 unset the_labels($key)
249 }
250 # eval [list $action {}]
251
252 set lastrow [llength [winfo children $f]]
253 set row 0
254 foreach item $list {
255 set l [$self create_clickable_label $f.c$row $item "$action $item"]
256 set the_labels($type,$item) $l
257 incr row
258 }
259 for {set i $row} {$i < $lastrow} {incr i} {
260 destroy $f.c$i
261 }
262 $self pack_display $f $canvas
263 if {$list != ""} {
264 $f config -bg $config(GRID_COLOR)
265 }
266 }
267
268
269 MashInspector instproc show_members {list {instance ""}} {
270 $self instvar the_canvas the_frame config
271 set canvas $the_canvas(Members)
272 set f $the_frame(Members)
273
274 grid columnconfigure $f {0 1} -weight 1
275 grid rowconfigure $f {0 1} -weight 1
276
277 $f config -bg $config(BACKGROUND_COLOR)
278 foreach c [winfo children $f] {
279 destroy $c
280 }
281 set row 0
282 foreach var [lsort $list] {
283 if [$instance array exists $var] {
284 foreach n [$instance array names $var] {
285 set value [lindex [$instance array get $var $n] 1]
286 $self create_member_labels $f $row ${var}($n) $value
287 incr row
288 }
289 } else {
290 catch {$instance set $var} value
291 $self create_member_labels $f $row $var $value
292 incr row
293 }
294 }
295 $self pack_display $f $canvas
296 if {$list != ""} {
297 $f config -bg $config(GRID_COLOR)
298 }
299 }
300
301
302 MashInspector instproc select_class {cls} {
303 global the_curr_class the_curr_inst
304 $self instvar the_text
305 if {$cls == $the_curr_class || $cls == ""} {
306 return
307 }
308 if {$cls == "ALL INSTANCES"} {
309 $self show_all_instances
310 return
311 }
312 if {[info command $cls] == ""} {
313 puts "Class $cls is not valid."
314 return
315 }
316 $self unhighlight_label Classes $the_curr_class
317 set the_curr_class $cls
318 $self highlight_label Classes $cls
319
320 $self show_class_data Instances [lsort -dictionary [$cls info instances]] select_instance
321 $self show_class_data Instprocs [lsort [$cls info instprocs]] select_instproc
322 $self show_class_data Heritage "[$self lreverse [$cls info heritage]] $cls [$cls info subclass]" select_class
323 $self highlight_label Heritage $cls
324 $self show_members ""
325 $the_text delete 1.0 end
326 set the_curr_inst ""
327 set the_curr_instproc ""
328 }
329
330 MashInspector instproc select_instproc {instproc} {
331 global the_curr_class the_curr_instproc
332 $self instvar the_text
333
334 $self unhighlight_label Instprocs $the_curr_instproc
335 set the_curr_instproc $instproc
336 $self highlight_label Instprocs $instproc
337
338 $the_text delete 1.0 end
339 $the_text insert end "$the_curr_class instproc $instproc {[$the_curr_class info instargs $instproc]} { [$the_curr_class info instbody $instproc] }"
340 }
341
342 MashInspector instproc select_instance {instance} {
343 # Make sure the instance still exists, as it may have been delete by
344 # the application since we shown it in the display.
345 if {[info commands $instance] == ""} {
346 puts "$instance no longer exists. Please refresh."
347 return
348 }
349 $self select_class [$instance info class]
350
351 global the_curr_inst
352 $self unhighlight_label Instances $the_curr_inst
353 set the_curr_inst $instance
354 $self highlight_label Instances $instance
355
356 $self show_members [$instance info vars] $instance
357 }
358
359
360 MashInspector instproc highlight_label { type name } {
361 $self instvar the_labels
362 if ![info exists the_labels($type,$name)] {return}
363 set l $the_labels($type,$name)
364 $l configure -background black -foreground white
365 bind $l <Any-Leave> "$l configure -bg black -fg white"
366 }
367
368
369 MashInspector instproc unhighlight_label { type name } {
370 $self instvar the_labels config
371 if ![info exists the_labels($type,$name)] {return}
372 set l $the_labels($type,$name)
373 $l configure -background $config(BACKGROUND_COLOR) -foreground black
374 bind $l <Any-Leave> "$l configure -bg $config(BACKGROUND_COLOR) -fg black"
375 }
376
377 MashInspector instproc scroll_label {label string} {
378 $self instvar scroll_offset config scroll_after_id
379 set scroll_after_id [after $config(SCROLL_SPEED) "$self scroll $label \"$string\""]
380 }
381
382 MashInspector instproc scroll {label string} {
383 $self instvar scroll_offset scroll_after_id config
384 incr scroll_offset 2
385 if {$scroll_offset >= [string length $string] + 10} {
386 set scroll_offset [expr $scroll_offset % [expr [string length $string] + 10]]
387 }
388 set scroll_after_id [
389 after $config(SCROLL_SPEED) "$self scroll $label \"$string\""
390 ]
391 set end_offset [expr $scroll_offset + $config(MAX_VALUE_LENGTH)]
392 set display [string range $string $scroll_offset $end_offset]
393 if {$end_offset >= [string length $string]} {
394 # too short.. pad with spaces or beginning of text.
395 set topad [expr $config(MAX_VALUE_LENGTH) - [string length $display] + 1]
396 if {$topad < 10} {
397 append display [string repeat " " $topad]
398 } else {
399 if {$scroll_offset >= [string length $string]} {
400 set padlength [expr 10 - $scroll_offset + [string length $string]]
401 } else {
402 set padlength 10
403 }
404 append display [string repeat " " $padlength]
405 append display [string range $string 0 [expr $topad - $padlength]]
406 }
407 }
408 $label config -text $display
409 return
410 }
411
412 MashInspector instproc unscroll_label {label string} {
413 $self instvar scroll_offset scroll_after_id
414 set scroll_offset 0
415 after cancel $scroll_after_id
416 $label config -text $string
417 }
418
419
420 MashInspector instproc init_disp {parent} {
421 global the_curr_class the_curr_inst
422 set f [frame $parent.status -relief ridge]
423 label $f.currclass -textvariable the_curr_class -anchor nw
424 label $f.colon1 -text ":" -anchor nw
425 label $f.currinst -textvariable the_curr_inst -anchor nw
426 pack $f.currclass $f.colon1 $f.currinst -side left
427 pack $f -side top -fill both
428
429 set f [frame $parent.ftext]
430 $self instvar the_text
431 set sb [scrollbar $f.sb -command "$f.text yview"]
432 set the_text [text $f.text -height 10 -yscrollcommand "$sb set"]
433 pack $sb -side right -fill both
434 pack $the_text -fill both
435 $the_text insert end " "
436
437 pack $f -side top -fill both
438 }
439
440 MashInspector instproc refresh {} {
441 $self init_class
442 global the_curr_inst the_curr_class
443 set cls $the_curr_class
444 set inst $the_curr_inst
445
446 # Reinitialize the_curr_class so that everything starts from the
447 # beginning. (Otherwise, if $the_curr_class == $class, we do
448 # nothing in select_class.)
449 set the_curr_class ""
450 if {$cls != ""} {
451 $self select_class $cls
452 }
453
454 # We use $inst instead of $the_curr_inst because select_class
455 # reinitializes the_curr_inst to "". We make sure that $inst
456 # exists.
457 if {$inst != ""} {
458 $self select_instance $inst
459 }
460 }
461
462
463 MashInspector instproc eval {text status} {
464 catch {eval [$text get]} err
465 $status configure -text $err
466 }
467
468
469 MashInspector instproc init_ctrl {parent} {
470 entry $parent.text -relief sunken -bg white
471 button $parent.eval -text "Eval" -command "$self eval $parent.text $parent.status"
472 button $parent.refresh -text "Refresh" -command "$self refresh"
473 button $parent.close -text "Close" -command "destroy [winfo toplevel $parent]"
474 label $parent.status -text "" -relief groove
475 pack $parent.status -fill x -expand 1
476 pack $parent.text $parent.eval -side left -fill both -expand 1
477 pack $parent.refresh $parent.close -side right -fill both -expand 1
478 }
479
480 MashInspector instproc toggle_all_classes { } {
481 $self instvar the_option config
482 if {$config(IGNORE_UNUSED_CLASSES) == 1} {
483 $the_option(Classes).all config -text "Hide Unused Classes"
484 set config(IGNORE_UNUSED_CLASSES) 0
485 } else {
486 $the_option(Classes).all config -text "Show Unused Classes"
487 set config(IGNORE_UNUSED_CLASSES) 1
488 }
489 $self init_class
490 }
491
492 MashInspector instproc lreverse l {
493 set m {}; foreach i $l { set m [linsert $m 0 $i] }; return $m
494 }
495
496 #vim:ts=8:sw=4:expandtab
497
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.