sid/component/tcl/sid-control-tksm.tk

   1 # tksm - tk system monitor
   2 # By #ohm, la resistance
   3
   4 # Initialization
   5
   6
   7 array set refresh_fragments [list]
   8 set refresh_pin [sid::pin::new]
   9 set refresh_ok 1
  10
  11
  12 set stop_pins [list]
  13 proc any_stop_pins_p {} {
  14     global stop_pins
  15     return [llength $stop_pins]
  16 }
  17
  18 array set triggerpoint_action [list]
  19 array set triggerpoint_info [list]
  20
  21 # $components(name) = component-handle
  22 array set components [list]
  23
  24 proc cfgroot_component {} {
  25     global components
  26     return $components(main)
  27 }
  28
  29 proc component_names {} {
  30     global components
  31     return [array names components]
  32 }
  33
  34
  35 # ---------------------------------------------------------------------------
  36 # State save/restore support data
  37
  38 # $state_snapshots($slot,$name) = state-snapshot
  39 array set state_snapshots [list]
  40 proc save_state {slot} {
  41     global components state_snapshots
  42     foreach name [component_names] {
  43         set comp $components($name)
  44         set state [sid::component::attribute_value $comp state-snapshot]
  45         set state_snapshots($slot,$name) $state
  46     }
  47 }
  48
  49 proc restore_state {slot} {
  50     global components state_snapshots
  51     set failed [list]
  52     foreach name [component_names] {
  53         set comp $components($name)
  54         if {! [info exists state_snapshots($slot,$name)]} then { continue }
  55         set state $state_snapshots($slot,$name)
  56         if {$state == ""} then { continue }
  57         set status [sid::component::set_attribute_value $comp state-snapshot $state]
  58         if {$status != "ok"} then { lappend failed "${name}:${status}" }
  59     }
  60     if {[llength $failed] > 0} then {
  61         tk_dialog .oops3 Error "Cannot restore state to some components: $failed" error 0 "oh well"
  62     }
  63 }
  64
  65 proc zap_state {slot} {
  66     global state_snapshots
  67     foreach name [component_names] {
  68         if {[info exists state_snapshots($slot,$name)]} then {
  69             unset state_snapshots($slot,$name)
  70         }
  71     }
  72 }
  73
  74
  75
  76 set num_state_slots 0
  77 proc push_new_state {} {
  78     global num_state_slots
  79     incr num_state_slots
  80     save_state $num_state_slots
  81     .control.statenum configure -text $num_state_slots
  82 }
  83 proc zap_top_state {} {
  84     global num_state_slots
  85     if {$num_state_slots == 0} then { return }
  86     zap_state $num_state_slots
  87     incr num_state_slots -1
  88     .control.statenum configure -text $num_state_slots
  89 }
  90 proc peek_top_state {} {
  91     global num_state_slots
  92     if {$num_state_slots == 0} then { return }
  93     restore_state $num_state_slots
  94 }
  95
  96
  97
  98 proc stop_tksm {} {
  99     set comp [cfgroot_component]
 100     set stoppin [sid::component::find_pin $comp "stop!"]
 101     if {$stoppin != ""} then {sid::pin::driven_h4 $stoppin 1}
 102 }
 103
 104
 105 # ---------------------------------------------------------------------------
 106
 107 # Configuration graphing interface
 108
 109 # Create a "dot" format description of the current configuration graph
 110 proc polkadot {} {
 111     global components
 112     set dot "digraph sid \{\n"
 113
 114     append dot "// nodes\n"
 115     append dot "node \[shape=\"box\"\];\n"
 116
 117     # collect pin/bus/component-handle -> dot-node-name mapping table
 118     foreach name [component_names] {
 119         set comp $components($name)
 120         set cn "$comp"
 121
 122         append dot "subgraph \"cluster $cn\" \{ label=\"$name\";\n"
 123         set comps($comp) $cn
 124
 125         if {[sid::component::pin_names $comp] != ""} then {
 126             append dot "  subgraph \"cluster $name-pins\" \{ label=\"pins\"; \n"
 127             foreach pin_nm [sid::component::pin_names $comp] {
 128                 set ph [sid::component::find_pin $comp $pin_nm]
 129                 set pn "$cn pin $pin_nm"
 130                 append dot "    \"$pn\" \[label=\"$pin_nm\"\];\n"
 131                 if {$ph != ""} then { ;# input pin
 132                     set pins($ph) $pn
 133                 }
 134             }
 135             append dot "  \} // pins\n"
 136         }
 137
 138         if {[sid::component::bus_names $comp] != ""} then {
 139             append dot "  subgraph \"cluster $name-buses\" \{ label=\"buses\"; \n"
 140             foreach bus_nm [sid::component::bus_names $comp] {
 141                 set bh [sid::component::find_bus $comp $bus_nm]
 142                 set bn "$cn bus $bus_nm"
 143                 append dot "    \"$bn\" \[label=\"$bus_nm\"\];\n"
 144                 set buses($bh) $bn
 145             }
 146             append dot "  \} // buses\n"
 147         }
 148
 149         if {[sid::component::accessor_names $comp] != ""} then {
 150             append dot "  subgraph \"cluster $name-accessors\" \{ label=\"accessors\"; \n"
 151             foreach acc_nm [sid::component::accessor_names $comp] {
 152                 set an "$cn accessor $acc_nm"
 153                 append dot "    \"$an\" \[label=\"$acc_nm\"\];\n"
 154             }
 155             append dot "  \} // accessors\n"
 156         }
 157
 158         if {[sid::component::relationship_names $comp] != ""} then {
 159             append dot "  subgraph \"cluster $name-relations\" \{ label=\"relations\"; \n"
 160             foreach rel_nm [sid::component::relationship_names $comp] {
 161                 set rn "$cn relation $rel_nm"
 162                 append dot "    \"$rn\" \[label=\"$rel_nm\"\];\n"
 163             }
 164             append dot "  \} // relations\n"
 165         }
 166         append dot "\} // component\n"
 167     }
 168
 169     append dot "// edges\n"
 170
 171     # generate pin/bus/relation edges
 172     foreach name [component_names] {
 173         set comp $components($name)
 174         set cn "$comp"
 175
 176         foreach pin_nm [sid::component::pin_names $comp] {
 177             set pn "$cn pin $pin_nm"
 178             foreach conn_pin [sid::component::connected_pins $comp $pin_nm] {
 179                 if {[info exists pins($conn_pin)]} then {
 180                     append dot "\"$pn\" -> \"$pins($conn_pin)\"; \n"
 181                 } else {
 182                     append dot "\"$pn\" -> \"anonymous-pin\"; \n"
 183                 }
 184             }
 185         }
 186
 187         foreach acc_nm [sid::component::accessor_names $comp] {
 188             set an "$cn accessor $acc_nm"
 189             set acc_bus [sid::component::connected_bus $comp $acc_nm]
 190             if {$acc_bus != ""} {
 191                 if {[info exists buses($acc_bus)]} then {
 192                     append dot "\"$an\" -> \"$buses($acc_bus)\"; \n"
 193                 } else {
 194                     append dot "\"$an\" -> \"anonymous-bus\"; \n"
 195                 }
 196             }
 197         }
 198
 199         foreach rel_nm [sid::component::relationship_names $comp] {
 200             set rn "$cn relation $rel_nm"
 201             foreach rel_comp [sid::component::related_components $comp $rel_nm] {
 202                 if {[info exists comps($rel_comp)]} then {
 203                     append dot "\"$rn\" -> \"$comps($rel_comp)\"; \n"
 204                 } else {
 205                     append dot "\"$rn\" -> \"anonymous-component\"; \n"
 206                 }
 207             }
 208         }
 209     }
 210
 211     append dot "\} // digraph\n"
 212     return $dot
 213 }
 214
 215
 216 proc show_polkadot {} {
 217     set dot [polkadot]
 218     set filename "/tmp/dot.[clock seconds]"
 219     set file [open $filename w]
 220     puts $file $dot
 221     close $file
 222     catch {exec dotty $filename &}
 223     # race
 224     set now [clock seconds]
 225     while {($now + 5) > [clock seconds]} { }
 226     file delete $filename
 227 }
 228
 229
 230
 231 # ---------------------------------------------------------------------------
 232 # Top-level window layout
 233
 234 wm title . "System Monitor"
 235 #wm resizable . 0 0
 236 #scrollbar .x -orient horizontal
 237 #scrollbar .y -orient vertical
 238 #pack .x -side bottom -fill x
 239 #pack .y -side right -fill y
 240
 241 frame .control -borderwidth 2
 242 checkbutton .control.autorefresh -variable refresh_ok -text "Auto refresh"
 243 # button .control.graph -text "Graphviz" -command {show_polkadot}
 244 # pack .control.autorefresh .control.graph -side left
 245 pack .control.autorefresh -side left -padx 20
 246 label .control.state -text "State"
 247 label .control.statenum -text "0"
 248 button .control.statepush -padx 4 -borderwidth 1 -text "save" -command {push_new_state}
 249 button .control.statepop -padx 4 -borderwidth 1 -text "restore" -command {peek_top_state}
 250 button .control.statezap -padx 4 -borderwidth 1 -text "discard" -command {zap_top_state}
 251 pack .control.state .control.statenum .control.statepush .control.statepop .control.statezap -side left
 252 pack .control -side top
 253 bind .control <Destroy> {stop_tksm}
 254
 255
 256 # Ask user to fill in a number of text fields.
 257 # w: window path
 258 # title/text: labels
 259 # args: field names
 260 # result: list of field values (or empty list if cancelled)
 261 proc tk_ask {w title text bitmap args} {
 262     global tkask_vars
 263     global tkask_disposition
 264     global tcl_platform
 265
 266     foreach a $args {
 267         set tkask_vars($a) {}
 268     }
 269
 270     # destroy/recreate window
 271     catch {destroy $w}
 272     toplevel $w -class Dialog
 273     wm title $w $title
 274     wm iconname $w Dialog
 275     wm protocol $w WM_DELETE_WINDOW {set tkask_disposition -1}
 276     wm transient $w [winfo toplevel [winfo parent $w]]
 277
 278     # create window skeleton
 279     frame $w.bot
 280     frame $w.mid
 281     frame $w.top
 282     if {$tcl_platform(platform) == "unix"} {
 283         $w.bot configure -relief raised -bd 1
 284         $w.mid configure -relief raised -bd 1
 285         $w.top configure -relief raised -bd 1
 286     }
 287     pack $w.bot -side bottom -fill both
 288     pack $w.top $w.mid -side top -fill both -expand 1
 289
 290     # fill top part
 291
 292     option add *Dialog.msg.wrapLength 3i widgetDefault
 293     label $w.msg -justify left -text $text
 294     if {$tcl_platform(platform) == "macintosh"} {
 295         $w.msg configure -font system
 296     } else {
 297         $w.msg configure -font {Times 18}
 298     }
 299     pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
 300     if {$bitmap != ""} {
 301         if {($tcl_platform(platform) == "macintosh") && ($bitmap == "error")} {
 302             set bitmap "stop"
 303         }
 304         label $w.bitmap -bitmap $bitmap
 305         pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
 306     }
 307
 308     # fill middle part
 309     set i 0
 310     foreach a $args {
 311         frame $w.mid$i
 312         label $w.mid$i.l -text $a
 313         entry $w.mid$i.r -width 20 -textvariable tkask_vars($a)
 314         pack $w.mid$i.l -side left
 315         pack $w.mid$i.r -side right
 316         grid $w.mid$i -in $w.mid -column 0 -row $i -sticky ew -pady 10
 317         incr i
 318     }
 319
 320     # fill bottom part
 321     set i 0
 322     foreach but {ok cancel} {
 323         button $w.button$i -text $but -command "set tkask_disposition $i"
 324         if {$i == 0} {
 325             $w.button$i configure -default active
 326         } else {
 327             $w.button$i configure -default normal
 328         }
 329         grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew -padx 10
 330         grid columnconfigure $w.bot $i
 331         # We boost the size of some Mac buttons for l&f
 332         if {$tcl_platform(platform) == "macintosh"} {
 333             set tmp [string tolower $but]
 334             if {($tmp == "ok") || ($tmp == "cancel")} {
 335                 grid columnconfigure $w.bot $i -minsize [expr 59 + 20]
 336             }
 337         }
 338         incr i
 339     }
 340
 341
 342     # handle <Return>,<Destroy>
 343     bind $w <Return> "
 344             $w.button0 configure -state active -relief sunken
 345             update idletasks
 346             after 100
 347             set tkask_disposition 0
 348         "
 349     bind $w <Destroy> {set tkask_disposition -1}
 350
 351     # withdraw & resize dialog
 352     wm withdraw $w
 353     update idletasks
 354     set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
 355             - [winfo vrootx [winfo parent $w]]}]
 356     set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
 357             - [winfo vrooty [winfo parent $w]]}]
 358     wm geom $w +$x+$y
 359     update idle
 360     wm deiconify $w
 361
 362     # grab & focus
 363     set oldFocus [focus]
 364     set oldGrab [grab current $w]
 365     if {$oldGrab != ""} {
 366         set grabStatus [grab status $oldGrab]
 367     }
 368     grab $w
 369     focus $w.button0
 370
 371     # wait for user
 372     tkwait variable tkask_disposition
 373     catch {focus $oldFocus}
 374     catch {
 375         bind $w <Destroy> {}
 376         destroy $w
 377     }
 378     if {$oldGrab != ""} {
 379         if {$grabStatus == "global"} {
 380             grab -global $oldGrab
 381         } else {
 382             grab $oldGrab
 383         }
 384     }
 385
 386     # collect results
 387     if {$tkask_disposition != 0} then {
 388         return [list]
 389     } else {
 390         set r [list]
 391         foreach a $args {
 392             lappend r $tkask_vars($a)
 393         }
 394         return $r
 395     }
 396 }
 397
 398
 399
 400 # Take a component name and/or attribute name, and mangle it into something
 401 # unique and safe for use as a tk widget path.
 402 set unique_wn_suffix 0
 403 proc widgetname {base args} {
 404     global unique_wn_suffix
 405     set name ""
 406     foreach a $args {
 407         regsub -all {[^a-z0-9]} $a {_} mangled
 408         set name "${name}_${mangled}"
 409     }
 410     incr unique_wn_suffix
 411     set name "${base}.${name}_${unique_wn_suffix}"
 412     # puts "$args -> $name"
 413     return $name
 414 }
 415
 416
 417 proc have_none_p {comp category} {
 418     set registers [sid::component::attribute_names_in_category $comp $category]
 419     if {[llength $registers] == 0} then { return 1 } else { return 0 }
 420 }
 421
 422 proc not_watchable_p {comp attribute} {
 423     foreach w [sid::component::attribute_names_in_category $comp watchable] {
 424         if {$w == $attribute} then { return 0 }
 425     }
 426     return 1
 427 }
 428
 429
 430 proc refresh_all {} {
 431     global refresh_fragments
 432     set search [array startsearch refresh_fragments]
 433     while {[array anymore refresh_fragments $search]} {
 434         set name [array nextelement refresh_fragments $search]
 435         set script $refresh_fragments($name)
 436         eval $script
 437     }
 438     array donesearch refresh_fragments $search
 439     # update may fail if top level window was closed
 440     catch { update }
 441 }
 442
 443
 444
 445 proc open_component_window { category name type comp } {
 446
 447     set wn [widgetname "" $name $category]
 448
 449     toplevel $wn
 450     wm title $wn "$name $category list"
 451     #wm resizable $wn 0 0
 452
 453     # scrollbar $wn.y -orient vertical
 454     # pack $wn.y -side right -fill y
 455
 456     set registers [sid::component::attribute_names_in_category $comp $category]
 457     if {[llength $registers] == 0} then {
 458         tk_dialog .oops2 Oops "Nothing to show for $name $category list." warning 0 "oh well"
 459         destroy $wn
 460         return
 461     }
 462
 463 #    set refreshcmds "puts \"refreshing $name $category\""
 464     set refreshcmds ""
 465     frame $wn.regs -relief raised -borderwidth 2
 466
 467     foreach r $registers {
 468         set subwidgetname [widgetname $wn $r]
 469
 470         frame $subwidgetname -relief sunken -borderwidth 2
 471         label $subwidgetname.label -text $r
 472         entry $subwidgetname.value -width 20
 473
 474         append refreshcmds "
 475             set prev_value \[$subwidgetname.value get\]
 476             set value \[sid::component::attribute_value $comp [list $r]\]
 477             $subwidgetname.value delete 0 end
 478             $subwidgetname.value insert 0 \$value
 479             if {\$value == \$prev_value} then { set c black } else { set c red }
 480             $subwidgetname.label configure -foreground \$c"
 481         bind $subwidgetname.value <Escape> "
 482             set value \[sid::component::attribute_value $comp [list $r]\]
 483             $subwidgetname.value delete 0 end
 484             $subwidgetname.value insert 0 \$value
 485             $subwidgetname.label configure -foreground blue"
 486         bind $subwidgetname.value <Return> "
 487             set value \[$subwidgetname.value get\]
 488             set prev_value \[sid::component::attribute_value $comp [list $r] \]
 489             set status \[sid::component::set_attribute_value $comp [list $r] \$value\]
 490             if {\$status != \"ok\"} then {
 491                 tk_dialog .oops Error \"Error setting $name $category [list $r] to \$value: \$status\" error 0 ok
 492                 set new_value \[sid::component::attribute_value $comp [list $r]\]
 493                 if {\$new_value != \$prev_value} then {
 494                     set status2 \[sid::component::set_attribute_value $comp [list $r] \$prev_value\]
 495                     if {\$status2 != \"ok\"} then {
 496                          tk_dialog .oops Error \"Error restoring $name $category [list $r] back to \$prev_value: \$status\" error 0 damn
 497                     }
 498                 }
 499             }
 500             $subwidgetname.label configure -foreground green"
 501         bind $subwidgetname.value <Enter> "global refresh_ok ; set refresh_ok 0"
 502         bind $subwidgetname.value <Leave> "global refresh_ok ; set refresh_ok 1"
 503
 504         set event_command \
 505             "destroy .m
 506              menu .m -tearoff 0
 507             .m add command -label {Watch change} -command {
 508                  add_triggerpoint $subwidgetname $comp [list $r] change
 509                  destroy .m}
 510             .m add command -label {Watch value} -command {
 511                  add_triggerpoint $subwidgetname $comp [list $r] value
 512                  destroy .m}
 513             .m add command -label {Watch mask/value} -command {
 514                  add_triggerpoint $subwidgetname $comp [list $r] mask/value
 515                  destroy .m}
 516             .m add command -label {Watch range} -command {
 517                  add_triggerpoint $subwidgetname $comp [list $r] range
 518                  destroy .m}
 519             if \[not_watchable_p $comp [list $r]\] { .m entryconfigure 0 -state disabled
 520                                               .m entryconfigure 1 -state disabled
 521                                               .m entryconfigure 2 -state disabled
 522                                               .m entryconfigure 3 -state disabled }
 523             tk_popup .m %X %Y"
 524         bind $subwidgetname.label <Button-1> $event_command
 525         bind $subwidgetname.label <Button-3> $event_command
 526         bind $subwidgetname.label <Enter> "$subwidgetname.label configure -foreground yellow"
 527         bind $subwidgetname.label <Leave> "$subwidgetname.label configure -foreground black"
 528
 529         pack $subwidgetname.label -side left -fill none
 530         pack $subwidgetname.value -ipadx 20 -side right -fill none
 531         pack $subwidgetname -side top -fill x
 532     }
 533     pack $wn.regs -side top -fill x
 534
 535     global refresh_fragments
 536     eval $refreshcmds
 537     set refresh_fragments($wn) $refreshcmds
 538     bind $wn <Destroy> "
 539         if {\"%W\" == \"$wn\"} then {
 540             global refresh_fragments
 541             if {[info exists refresh_fragments($wn)]} { unset refresh_fragments($wn) }
 542         }"
 543
 544     frame $wn.buttons
 545     button $wn.buttons.refresh -text Refresh -command {refresh_all}
 546     button $wn.buttons.regen -text Regenerate -command "destroy $wn ; open_component_window $category $name $type $comp"
 547     button $wn.buttons.close -text "M'kay" -command "destroy $wn"
 548     pack $wn.buttons.refresh $wn.buttons.regen -side left
 549     pack $wn.buttons.close -side right
 550     pack $wn.buttons -side bottom -fill x
 551 }
 552
 553
 554
 555 set component_gui_number 0
 556 proc open_component_gui { gui name type comp } {
 557     global component_gui_number
 558     global compgui_pending_relations
 559
 560     incr component_gui_number
 561
 562     # perform work by instantiating component of choice
 563
 564     set comptype [sid::component::attribute_value $comp $gui]
 565     set compname tksm-gui-${component_gui_number}
 566
 567     # leave a mark for `proc relate' to inform new gui component
 568     set compgui_pending_relations($compname,component) $comp
 569     set compgui_pending_relations($compname,relation) "$type $name"
 570
 571     set r [sid::component::set_attribute_value [cfgroot_component] "config-line!" "new \"$comptype\" \"$compname\" "]
 572     if {$r != "ok"} then { tk_dialog .oops Error "Cannot create gui component $comptype" error 0 ok; return }
 573 }
 574
 575
 576
 577 proc remove_triggerpoint { component watcher_name pin } {
 578     global triggerpoint_action
 579     global triggerpoint_info
 580     unset triggerpoint_action($pin)
 581     unset triggerpoint_info($pin)
 582     set s [sid::component::disconnect_pin $component $watcher_name $pin]
 583     if {$s != "ok"} then {
 584         tk_dialog .oops3 Oops "Cannot remove $watcher_name: $s" "error" 0 "oh well"
 585     }
 586 }
 587
 588
 589
 590 proc tp_ignore_enter { pin } {
 591     global triggerpoint_info
 592     set triggerpoint_info($pin) "not"
 593 }
 594
 595 proc tp_ignore { pin } {
 596     # nop
 597 }
 598
 599 proc tp_count_enter { pin } {
 600     global triggerpoint_info
 601     set triggerpoint_info($pin) 0
 602 }
 603
 604 proc tp_count { pin } {
 605     global triggerpoint_info
 606     incr triggerpoint_info($pin)
 607 }
 608
 609 proc tp_stop_enter { pin } {
 610     global triggerpoint_info
 611     set triggerpoint_info($pin) "waiting"
 612 }
 613
 614 proc tp_stop { pin } {
 615     global triggerpoint_info
 616
 617     # clear other tp_stop pins' "hit-stopping" indications
 618     global triggerpoint_action
 619     set search [array startsearch triggerpoint_action]
 620     while {[array anymore triggerpoint_action $search]} {
 621         set otherpin [array nextelement triggerpoint_action $search]
 622         set action $triggerpoint_action($otherpin)
 623         if {$action == "tp_stop"} then { tp_stop_enter $otherpin }
 624     }
 625     array donesearch triggerpoint_action $search
 626
 627     set triggerpoint_info($pin) "stopping"
 628     global stop_pins
 629     foreach s $stop_pins {
 630         sid::pin::driven_h4 $s 0
 631     }
 632 }
 633
 634
 635 proc tp_switch { pin } {
 636     global triggerpoint_action
 637     set a $triggerpoint_action($pin)
 638     eval "${a}_enter $pin"
 639     refresh_all
 640 }
 641
 642
 643
 644 # mirror map_watchable_name in sidwatchutil.h
 645 proc map_watchable_name { name } {
 646     set out ""
 647     for {set i 0} {$i < [string length $name]} {incr i} {
 648         set c [string index $name $i]
 649         if {($c >= "a" && $c <= "z") ||
 650             ($c >= "A" && $c <= "Z") ||
 651             ($c >= "0" && $c <= "9") ||
 652             ($c == "_")} then {
 653             append out $c
 654         } else {
 655             set hex "0123456789ABCDEF"
 656             append out "%"
 657             if {$c == ""} then { set cnum 0 } else { scan $c %c cnum }
 658             append out [string index $hex [expr {($cnum >> 4) & 0x0f}]]
 659             append out [string index $hex [expr {$cnum & 0x0f}]]
 660         }
 661     }
 662     return $out
 663 }
 664
 665
 666 proc add_triggerpoint { parentwidget component watchable mode } {
 667     if {$mode == "change"} then {
 668         set args ""
 669     } elseif {$mode == "value"} then {
 670         set v [tk_ask .tpq "Triggerpoint details" "Enter triggerpoint specification" info "value" ]
 671         if {[llength $v] == 0} then { return }
 672         set args ":[lindex $v 0]"
 673     } elseif {$mode == "mask/value"} then {
 674         set v [tk_ask .tpq "Triggerpoint details" "Enter triggerpoint specification" info "mask" "value" ]
 675         if {[llength $v] == 0} then { return }
 676         set args ":[lindex $v 0]:[lindex $v 1]"
 677     } elseif {$mode == "range"} then {
 678         set v [tk_ask .tpq "Triggerpoint details" "Enter triggerpoint specification" info "low" "high" ]
 679         if {[llength $v] == 0} then { return }
 680         set args ":[lindex $v 0]:[lindex $v 1]"
 681     }
 682
 683     set recepient_pin [sid::pin::new]
 684     set mapped [map_watchable_name $watchable]
 685     set watcher_name "watch:${mapped}:${mode}${args}"
 686     # puts $watcher_name
 687     set s [sid::component::connect_pin $component $watcher_name $recepient_pin]
 688     if {$s == "ok"} then {
 689         set wn [widgetname $parentwidget $watchable]
 690         label $wn -text "(wait)"
 691
 692         global triggerpoint_info
 693         set triggerpoint_info($recepient_pin) {}
 694         global triggerpoint_action
 695         set triggerpoint_action($recepient_pin) tp_ignore
 696         tp_switch $recepient_pin
 697
 698         set my_refresh_fragment "
 699             global triggerpoint_info
 700             set i \$triggerpoint_info($recepient_pin)
 701             if {\$i == \"\"} then {
 702                 $wn configure -text \"(watch $mode$args)\"
 703             } else {
 704                 $wn configure -text \"(watch $mode$args: \$i)\"
 705             }
 706             "
 707         global refresh_fragments
 708         set refresh_fragments($wn) $my_refresh_fragment
 709
 710         # must quote "%" in $watcher_name since bind does textual substitutions
 711         regsub -all {%} $watcher_name {%%} watcher_name2
 712         bind $wn <Destroy> "
 713             if {\"%W\" == \"$wn\"} {
 714                 remove_triggerpoint $component $watcher_name2 $recepient_pin
 715                 global refresh_fragments
 716                 if {[info exists refresh_fragments($wn)]} { unset refresh_fragments($wn) }
 717             }"
 718
 719         set event_command \
 720             "global triggerpoint_action
 721              destroy .m
 722              menu .m -tearoff 0
 723              menu .m.action -tearoff 0
 724              .m add cascade -label {Action} -menu .m.action
 725              .m.action add radiobutton -label {Ignore} -variable triggerpoint_action($recepient_pin) -value tp_ignore -command \"tp_switch $recepient_pin\"
 726              .m.action add radiobutton -label {Count} -variable triggerpoint_action($recepient_pin) -value tp_count -command \"tp_switch $recepient_pin\"
 727              .m.action add radiobutton -label {Stop} -variable triggerpoint_action($recepient_pin) -value tp_stop -command \"tp_switch $recepient_pin\"
 728              if {! \[any_stop_pins_p\]} then { .m.action entryconfigure 2 -state disabled }
 729              .m add command -label {Reset} -command \"tp_switch $recepient_pin\"
 730              .m add command -label {Delete} -command \"pack forget $wn ; destroy $wn\"
 731              tk_popup .m %X %Y"
 732         bind $wn <Button-1> $event_command
 733         bind $wn <Button-3> $event_command
 734         bind $wn <Enter> "$wn configure -foreground yellow"
 735         bind $wn <Leave> "$wn configure -foreground black"
 736
 737
 738         pack $wn -side right -fill none
 739     } else {
 740         tk_dialog .oops3 Oops "Cannot set a $mode triggerpoint on $watchable: $s" "error" 0 "oh well"
 741     }
 742 }
 743
 744
 745
 746 # SID callbacks
 747
 748 # XXX: proc unrelate {rel comp} { }
 749
 750 proc relate {rel comp} {
 751     # XXX: what if type or name has a space in it?
 752     set type [lindex $rel 0]
 753     set name [lindex $rel 1]
 754
 755     global components
 756     set components($name) $comp
 757
 758     # handle any pending relations for gui components
 759     global compgui_pending_relations
 760     if {[info exists compgui_pending_relations($name,component)]} then {
 761         sid::component::relate $comp \
 762                 $compgui_pending_relations($name,relation) \
 763                 $compgui_pending_relations($name,component)
 764     }
 765
 766     # puts "$name $type $comp"
 767
 768     frame .c_$name -relief sunken -borderwidth 2
 769     label .c_$name.name -text $name
 770     label .c_$name.type -text $type
 771     pack .c_$name.name -side left
 772     pack .c_$name.type -side right
 773     pack .c_$name -side top -fill x -ipadx 20
 774
 775     set event_command \
 776        "destroy .m
 777         menu .m -tearoff 0
 778
 779         menu .m.views -tearoff 0
 780         .m add cascade -label {View} -menu .m.views
 781         .m.views add command -label Registers -command \"open_component_window register $name $type $comp; destroy .m\"
 782
 783         if \[have_none_p $comp register\] { .m.views entryconfigure 0 -state disabled }
 784        .m.views add command -label Pins -command \"open_component_window pin $name $type $comp; destroy .m\"
 785         if \[have_none_p $comp pin\] { .m.views entryconfigure 1 -state disabled }
 786        .m.views add command -label Settings -command \"open_component_window setting $name $type $comp; destroy .m\"
 787         if \[have_none_p $comp setting\] { .m.views entryconfigure 2 -state disabled }
 788
 789         menu .m.guis -tearoff 0
 790         .m add cascade -label {GUIs} -menu .m.guis"
 791     foreach gui [sid::component::attribute_names_in_category $comp gui] {
 792         append event_command "
 793         .m.guis add command -label \"$gui\" -command \"open_component_gui {$gui} {$name} {$type} {$comp}; destroy .m\" "
 794     }
 795
 796     append event_command "
 797         if \[have_none_p $comp gui\] { .m entryconfigure 3 -state disabled }
 798         tk_popup .m %X %Y"
 799
 800     bind .c_$name.name <Button-1> $event_command
 801     bind .c_$name.name <Button-3> $event_command
 802     bind .c_$name.type <Button-1> $event_command
 803     bind .c_$name.type <Button-3> $event_command
 804     bind .c_$name.name <Enter> ".c_$name.name configure -foreground yellow"
 805     bind .c_$name.name <Leave> ".c_$name.name configure -foreground black"
 806     bind .c_$name.type <Enter> ".c_$name.type configure -foreground yellow"
 807     bind .c_$name.type <Leave> ".c_$name.type configure -foreground black"
 808 }
 809
 810
 811 proc find_pin { name } {
 812     # triggerpoint pins don't have to be listed here
 813     global refresh_pin
 814     if {$name == "refresh" } then { return $refresh_pin }
 815     return ""
 816 }
 817
 818 proc pin_names {} {
 819     # triggerpoint pins don't have to be listed here
 820     return [list "refresh"]
 821 }
 822
 823 proc driven_h4 {pin value} {
 824     global triggerpoint_action
 825     if {[info exists triggerpoint_action($pin)]} then {
 826         eval $triggerpoint_action($pin) $pin
 827         # global triggerpoint_info
 828         # puts "$triggerpoint_action($pin) $pin -> $triggerpoint_info($pin)"
 829         return
 830     }
 831     global refresh_pin
 832     global refresh_ok
 833     if {$pin == $refresh_pin && $refresh_ok == 1} then {
 834         refresh_all
 835         return
 836     }
 837 }
 838
 839 proc connect_pin {name pin} {
 840     if {$name == "triggerpoint-hit"} then {
 841         global stop_pins
 842         lappend stop_pins $pin
 843         return "ok"
 844     }
 845     return "not_found"
 846 }
 847
 848 proc disconnect_pin {name pin} {
 849     if {$name == "triggerpoint-hit"} then {
 850         global stop_pins
 851         set ix [lsearch -exact stop_pins $pin]
 852         if {$ix >= 0} then {
 853             lreplace stop_pins $ix $ix
 854         } else {
 855             return "bad_value"
 856         }
 857         return "ok"
 858     }
 859     return "not_found"
 860 }
 861
 862 proc connected_pins {name} {
 863     if {$name == "triggerpoint-hit"} then {
 864         global stop_pins
 865         return $stop_pins
 866     }
 867     return ""
 868 }
 869 proc bus_names {} { return "" }
 870 proc find_bus {b} { return "" }
 871
 872 # stubs that allow this component to be listed safely in itself
 873 proc attribute_names_in_category { category } {
 874     if {$category == "auto-print"} then {
 875         return [list "warning"]
 876     } else {
 877         return [list]
 878     }
 879 }
 880 proc attribute_names {} {
 881     return [list "warning"]
 882 }
 883 proc attribute_value {name} {
 884     if {$name == "warning"} then {
 885         return "WARNING: TKSM is experimental and is recommended for advanced users only."
 886     } else {
 887         return ""
 888     }
 889 }
 890 proc set_attribute_value {name} { return bad_value }
 891
 892 proc accessor_names {} { return [list] }
 893 proc relationship_names {} { return [list] }
 894
 895 # Local Variables:
 896 # mode: tcl
 897 # End: