| 1 | # ---------------------------------------------------------------------- |
|---|
| 2 | # TEST HARNESS for the P2P infrastructure |
|---|
| 3 | # |
|---|
| 4 | # This script drives the test setup and visualization for the P2P |
|---|
| 5 | # infrastructure. It launches the authority server(s) and various |
|---|
| 6 | # workers, and helps to visualize their interactions. |
|---|
| 7 | # ---------------------------------------------------------------------- |
|---|
| 8 | # Michael McLennan (mmclennan@purdue.edu) |
|---|
| 9 | # ====================================================================== |
|---|
| 10 | # Copyright (c) 2008 Purdue Research Foundation |
|---|
| 11 | # ====================================================================== |
|---|
| 12 | package require Itcl |
|---|
| 13 | |
|---|
| 14 | # recognize other library files in this same directory |
|---|
| 15 | set dir [file dirname [info script]] |
|---|
| 16 | lappend auto_path $dir |
|---|
| 17 | |
|---|
| 18 | set time0 [clock seconds] |
|---|
| 19 | set processes "" |
|---|
| 20 | set nodes(all) "" |
|---|
| 21 | set nodeRadius 15 |
|---|
| 22 | |
|---|
| 23 | # ====================================================================== |
|---|
| 24 | # SHAPES |
|---|
| 25 | # ====================================================================== |
|---|
| 26 | itcl::class Shape { |
|---|
| 27 | private variable _canvas "" ;# shape sits on this canvas |
|---|
| 28 | private variable _ranges "" ;# list of time ranges for shape |
|---|
| 29 | private common _shapesOnCanvas ;# maps canvas => list of shapes |
|---|
| 30 | |
|---|
| 31 | public variable command "" ;# command template used to create shape |
|---|
| 32 | |
|---|
| 33 | constructor {canvas args} { |
|---|
| 34 | # add this shape to the list of shapes on this canvas |
|---|
| 35 | lappend _shapesOnCanvas($canvas) $this |
|---|
| 36 | set _canvas $canvas |
|---|
| 37 | eval configure $args |
|---|
| 38 | } |
|---|
| 39 | destructor { |
|---|
| 40 | # remove this shape from the list of shapes on the canvas |
|---|
| 41 | set i [lsearch $_shapesOnCanvas($_canvas) $this] |
|---|
| 42 | if {$i >= 0} { |
|---|
| 43 | set _shapesOnCanvas($_canvas) \ |
|---|
| 44 | [lreplace $_shapesOnCanvas($_canvas) $i $i] |
|---|
| 45 | } |
|---|
| 46 | } |
|---|
| 47 | |
|---|
| 48 | # ------------------------------------------------------------------ |
|---|
| 49 | # METHOD: addRange <time0> <time1> |
|---|
| 50 | # Declares that this shape exists during the given time range |
|---|
| 51 | # between <time0> and <time1>. |
|---|
| 52 | # ------------------------------------------------------------------ |
|---|
| 53 | public method addRange {t0 t1} { |
|---|
| 54 | # see if there's any overlap with existing ranges |
|---|
| 55 | set ri0 -1 |
|---|
| 56 | set ri1 -1 |
|---|
| 57 | for {set i 0} {$i < [llength $_ranges]} {incr i} { |
|---|
| 58 | set pair [lindex $_ranges $i] |
|---|
| 59 | foreach {r0 r1} $pair break |
|---|
| 60 | if {$r0 >= $t0 && $r0 <= $t1} { |
|---|
| 61 | set ri0 $i |
|---|
| 62 | } |
|---|
| 63 | if {$r1 >= $t0 && $r1 <= $t1} { |
|---|
| 64 | set ri1 $i |
|---|
| 65 | } |
|---|
| 66 | incr i |
|---|
| 67 | } |
|---|
| 68 | |
|---|
| 69 | if {$ri0 < 0 && $ri1 < 1} { |
|---|
| 70 | # doesn't overlap with anything -- insert in right place |
|---|
| 71 | for {set i 0} {$i < [llength $_ranges]} {incr i} { |
|---|
| 72 | set pair [lindex $_ranges $i] |
|---|
| 73 | foreach {r0 r1} $pair break |
|---|
| 74 | if {$t0 < $r0} break |
|---|
| 75 | } |
|---|
| 76 | set _ranges [linsert $_ranges $i [list $t0 $t1]] |
|---|
| 77 | } elseif {$ri0 >= 0 && $ri1 >= 0} { |
|---|
| 78 | # overlaps on both limits -- bridge the middle part |
|---|
| 79 | set r0 [lindex [lindex $_ranges $ri0] 0] |
|---|
| 80 | set r1 [lindex [lindex $_ranges $ri1] 1] |
|---|
| 81 | set _ranges [lreplace $_ranges $ri0 $ri1 [list $r0 $r1]] |
|---|
| 82 | } elseif {$ri0 >= 0} { |
|---|
| 83 | # overlaps on the lower limit |
|---|
| 84 | for {set i [expr {[llength $_ranges]-1}]} {$i >= 0} {incr i -1} { |
|---|
| 85 | set pair [lindex $_ranges $i] |
|---|
| 86 | foreach {r0 r1} $pair break |
|---|
| 87 | if {$r0 > $t0 && $r1 < $t1} { |
|---|
| 88 | # remove any ranges completely contained in this one |
|---|
| 89 | set _ranges [lreplace $_ranges $i $i] |
|---|
| 90 | } |
|---|
| 91 | set _ranges [lreplace $_ranges $ri0 $ri1 [list $r0 $r1]] |
|---|
| 92 | } |
|---|
| 93 | set pair [lindex $_ranges $ri0] |
|---|
| 94 | foreach {r0 r1} $pair break |
|---|
| 95 | set _ranges [lreplace $_ranges $ri0 $ri0 [list $r0 $t1]] |
|---|
| 96 | } else { |
|---|
| 97 | # overlaps on the upper limit |
|---|
| 98 | for {set i [expr {[llength $_ranges]-1}]} {$i >= 0} {incr i -1} { |
|---|
| 99 | set pair [lindex $_ranges $i] |
|---|
| 100 | foreach {r0 r1} $pair break |
|---|
| 101 | if {$r0 > $t0 && $r1 < $t1} { |
|---|
| 102 | # remove any ranges completely contained in this one |
|---|
| 103 | set _ranges [lreplace $_ranges $i $i] |
|---|
| 104 | } |
|---|
| 105 | set _ranges [lreplace $_ranges $ri0 $ri1 [list $r0 $r1]] |
|---|
| 106 | } |
|---|
| 107 | set pair [lindex $_ranges $ri1] |
|---|
| 108 | foreach {r0 r1} $pair break |
|---|
| 109 | set _ranges [lreplace $_ranges $ri1 $ri1 [list $t0 $r1]] |
|---|
| 110 | } |
|---|
| 111 | } |
|---|
| 112 | |
|---|
| 113 | # ------------------------------------------------------------------ |
|---|
| 114 | # METHOD: exists <time> |
|---|
| 115 | # Checks to see if this shape exists at the given <time>. |
|---|
| 116 | # Returns 1 if so, and 0 otherwise. |
|---|
| 117 | # ------------------------------------------------------------------ |
|---|
| 118 | public method exists {t} { |
|---|
| 119 | for {set i 0} {$i < [llength $_ranges]} {incr i} { |
|---|
| 120 | set pair [lindex $_ranges $i] |
|---|
| 121 | foreach {r0 r1} $pair break |
|---|
| 122 | if {$t >= $r0 && $t <= $r1} { |
|---|
| 123 | return 1 |
|---|
| 124 | } |
|---|
| 125 | } |
|---|
| 126 | return 0 |
|---|
| 127 | } |
|---|
| 128 | |
|---|
| 129 | # ------------------------------------------------------------------ |
|---|
| 130 | # PROC: draw <canvas> <time> |
|---|
| 131 | # Finds the list of shapes that exist on the given <canvas> at |
|---|
| 132 | # the specified time, and executes all of their associated |
|---|
| 133 | # -command templates, adding them to the canvas. |
|---|
| 134 | # ------------------------------------------------------------------ |
|---|
| 135 | public proc draw {canvas time} { |
|---|
| 136 | if {[info exists _shapesOnCanvas($canvas)]} { |
|---|
| 137 | foreach obj $_shapesOnCanvas($canvas) { |
|---|
| 138 | if {[$obj exists $time]} { |
|---|
| 139 | set cmd [$obj cget -command] |
|---|
| 140 | regsub -all %c $cmd $canvas cmd |
|---|
| 141 | eval $cmd |
|---|
| 142 | } |
|---|
| 143 | } |
|---|
| 144 | } |
|---|
| 145 | } |
|---|
| 146 | |
|---|
| 147 | # ------------------------------------------------------------------ |
|---|
| 148 | # PROC: clear <canvas> |
|---|
| 149 | # Removes all shapes associated with the specified <canvas>. |
|---|
| 150 | # ------------------------------------------------------------------ |
|---|
| 151 | public proc clear {canvas} { |
|---|
| 152 | if {[info exists _shapesOnCanvas($canvas)]} { |
|---|
| 153 | eval itcl::delete object $_shapesOnCanvas($canvas) |
|---|
| 154 | } |
|---|
| 155 | } |
|---|
| 156 | } |
|---|
| 157 | |
|---|
| 158 | # ====================================================================== |
|---|
| 159 | # Build the main interface |
|---|
| 160 | # ====================================================================== |
|---|
| 161 | frame .cntls |
|---|
| 162 | pack .cntls -fill x |
|---|
| 163 | |
|---|
| 164 | button .cntls.start -text "Start" -command test_start |
|---|
| 165 | pack .cntls.start -side left -padx 4 -pady 2 |
|---|
| 166 | |
|---|
| 167 | button .cntls.stop -text "Stop" -command test_stop -state disabled |
|---|
| 168 | pack .cntls.stop -side left -padx 4 -pady 2 |
|---|
| 169 | |
|---|
| 170 | button .cntls.reload -text "Reload" -command test_reload |
|---|
| 171 | pack .cntls.reload -side left -padx 4 -pady 2 |
|---|
| 172 | |
|---|
| 173 | button .cntls.layout -text "New Layout" -command { |
|---|
| 174 | foreach key [array names nodes *-\[xy\]] { |
|---|
| 175 | unset nodes($key) |
|---|
| 176 | } |
|---|
| 177 | after idle test_reload |
|---|
| 178 | } |
|---|
| 179 | pack .cntls.layout -side left -padx 4 -pady 2 |
|---|
| 180 | |
|---|
| 181 | frame .player |
|---|
| 182 | pack .player -side bottom -fill x |
|---|
| 183 | |
|---|
| 184 | button .player.back -text "<" -command {test_frame_go -1 nudge} |
|---|
| 185 | pack .player.back -side left -padx 4 -pady 2 |
|---|
| 186 | |
|---|
| 187 | button .player.fwd -text ">" -command {test_frame_go 1 nudge} |
|---|
| 188 | pack .player.fwd -side left -padx 4 -pady 2 |
|---|
| 189 | |
|---|
| 190 | scale .player.scale -label "Frame" -orient horizontal \ |
|---|
| 191 | -from 0 -to 1 -showvalue 0 -command {test_frame_go 1} |
|---|
| 192 | pack .player.scale -side left -expand yes -fill x -padx 4 -pady 2 |
|---|
| 193 | |
|---|
| 194 | frame .view |
|---|
| 195 | pack .view -side bottom -anchor w |
|---|
| 196 | label .view.show -text "Show:" |
|---|
| 197 | grid .view.show -row 0 -column 0 -sticky e |
|---|
| 198 | radiobutton .view.network -text "P2P Network" -variable view -value network -command test_view_change |
|---|
| 199 | grid .view.network -row 0 -column 1 -sticky w |
|---|
| 200 | radiobutton .view.traffic -text "Network traffic" -variable view -value traffic -command test_view_change |
|---|
| 201 | grid .view.traffic -row 1 -column 1 -sticky w |
|---|
| 202 | |
|---|
| 203 | frame .diagram |
|---|
| 204 | pack .diagram -expand yes -fill both |
|---|
| 205 | canvas .diagram.network -width 500 -height 400 |
|---|
| 206 | canvas .diagram.traffic -width 500 -height 400 |
|---|
| 207 | |
|---|
| 208 | after idle .view.traffic invoke |
|---|
| 209 | |
|---|
| 210 | proc test_stop {} { |
|---|
| 211 | global processes |
|---|
| 212 | |
|---|
| 213 | # kill any existing processes |
|---|
| 214 | foreach job $processes { |
|---|
| 215 | exec kill $job |
|---|
| 216 | } |
|---|
| 217 | set processes "" |
|---|
| 218 | |
|---|
| 219 | .cntls.stop configure -state disabled |
|---|
| 220 | .cntls.start configure -state normal |
|---|
| 221 | |
|---|
| 222 | after idle test_reload |
|---|
| 223 | } |
|---|
| 224 | |
|---|
| 225 | proc test_start {} { |
|---|
| 226 | global processes |
|---|
| 227 | |
|---|
| 228 | # clean up existing log files... |
|---|
| 229 | foreach fname [glob -nocomplain /tmp/log*] { |
|---|
| 230 | file delete $fname |
|---|
| 231 | } |
|---|
| 232 | |
|---|
| 233 | # launch a new authority server |
|---|
| 234 | lappend processes [exec tclsh authority.tcl &] |
|---|
| 235 | |
|---|
| 236 | # launch a series of workers |
|---|
| 237 | for {set i 0} {$i < 20} {incr i} { |
|---|
| 238 | lappend processes [exec tclsh worker.tcl &] |
|---|
| 239 | after [expr {int(rand()*5000)}] |
|---|
| 240 | } |
|---|
| 241 | |
|---|
| 242 | .cntls.start configure -state disabled |
|---|
| 243 | .cntls.stop configure -state normal |
|---|
| 244 | } |
|---|
| 245 | |
|---|
| 246 | proc test_reload {} { |
|---|
| 247 | global time0 nodes actions nodeRadius |
|---|
| 248 | |
|---|
| 249 | array set colors { |
|---|
| 250 | authority blue |
|---|
| 251 | worker gray |
|---|
| 252 | } |
|---|
| 253 | |
|---|
| 254 | Shape::clear .diagram.network |
|---|
| 255 | Shape::clear .diagram.traffic |
|---|
| 256 | set tmax 0 |
|---|
| 257 | |
|---|
| 258 | # |
|---|
| 259 | # Scan through all files and generate positions for all nodes. |
|---|
| 260 | # |
|---|
| 261 | foreach fname [glob -nocomplain /tmp/log*] { |
|---|
| 262 | set fid [open $fname r] |
|---|
| 263 | set info [read $fid] |
|---|
| 264 | close $fid |
|---|
| 265 | |
|---|
| 266 | # get the address for this host |
|---|
| 267 | regexp {started at port ([0-9]+)} $info match port |
|---|
| 268 | if {[regexp {options [^\n]+ ip ([^ ]+)} $info match ip]} { |
|---|
| 269 | set addr $ip:$port |
|---|
| 270 | } else { |
|---|
| 271 | set addr 127.0.0.1:$port |
|---|
| 272 | } |
|---|
| 273 | |
|---|
| 274 | set lasttime "" |
|---|
| 275 | set info [split $info \n] |
|---|
| 276 | set first [lindex $info 0] |
|---|
| 277 | regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+) +(authority|worker)} $first match t0 type |
|---|
| 278 | set t0val [expr {([clock scan $t0]-$time0)*100}] |
|---|
| 279 | |
|---|
| 280 | set last [lindex $info end-1] |
|---|
| 281 | regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+)} $last match t1 |
|---|
| 282 | set t1val [expr {([clock scan $t1]-$time0)*100 + 99}] |
|---|
| 283 | set margin 20 |
|---|
| 284 | set r $nodeRadius |
|---|
| 285 | |
|---|
| 286 | set nodes($fname) $addr |
|---|
| 287 | set nodes($addr-log) $fname |
|---|
| 288 | set nodes($addr-type) $type |
|---|
| 289 | if {![info exists nodes($addr-x)]} { |
|---|
| 290 | set w [expr {[winfo width .diagram]-2*$margin}] |
|---|
| 291 | set h [expr {[winfo height .diagram]-2*$margin}] |
|---|
| 292 | set nodes($addr-x) [expr {int(rand()*$w) + $margin}] |
|---|
| 293 | set nodes($addr-y) [expr {int(rand()*$h) + $margin}] |
|---|
| 294 | } |
|---|
| 295 | set x $nodes($addr-x) |
|---|
| 296 | set y $nodes($addr-y) |
|---|
| 297 | |
|---|
| 298 | foreach canv {.diagram.traffic .diagram.network} { |
|---|
| 299 | set s [Shape ::#auto $canv -command \ |
|---|
| 300 | [list %c create oval [expr {$x-$r}] [expr {$y-$r}] \ |
|---|
| 301 | [expr {$x+$r}] [expr {$y+$r}] \ |
|---|
| 302 | -outline black -fill $colors($type) \ |
|---|
| 303 | -tags [list $fname $fname-node]]] |
|---|
| 304 | $s addRange $t0val $t1val |
|---|
| 305 | } |
|---|
| 306 | |
|---|
| 307 | append actions($t0val) "$type $addr online\n" |
|---|
| 308 | append actions($t1val) "$type $addr offline\n" |
|---|
| 309 | |
|---|
| 310 | if {$t1val > $tmax} { set tmax $t1val } |
|---|
| 311 | } |
|---|
| 312 | |
|---|
| 313 | # |
|---|
| 314 | # Scan through files again and generate shapes for all messages |
|---|
| 315 | # |
|---|
| 316 | foreach fname [glob -nocomplain /tmp/log*] { |
|---|
| 317 | set fid [open $fname r] |
|---|
| 318 | set info [read $fid] |
|---|
| 319 | close $fid |
|---|
| 320 | puts "\nscanning $fname" |
|---|
| 321 | |
|---|
| 322 | catch {unset started} |
|---|
| 323 | set peerlist(addrs) "" |
|---|
| 324 | set peerlist(time) 0 |
|---|
| 325 | set lasttime "" |
|---|
| 326 | set counter 0 |
|---|
| 327 | foreach line [split $info \n] { |
|---|
| 328 | if {[regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+) (.+)$} $line match time mesg]} { |
|---|
| 329 | set tval [expr {([clock scan $time]-$time0)*100}] |
|---|
| 330 | |
|---|
| 331 | if {$time == $lasttime} { |
|---|
| 332 | set tval [expr {$tval + [incr counter]}] |
|---|
| 333 | } |
|---|
| 334 | set lasttime $time |
|---|
| 335 | |
|---|
| 336 | if {$tval > $tmax} { set tmax $tval } |
|---|
| 337 | |
|---|
| 338 | if {[regexp {accepted: +([^ ]+) +\((.+)\)} $mesg match addr cid]} { |
|---|
| 339 | append actions($tval) $mesg \n |
|---|
| 340 | set started(connect$cid-time) $tval |
|---|
| 341 | set started(connect$cid-addr) ? |
|---|
| 342 | |
|---|
| 343 | } elseif {[regexp {dropped: +([^ ]+) +\((.+)\)} $mesg match addr cid] && [info exists started(connect$cid-time)]} { |
|---|
| 344 | append actions($tval) $mesg \n |
|---|
| 345 | set from $nodes($fname) |
|---|
| 346 | set x0 $nodes($from-x) |
|---|
| 347 | set y0 $nodes($from-y) |
|---|
| 348 | set x1 $nodes($addr-x) |
|---|
| 349 | set y1 $nodes($addr-y) |
|---|
| 350 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 351 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
|---|
| 352 | $s addRange $started(connect$cid-time) $tval |
|---|
| 353 | |
|---|
| 354 | unset started(connect$cid-time) |
|---|
| 355 | unset started(connect$cid-addr) |
|---|
| 356 | |
|---|
| 357 | } elseif {[regexp {server message from ([a-zA-Z0-9\.]+:[0-9]+) \(([a-z0-9]+)\): +(.+) => (.*)} $mesg match addr cid cmd result]} { |
|---|
| 358 | if {![string match identity* $cmd]} { |
|---|
| 359 | append actions($tval) $mesg \n |
|---|
| 360 | set from $nodes($fname) |
|---|
| 361 | set x0 $nodes($from-x) |
|---|
| 362 | set y0 $nodes($from-y) |
|---|
| 363 | set x1 $nodes($addr-x) |
|---|
| 364 | set y1 $nodes($addr-y) |
|---|
| 365 | set w [expr {[winfo width .diagram]/2}] |
|---|
| 366 | |
|---|
| 367 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 368 | [list %c create line [expr $x0-3] [expr $y0-3] [expr $x1-3] [expr $y1-3] -fill black -arrow first -tags transient]] |
|---|
| 369 | $s addRange $tval $tval |
|---|
| 370 | |
|---|
| 371 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 372 | [list %c create text [expr {0.5*($x0+$x1)}] [expr {0.5*($y0+$y1)-1}] -width $w -fill black -anchor s -text $cmd -tags transient]] |
|---|
| 373 | $s addRange $tval $tval |
|---|
| 374 | |
|---|
| 375 | if {"" != [string trim $result]} { |
|---|
| 376 | if {[regexp {^ok:} $result]} { |
|---|
| 377 | set color black |
|---|
| 378 | } else { |
|---|
| 379 | set color red |
|---|
| 380 | } |
|---|
| 381 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 382 | [list %c create line [expr $x0+3] [expr $y0+3] [expr $x1+3] [expr $y1+3] -fill $color -arrow last -tags transient]] |
|---|
| 383 | $s addRange $tval $tval |
|---|
| 384 | |
|---|
| 385 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 386 | [list %c create text [expr {0.5*($x0+$x1)}] [expr {0.5*($y0+$y1)+1}] -width $w -fill $color -anchor n -text $result -tags transient]] |
|---|
| 387 | $s addRange $tval $tval |
|---|
| 388 | } |
|---|
| 389 | } |
|---|
| 390 | |
|---|
| 391 | # no address for this client yet? then save this info |
|---|
| 392 | if {[info exists started(connect$cid-addr)] |
|---|
| 393 | && $started(connect$cid-addr) == "?"} { |
|---|
| 394 | set started(connect$cid-addr) $addr |
|---|
| 395 | } |
|---|
| 396 | |
|---|
| 397 | } elseif {[regexp {connected to peers: (.*)} $mesg match plist]} { |
|---|
| 398 | # draw a highlight ring, indicating that peers have changed |
|---|
| 399 | set from $nodes($fname) |
|---|
| 400 | set x $nodes($from-x) |
|---|
| 401 | set y $nodes($from-y) |
|---|
| 402 | foreach canv {.diagram.traffic .diagram.network} { |
|---|
| 403 | set s [Shape ::#auto $canv -command \ |
|---|
| 404 | [list %c create oval [expr {$x-$r-3}] [expr {$y-$r-3}] [expr {$x+$r+3}] [expr {$y+$r+3}] -outline red -fill "" -tags transient]] |
|---|
| 405 | $s addRange $tval [expr {$tval+20}] |
|---|
| 406 | } |
|---|
| 407 | |
|---|
| 408 | # draw lines from the previous peer list, now that |
|---|
| 409 | # we know it's time range is done. |
|---|
| 410 | foreach addr $peerlist(addrs) { |
|---|
| 411 | set from $nodes($fname) |
|---|
| 412 | set x0 $nodes($from-x) |
|---|
| 413 | set y0 $nodes($from-y) |
|---|
| 414 | set x1 $nodes($addr-x) |
|---|
| 415 | set y1 $nodes($addr-y) |
|---|
| 416 | set s [Shape ::#auto .diagram.network -command \ |
|---|
| 417 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
|---|
| 418 | $s addRange $peerlist(time) $tval |
|---|
| 419 | } |
|---|
| 420 | |
|---|
| 421 | # save the start of this new peer list |
|---|
| 422 | set peerlist(addrs) $plist |
|---|
| 423 | set peerlist(time) $tval |
|---|
| 424 | } |
|---|
| 425 | } |
|---|
| 426 | } |
|---|
| 427 | |
|---|
| 428 | # any connections hanging out that we haven't drawn? |
|---|
| 429 | foreach key [array names started connect*-addr] { |
|---|
| 430 | regexp {connect([^-]+)-addr} $key match cid |
|---|
| 431 | set from $nodes($fname) |
|---|
| 432 | set addr $started($key) |
|---|
| 433 | set x0 $nodes($from-x) |
|---|
| 434 | set y0 $nodes($from-y) |
|---|
| 435 | set x1 $nodes($addr-x) |
|---|
| 436 | set y1 $nodes($addr-y) |
|---|
| 437 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 438 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
|---|
| 439 | $s addRange $started(connect$cid-time) $tval |
|---|
| 440 | |
|---|
| 441 | unset started(connect$cid-time) |
|---|
| 442 | unset started(connect$cid-addr) |
|---|
| 443 | } |
|---|
| 444 | |
|---|
| 445 | .diagram.traffic bind $fname <Enter> " |
|---|
| 446 | %W itemconfigure $fname-node -outline red |
|---|
| 447 | %W itemconfigure $fname-cnx -fill red |
|---|
| 448 | %W raise $fname-cnx |
|---|
| 449 | " |
|---|
| 450 | .diagram.traffic bind $fname <Leave> " |
|---|
| 451 | %W itemconfigure $fname-node -outline black |
|---|
| 452 | %W itemconfigure $fname-cnx -fill gray |
|---|
| 453 | %W raise transient |
|---|
| 454 | " |
|---|
| 455 | |
|---|
| 456 | foreach canv {.diagram.network .diagram.traffic} { |
|---|
| 457 | $canv bind $fname-node <ButtonPress-1> \ |
|---|
| 458 | [list worker_node_click %W $fname %x %y] |
|---|
| 459 | $canv bind $fname-node <B1-Motion> \ |
|---|
| 460 | [list worker_node_drag %W $fname %x %y] |
|---|
| 461 | $canv bind $fname-node <ButtonRelease-1> \ |
|---|
| 462 | [list worker_node_release %W $fname %x %y] |
|---|
| 463 | } |
|---|
| 464 | |
|---|
| 465 | # any peer connections that we haven't drawn? then do it now |
|---|
| 466 | foreach addr $peerlist(addrs) { |
|---|
| 467 | set from $nodes($fname) |
|---|
| 468 | set x0 $nodes($from-x) |
|---|
| 469 | set y0 $nodes($from-y) |
|---|
| 470 | set x1 $nodes($addr-x) |
|---|
| 471 | set y1 $nodes($addr-y) |
|---|
| 472 | set s [Shape ::#auto .diagram.network -command \ |
|---|
| 473 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
|---|
| 474 | $s addRange $peerlist(time) $tmax |
|---|
| 475 | } |
|---|
| 476 | |
|---|
| 477 | .diagram.network bind $fname <Enter> " |
|---|
| 478 | %W itemconfigure $fname-node -outline red |
|---|
| 479 | %W itemconfigure $fname-cnx -fill red |
|---|
| 480 | %W raise $fname-cnx |
|---|
| 481 | " |
|---|
| 482 | .diagram.network bind $fname <Leave> " |
|---|
| 483 | %W itemconfigure $fname-node -outline black |
|---|
| 484 | %W itemconfigure $fname-cnx -fill gray |
|---|
| 485 | %W raise transient |
|---|
| 486 | " |
|---|
| 487 | } |
|---|
| 488 | .player.scale configure -to $tmax |
|---|
| 489 | |
|---|
| 490 | after cancel test_visualize |
|---|
| 491 | after idle test_visualize |
|---|
| 492 | } |
|---|
| 493 | |
|---|
| 494 | proc worker_node_click {canv fname x y} { |
|---|
| 495 | $canv itemconfigure $fname-node -stipple gray50 |
|---|
| 496 | } |
|---|
| 497 | |
|---|
| 498 | proc worker_node_drag {canv fname x y} { |
|---|
| 499 | global nodeRadius |
|---|
| 500 | $canv itemconfigure $fname-node -stipple "" |
|---|
| 501 | $canv coords $fname-node [expr {$x-$nodeRadius}] [expr {$y-$nodeRadius}] [expr {$x+$nodeRadius}] [expr {$y+$nodeRadius}] |
|---|
| 502 | } |
|---|
| 503 | |
|---|
| 504 | proc worker_node_release {canv fname x y} { |
|---|
| 505 | global move nodes |
|---|
| 506 | |
|---|
| 507 | worker_node_drag $canv $fname $x $y |
|---|
| 508 | $canv itemconfigure $fname-node -stipple "" |
|---|
| 509 | |
|---|
| 510 | set addr $nodes($fname) |
|---|
| 511 | set nodes($addr-x) $x |
|---|
| 512 | set nodes($addr-y) $y |
|---|
| 513 | after idle test_reload |
|---|
| 514 | } |
|---|
| 515 | |
|---|
| 516 | proc test_frame_go {dir position} { |
|---|
| 517 | global actions |
|---|
| 518 | |
|---|
| 519 | set tmax [.player.scale cget -to] |
|---|
| 520 | if {"nudge" == $position} { |
|---|
| 521 | set nframe [.player.scale get] |
|---|
| 522 | incr nframe $dir |
|---|
| 523 | } else { |
|---|
| 524 | set nframe $position |
|---|
| 525 | } |
|---|
| 526 | |
|---|
| 527 | while {![info exists actions($nframe)] && $nframe > 0 && $nframe < $tmax} { |
|---|
| 528 | incr nframe $dir |
|---|
| 529 | } |
|---|
| 530 | |
|---|
| 531 | # set the scale to this new position |
|---|
| 532 | .player.scale configure -command "" |
|---|
| 533 | .player.scale set $nframe |
|---|
| 534 | .player.scale configure -command {test_frame_go 1} |
|---|
| 535 | |
|---|
| 536 | after cancel test_visualize |
|---|
| 537 | after idle test_visualize |
|---|
| 538 | } |
|---|
| 539 | |
|---|
| 540 | proc test_visualize {} { |
|---|
| 541 | .diagram.traffic delete all |
|---|
| 542 | Shape::draw .diagram.traffic [.player.scale get] |
|---|
| 543 | .diagram.traffic raise transient |
|---|
| 544 | |
|---|
| 545 | .diagram.network delete all |
|---|
| 546 | Shape::draw .diagram.network [.player.scale get] |
|---|
| 547 | .diagram.network raise transient |
|---|
| 548 | } |
|---|
| 549 | |
|---|
| 550 | proc test_view_change {} { |
|---|
| 551 | global view |
|---|
| 552 | foreach widget [pack slaves .diagram] { |
|---|
| 553 | catch {pack forget $widget} |
|---|
| 554 | } |
|---|
| 555 | pack .diagram.$view -expand yes -fill both |
|---|
| 556 | } |
|---|
