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