[1251] | 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 | # ====================================================================== |
---|
[3177] | 10 | # Copyright (c) 2004-2012 HUBzero Foundation, LLC |
---|
[1257] | 11 | # |
---|
| 12 | # See the file "license.terms" for information on usage and |
---|
| 13 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
[1251] | 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 | |
---|
[1273] | 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 | |
---|
[1251] | 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} { |
---|
[2080] | 144 | global times |
---|
[1251] | 145 | if {[info exists _shapesOnCanvas($canvas)]} { |
---|
[2080] | 146 | set y0 5 |
---|
| 147 | if {[info exists times($time)]} { |
---|
| 148 | $canvas create text 5 $y0 -anchor nw -text $times($time) |
---|
| 149 | incr y0 15 |
---|
| 150 | } |
---|
| 151 | $canvas create text 5 $y0 -anchor nw -tags entity |
---|
| 152 | |
---|
[1251] | 153 | foreach obj $_shapesOnCanvas($canvas) { |
---|
| 154 | if {[$obj exists $time]} { |
---|
| 155 | set cmd [$obj cget -command] |
---|
| 156 | regsub -all %c $cmd $canvas cmd |
---|
| 157 | eval $cmd |
---|
| 158 | } |
---|
| 159 | } |
---|
| 160 | } |
---|
| 161 | } |
---|
| 162 | |
---|
| 163 | # ------------------------------------------------------------------ |
---|
| 164 | # PROC: clear <canvas> |
---|
| 165 | # Removes all shapes associated with the specified <canvas>. |
---|
| 166 | # ------------------------------------------------------------------ |
---|
| 167 | public proc clear {canvas} { |
---|
| 168 | if {[info exists _shapesOnCanvas($canvas)]} { |
---|
| 169 | eval itcl::delete object $_shapesOnCanvas($canvas) |
---|
| 170 | } |
---|
| 171 | } |
---|
| 172 | } |
---|
| 173 | |
---|
| 174 | # ====================================================================== |
---|
| 175 | # Build the main interface |
---|
| 176 | # ====================================================================== |
---|
[1273] | 177 | frame .client -borderwidth 8 -relief flat |
---|
| 178 | pack .client -side right -fill y |
---|
| 179 | button .client.getbids -text "Get Bids:" -command test_bids |
---|
| 180 | pack .client.getbids -side top -anchor w |
---|
| 181 | frame .client.cntls |
---|
| 182 | pack .client.cntls -side bottom -fill x |
---|
| 183 | button .client.cntls.run -text "Spend" -command test_spend |
---|
| 184 | pack .client.cntls.run -side left |
---|
| 185 | entry .client.cntls.points -width 8 |
---|
| 186 | pack .client.cntls.points -side left |
---|
| 187 | label .client.cntls.pointsl -text "points" |
---|
| 188 | pack .client.cntls.pointsl -side left |
---|
| 189 | |
---|
| 190 | frame .client.bids |
---|
| 191 | pack .client.bids -side bottom -expand yes -fill both |
---|
| 192 | scrollbar .client.bids.ysbar -orient vertical -command {.client.bids.info yview} |
---|
| 193 | pack .client.bids.ysbar -side right -fill y |
---|
| 194 | listbox .client.bids.info -yscrollcommand {.client.bids.ysbar set} |
---|
| 195 | pack .client.bids.info -side left -expand yes -fill both |
---|
| 196 | |
---|
[1251] | 197 | frame .cntls |
---|
| 198 | pack .cntls -fill x |
---|
| 199 | |
---|
| 200 | button .cntls.start -text "Start" -command test_start |
---|
| 201 | pack .cntls.start -side left -padx 4 -pady 2 |
---|
| 202 | |
---|
| 203 | button .cntls.stop -text "Stop" -command test_stop -state disabled |
---|
| 204 | pack .cntls.stop -side left -padx 4 -pady 2 |
---|
| 205 | |
---|
| 206 | button .cntls.reload -text "Reload" -command test_reload |
---|
| 207 | pack .cntls.reload -side left -padx 4 -pady 2 |
---|
| 208 | |
---|
| 209 | button .cntls.layout -text "New Layout" -command { |
---|
| 210 | foreach key [array names nodes *-\[xy\]] { |
---|
| 211 | unset nodes($key) |
---|
| 212 | } |
---|
| 213 | after idle test_reload |
---|
| 214 | } |
---|
| 215 | pack .cntls.layout -side left -padx 4 -pady 2 |
---|
| 216 | |
---|
[1273] | 217 | entry .cntls.workers -width 5 |
---|
| 218 | pack .cntls.workers -side right -padx {0 4} -pady 2 |
---|
| 219 | .cntls.workers insert end "3" |
---|
| 220 | label .cntls.workersl -text "Workers:" |
---|
| 221 | pack .cntls.workersl -side right -pady 2 |
---|
| 222 | |
---|
[1251] | 223 | frame .player |
---|
| 224 | pack .player -side bottom -fill x |
---|
| 225 | |
---|
| 226 | button .player.back -text "<" -command {test_frame_go -1 nudge} |
---|
| 227 | pack .player.back -side left -padx 4 -pady 2 |
---|
| 228 | |
---|
| 229 | button .player.fwd -text ">" -command {test_frame_go 1 nudge} |
---|
| 230 | pack .player.fwd -side left -padx 4 -pady 2 |
---|
| 231 | |
---|
[2080] | 232 | button .player.err -text "0 errors" -command {wm deiconify .errors; raise .errors} |
---|
| 233 | pack .player.err -side right -padx 4 -pady 2 |
---|
| 234 | .player.err configure -state disabled |
---|
| 235 | |
---|
[1251] | 236 | scale .player.scale -label "Frame" -orient horizontal \ |
---|
| 237 | -from 0 -to 1 -showvalue 0 -command {test_frame_go 1} |
---|
| 238 | pack .player.scale -side left -expand yes -fill x -padx 4 -pady 2 |
---|
| 239 | |
---|
| 240 | frame .view |
---|
| 241 | pack .view -side bottom -anchor w |
---|
| 242 | label .view.show -text "Show:" |
---|
| 243 | grid .view.show -row 0 -column 0 -sticky e |
---|
| 244 | radiobutton .view.network -text "P2P Network" -variable view -value network -command test_view_change |
---|
| 245 | grid .view.network -row 0 -column 1 -sticky w |
---|
| 246 | radiobutton .view.traffic -text "Network traffic" -variable view -value traffic -command test_view_change |
---|
| 247 | grid .view.traffic -row 1 -column 1 -sticky w |
---|
| 248 | |
---|
| 249 | frame .diagram |
---|
| 250 | pack .diagram -expand yes -fill both |
---|
| 251 | canvas .diagram.network -width 500 -height 400 |
---|
| 252 | canvas .diagram.traffic -width 500 -height 400 |
---|
| 253 | |
---|
| 254 | after idle .view.traffic invoke |
---|
| 255 | |
---|
[2080] | 256 | toplevel .errors |
---|
| 257 | wm title .errors "Error Messages" |
---|
| 258 | wm withdraw .errors |
---|
| 259 | wm protocol .errors WM_DELETE_WINDOW {wm withdraw .errors} |
---|
| 260 | scrollbar .errors.ysbar -orient vertical -command {.errors.info yview} |
---|
| 261 | pack .errors.ysbar -side right -fill y |
---|
| 262 | text .errors.info -yscrollcommand {.errors.ysbar set} -font {Courier 12} |
---|
| 263 | pack .errors.info -expand yes -fill both |
---|
| 264 | .errors.info tag configure timecode -foreground gray |
---|
| 265 | .errors.info tag configure error -foreground red -font {Courier 12 bold} |
---|
| 266 | |
---|
[1251] | 267 | proc test_stop {} { |
---|
| 268 | global processes |
---|
| 269 | |
---|
| 270 | # kill any existing processes |
---|
| 271 | foreach job $processes { |
---|
| 272 | exec kill $job |
---|
| 273 | } |
---|
| 274 | set processes "" |
---|
| 275 | |
---|
| 276 | .cntls.stop configure -state disabled |
---|
| 277 | .cntls.start configure -state normal |
---|
| 278 | |
---|
| 279 | after idle test_reload |
---|
| 280 | } |
---|
| 281 | |
---|
| 282 | proc test_start {} { |
---|
| 283 | global processes |
---|
| 284 | |
---|
| 285 | # clean up existing log files... |
---|
| 286 | foreach fname [glob -nocomplain /tmp/log*] { |
---|
| 287 | file delete $fname |
---|
| 288 | } |
---|
| 289 | |
---|
| 290 | # launch a new authority server |
---|
| 291 | lappend processes [exec tclsh authority.tcl &] |
---|
| 292 | |
---|
| 293 | # launch a series of workers |
---|
[1273] | 294 | for {set i 0} {$i < [.cntls.workers get]} {incr i} { |
---|
[1251] | 295 | lappend processes [exec tclsh worker.tcl &] |
---|
| 296 | after [expr {int(rand()*5000)}] |
---|
| 297 | } |
---|
| 298 | |
---|
| 299 | .cntls.start configure -state disabled |
---|
| 300 | .cntls.stop configure -state normal |
---|
| 301 | } |
---|
| 302 | |
---|
| 303 | proc test_reload {} { |
---|
[2080] | 304 | global time0 nodes actions times nodeRadius |
---|
[1251] | 305 | |
---|
| 306 | array set colors { |
---|
| 307 | authority blue |
---|
| 308 | worker gray |
---|
[2080] | 309 | foreman red |
---|
[1251] | 310 | } |
---|
| 311 | |
---|
| 312 | Shape::clear .diagram.network |
---|
| 313 | Shape::clear .diagram.traffic |
---|
[2080] | 314 | .errors.info configure -state normal |
---|
| 315 | .errors.info delete 1.0 end |
---|
[1251] | 316 | set tmax 0 |
---|
[2080] | 317 | set errs 0 |
---|
[1251] | 318 | |
---|
| 319 | # |
---|
| 320 | # Scan through all files and generate positions for all nodes. |
---|
| 321 | # |
---|
| 322 | foreach fname [glob -nocomplain /tmp/log*] { |
---|
| 323 | set fid [open $fname r] |
---|
| 324 | set info [read $fid] |
---|
| 325 | close $fid |
---|
| 326 | |
---|
[2080] | 327 | set lasttime "" |
---|
| 328 | set t0val ""; set first "" |
---|
| 329 | set t1val ""; set last "" |
---|
| 330 | set info [split $info \n] |
---|
| 331 | foreach line $info { |
---|
| 332 | if {[regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+)} $line match tval]} { |
---|
| 333 | if {"" == $t0val} { |
---|
| 334 | set first $line |
---|
| 335 | set t0val [expr {([clock scan $tval]-$time0)*100}] |
---|
| 336 | } else { |
---|
| 337 | set last $line |
---|
| 338 | set t1val [expr {([clock scan $tval]-$time0)*100 + 99}] |
---|
| 339 | } |
---|
| 340 | } |
---|
| 341 | } |
---|
| 342 | |
---|
| 343 | if {"" == $t0val || "" == $t1val} { |
---|
| 344 | # can't find any log statements -- skip this file! |
---|
[1273] | 345 | continue |
---|
| 346 | } |
---|
| 347 | |
---|
[1251] | 348 | # get the address for this host |
---|
[2080] | 349 | if {[regexp {started at port ([0-9]+)} $info match port]} { |
---|
| 350 | if {[regexp {options [^\n]+ ip ([^ ]+)} $info match ip]} { |
---|
| 351 | set addr $ip:$port |
---|
| 352 | } else { |
---|
| 353 | set addr 127.0.0.1:$port |
---|
| 354 | } |
---|
| 355 | set shape oval |
---|
| 356 | regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+) +(authority|worker)} $first match t0 type |
---|
| 357 | } elseif {[regexp -- {foreman<-} $info]} { |
---|
| 358 | set shape rectangle |
---|
| 359 | set addr "foreman" |
---|
| 360 | set type "foreman" |
---|
[1251] | 361 | } else { |
---|
[2080] | 362 | # unknown log file -- skip it |
---|
| 363 | continue |
---|
[1251] | 364 | } |
---|
| 365 | set margin 20 |
---|
| 366 | set r $nodeRadius |
---|
| 367 | |
---|
| 368 | set nodes($fname) $addr |
---|
| 369 | set nodes($addr-log) $fname |
---|
| 370 | set nodes($addr-type) $type |
---|
| 371 | if {![info exists nodes($addr-x)]} { |
---|
| 372 | set w [expr {[winfo width .diagram]-2*$margin}] |
---|
| 373 | set h [expr {[winfo height .diagram]-2*$margin}] |
---|
| 374 | set nodes($addr-x) [expr {int(rand()*$w) + $margin}] |
---|
| 375 | set nodes($addr-y) [expr {int(rand()*$h) + $margin}] |
---|
| 376 | } |
---|
| 377 | set x $nodes($addr-x) |
---|
| 378 | set y $nodes($addr-y) |
---|
| 379 | |
---|
| 380 | foreach canv {.diagram.traffic .diagram.network} { |
---|
| 381 | set s [Shape ::#auto $canv -command \ |
---|
[2080] | 382 | [list %c create $shape [expr {$x-$r}] [expr {$y-$r}] \ |
---|
[1251] | 383 | [expr {$x+$r}] [expr {$y+$r}] \ |
---|
| 384 | -outline black -fill $colors($type) \ |
---|
| 385 | -tags [list $fname $fname-node]]] |
---|
| 386 | $s addRange $t0val $t1val |
---|
| 387 | } |
---|
| 388 | |
---|
| 389 | append actions($t0val) "$type $addr online\n" |
---|
| 390 | append actions($t1val) "$type $addr offline\n" |
---|
| 391 | |
---|
| 392 | if {$t1val > $tmax} { set tmax $t1val } |
---|
| 393 | } |
---|
| 394 | |
---|
| 395 | # |
---|
| 396 | # Scan through files again and generate shapes for all messages |
---|
| 397 | # |
---|
| 398 | foreach fname [glob -nocomplain /tmp/log*] { |
---|
| 399 | set fid [open $fname r] |
---|
| 400 | set info [read $fid] |
---|
| 401 | close $fid |
---|
| 402 | puts "\nscanning $fname" |
---|
| 403 | |
---|
| 404 | catch {unset started} |
---|
| 405 | set peerlist(addrs) "" |
---|
| 406 | set peerlist(time) 0 |
---|
| 407 | set lasttime "" |
---|
| 408 | set counter 0 |
---|
| 409 | foreach line [split $info \n] { |
---|
| 410 | if {[regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+) (.+)$} $line match time mesg]} { |
---|
| 411 | set tval [expr {([clock scan $time]-$time0)*100}] |
---|
| 412 | |
---|
| 413 | if {$time == $lasttime} { |
---|
| 414 | set tval [expr {$tval + [incr counter]}] |
---|
| 415 | } |
---|
| 416 | set lasttime $time |
---|
| 417 | |
---|
| 418 | if {$tval > $tmax} { set tmax $tval } |
---|
| 419 | |
---|
[2080] | 420 | set cid "" |
---|
[1251] | 421 | if {[regexp {accepted: +([^ ]+) +\((.+)\)} $mesg match addr cid]} { |
---|
| 422 | append actions($tval) $mesg \n |
---|
| 423 | set started(connect$cid-time) $tval |
---|
| 424 | set started(connect$cid-addr) ? |
---|
| 425 | |
---|
| 426 | } elseif {[regexp {dropped: +([^ ]+) +\((.+)\)} $mesg match addr cid] && [info exists started(connect$cid-time)]} { |
---|
[2080] | 427 | incr tval 99 ;# end of this second |
---|
[1251] | 428 | append actions($tval) $mesg \n |
---|
| 429 | set from $nodes($fname) |
---|
| 430 | set x0 $nodes($from-x) |
---|
| 431 | set y0 $nodes($from-y) |
---|
| 432 | set x1 $nodes($addr-x) |
---|
| 433 | set y1 $nodes($addr-y) |
---|
| 434 | set s [Shape ::#auto .diagram.traffic -command \ |
---|
| 435 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
---|
| 436 | $s addRange $started(connect$cid-time) $tval |
---|
| 437 | |
---|
| 438 | unset started(connect$cid-time) |
---|
| 439 | unset started(connect$cid-addr) |
---|
| 440 | |
---|
[2080] | 441 | } elseif {[regexp {(incoming) message from ([^ ]+) \((sock[0-9]+)\): +(.+) => (.*)} $mesg match which addr cid cmd result] |
---|
| 442 | || [regexp {(outgoing) message to ([^ ]+): +(.+)} $mesg match which addr cmd]} { |
---|
| 443 | switch -- $which { |
---|
| 444 | outgoing { |
---|
| 445 | set from $addr |
---|
| 446 | set to $nodes($fname) |
---|
| 447 | } |
---|
| 448 | incoming { |
---|
| 449 | set from $nodes($fname) |
---|
| 450 | set to $addr |
---|
| 451 | # show incoming messages later in time |
---|
| 452 | incr tval 50 |
---|
| 453 | } |
---|
| 454 | } |
---|
| 455 | append actions($tval) $mesg \n |
---|
| 456 | set x0 $nodes($from-x) |
---|
| 457 | set y0 $nodes($from-y) |
---|
| 458 | set x1 $nodes($to-x) |
---|
| 459 | set y1 $nodes($to-y) |
---|
| 460 | set w [expr {[winfo width .diagram]/2}] |
---|
[1251] | 461 | |
---|
[2080] | 462 | set s [Shape ::#auto .diagram.traffic -command \ |
---|
| 463 | [list %c create line [expr $x0-3] [expr $y0-3] [expr $x1-3] [expr $y1-3] -fill black -arrow first -tags transient]] |
---|
| 464 | $s addRange $tval $tval |
---|
| 465 | |
---|
| 466 | set s [Shape ::#auto .diagram.traffic -command \ |
---|
| 467 | [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]] |
---|
| 468 | $s addRange $tval $tval |
---|
| 469 | |
---|
| 470 | if {$which == "incoming" && "" != [string trim $result]} { |
---|
| 471 | if {[regexp {^ok:} $result]} { |
---|
| 472 | set color black |
---|
| 473 | } else { |
---|
| 474 | set color red |
---|
| 475 | } |
---|
[1251] | 476 | set s [Shape ::#auto .diagram.traffic -command \ |
---|
[2080] | 477 | [list %c create line [expr $x0+3] [expr $y0+3] [expr $x1+3] [expr $y1+3] -fill $color -arrow last -tags transient]] |
---|
[1251] | 478 | $s addRange $tval $tval |
---|
| 479 | |
---|
| 480 | set s [Shape ::#auto .diagram.traffic -command \ |
---|
[2080] | 481 | [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]] |
---|
[1251] | 482 | $s addRange $tval $tval |
---|
| 483 | } |
---|
| 484 | |
---|
| 485 | # no address for this client yet? then save this info |
---|
[2080] | 486 | if {"" != $cid |
---|
| 487 | && [info exists started(connect$cid-addr)] |
---|
[1251] | 488 | && $started(connect$cid-addr) == "?"} { |
---|
| 489 | set started(connect$cid-addr) $addr |
---|
| 490 | } |
---|
| 491 | |
---|
| 492 | } elseif {[regexp {connected to peers: (.*)} $mesg match plist]} { |
---|
| 493 | # draw a highlight ring, indicating that peers have changed |
---|
| 494 | set from $nodes($fname) |
---|
| 495 | set x $nodes($from-x) |
---|
| 496 | set y $nodes($from-y) |
---|
| 497 | foreach canv {.diagram.traffic .diagram.network} { |
---|
| 498 | set s [Shape ::#auto $canv -command \ |
---|
| 499 | [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]] |
---|
| 500 | $s addRange $tval [expr {$tval+20}] |
---|
| 501 | } |
---|
| 502 | |
---|
| 503 | # draw lines from the previous peer list, now that |
---|
| 504 | # we know it's time range is done. |
---|
| 505 | foreach addr $peerlist(addrs) { |
---|
| 506 | set from $nodes($fname) |
---|
| 507 | set x0 $nodes($from-x) |
---|
| 508 | set y0 $nodes($from-y) |
---|
| 509 | set x1 $nodes($addr-x) |
---|
| 510 | set y1 $nodes($addr-y) |
---|
| 511 | set s [Shape ::#auto .diagram.network -command \ |
---|
| 512 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
---|
| 513 | $s addRange $peerlist(time) $tval |
---|
| 514 | } |
---|
| 515 | |
---|
| 516 | # save the start of this new peer list |
---|
| 517 | set peerlist(addrs) $plist |
---|
| 518 | set peerlist(time) $tval |
---|
[2080] | 519 | } elseif {[regexp {ERROR} $mesg match addr]} { |
---|
| 520 | .errors.info insert end $time timecode $mesg error "\n" |
---|
| 521 | incr errs |
---|
[1251] | 522 | } |
---|
[2080] | 523 | set times($tval) $time |
---|
[1251] | 524 | } |
---|
| 525 | } |
---|
| 526 | |
---|
| 527 | # any connections hanging out that we haven't drawn? |
---|
| 528 | foreach key [array names started connect*-addr] { |
---|
| 529 | regexp {connect([^-]+)-addr} $key match cid |
---|
| 530 | set from $nodes($fname) |
---|
| 531 | set addr $started($key) |
---|
[1273] | 532 | |
---|
| 533 | if {![info exists nodes($addr-x)]} { |
---|
| 534 | unset started(connect$cid-time) |
---|
| 535 | unset started(connect$cid-addr) |
---|
| 536 | continue |
---|
| 537 | } |
---|
[1251] | 538 | set x0 $nodes($from-x) |
---|
| 539 | set y0 $nodes($from-y) |
---|
| 540 | set x1 $nodes($addr-x) |
---|
| 541 | set y1 $nodes($addr-y) |
---|
| 542 | set s [Shape ::#auto .diagram.traffic -command \ |
---|
| 543 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
---|
| 544 | $s addRange $started(connect$cid-time) $tval |
---|
| 545 | |
---|
| 546 | unset started(connect$cid-time) |
---|
| 547 | unset started(connect$cid-addr) |
---|
| 548 | } |
---|
| 549 | |
---|
| 550 | .diagram.traffic bind $fname <Enter> " |
---|
| 551 | %W itemconfigure $fname-node -outline red |
---|
| 552 | %W itemconfigure $fname-cnx -fill red |
---|
| 553 | %W raise $fname-cnx |
---|
[2080] | 554 | %W itemconfigure entity -text {$nodes($fname)} |
---|
[1251] | 555 | " |
---|
| 556 | .diagram.traffic bind $fname <Leave> " |
---|
| 557 | %W itemconfigure $fname-node -outline black |
---|
| 558 | %W itemconfigure $fname-cnx -fill gray |
---|
| 559 | %W raise transient |
---|
[2080] | 560 | %W itemconfigure entity -text {} |
---|
[1251] | 561 | " |
---|
| 562 | |
---|
| 563 | foreach canv {.diagram.network .diagram.traffic} { |
---|
| 564 | $canv bind $fname-node <ButtonPress-1> \ |
---|
| 565 | [list worker_node_click %W $fname %x %y] |
---|
| 566 | $canv bind $fname-node <B1-Motion> \ |
---|
| 567 | [list worker_node_drag %W $fname %x %y] |
---|
| 568 | $canv bind $fname-node <ButtonRelease-1> \ |
---|
| 569 | [list worker_node_release %W $fname %x %y] |
---|
| 570 | } |
---|
| 571 | |
---|
| 572 | # any peer connections that we haven't drawn? then do it now |
---|
| 573 | foreach addr $peerlist(addrs) { |
---|
| 574 | set from $nodes($fname) |
---|
| 575 | set x0 $nodes($from-x) |
---|
| 576 | set y0 $nodes($from-y) |
---|
| 577 | set x1 $nodes($addr-x) |
---|
| 578 | set y1 $nodes($addr-y) |
---|
| 579 | set s [Shape ::#auto .diagram.network -command \ |
---|
| 580 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
---|
| 581 | $s addRange $peerlist(time) $tmax |
---|
| 582 | } |
---|
| 583 | |
---|
| 584 | .diagram.network bind $fname <Enter> " |
---|
| 585 | %W itemconfigure $fname-node -outline red |
---|
| 586 | %W itemconfigure $fname-cnx -fill red |
---|
| 587 | %W raise $fname-cnx |
---|
| 588 | " |
---|
| 589 | .diagram.network bind $fname <Leave> " |
---|
| 590 | %W itemconfigure $fname-node -outline black |
---|
| 591 | %W itemconfigure $fname-cnx -fill gray |
---|
| 592 | %W raise transient |
---|
| 593 | " |
---|
| 594 | } |
---|
| 595 | .player.scale configure -to $tmax |
---|
[2080] | 596 | .errors.info configure -state disabled |
---|
| 597 | if {$errs == 0} { |
---|
| 598 | .player.err configure -state normal -text "0 errors" |
---|
| 599 | .player.err configure -state disabled |
---|
| 600 | } else { |
---|
| 601 | .player.err configure -state normal -text "$errs error[expr {($errs == 1) ? {} : {s}}]" |
---|
| 602 | } |
---|
[1251] | 603 | |
---|
| 604 | after cancel test_visualize |
---|
| 605 | after idle test_visualize |
---|
| 606 | } |
---|
| 607 | |
---|
| 608 | proc worker_node_click {canv fname x y} { |
---|
| 609 | $canv itemconfigure $fname-node -stipple gray50 |
---|
| 610 | } |
---|
| 611 | |
---|
| 612 | proc worker_node_drag {canv fname x y} { |
---|
| 613 | global nodeRadius |
---|
| 614 | $canv itemconfigure $fname-node -stipple "" |
---|
| 615 | $canv coords $fname-node [expr {$x-$nodeRadius}] [expr {$y-$nodeRadius}] [expr {$x+$nodeRadius}] [expr {$y+$nodeRadius}] |
---|
| 616 | } |
---|
| 617 | |
---|
| 618 | proc worker_node_release {canv fname x y} { |
---|
| 619 | global move nodes |
---|
| 620 | |
---|
| 621 | worker_node_drag $canv $fname $x $y |
---|
| 622 | $canv itemconfigure $fname-node -stipple "" |
---|
| 623 | |
---|
| 624 | set addr $nodes($fname) |
---|
| 625 | set nodes($addr-x) $x |
---|
| 626 | set nodes($addr-y) $y |
---|
| 627 | after idle test_reload |
---|
| 628 | } |
---|
| 629 | |
---|
| 630 | proc test_frame_go {dir position} { |
---|
[2080] | 631 | global actions times |
---|
[1251] | 632 | |
---|
| 633 | set tmax [.player.scale cget -to] |
---|
| 634 | if {"nudge" == $position} { |
---|
| 635 | set nframe [.player.scale get] |
---|
| 636 | incr nframe $dir |
---|
| 637 | } else { |
---|
| 638 | set nframe $position |
---|
| 639 | } |
---|
| 640 | |
---|
| 641 | while {![info exists actions($nframe)] && $nframe > 0 && $nframe < $tmax} { |
---|
| 642 | incr nframe $dir |
---|
| 643 | } |
---|
| 644 | |
---|
| 645 | # set the scale to this new position |
---|
| 646 | .player.scale configure -command "" |
---|
| 647 | .player.scale set $nframe |
---|
| 648 | .player.scale configure -command {test_frame_go 1} |
---|
| 649 | |
---|
| 650 | after cancel test_visualize |
---|
| 651 | after idle test_visualize |
---|
| 652 | } |
---|
| 653 | |
---|
| 654 | proc test_visualize {} { |
---|
| 655 | .diagram.traffic delete all |
---|
| 656 | Shape::draw .diagram.traffic [.player.scale get] |
---|
| 657 | .diagram.traffic raise transient |
---|
| 658 | |
---|
| 659 | .diagram.network delete all |
---|
| 660 | Shape::draw .diagram.network [.player.scale get] |
---|
| 661 | .diagram.network raise transient |
---|
| 662 | } |
---|
| 663 | |
---|
| 664 | proc test_view_change {} { |
---|
| 665 | global view |
---|
| 666 | foreach widget [pack slaves .diagram] { |
---|
| 667 | catch {pack forget $widget} |
---|
| 668 | } |
---|
| 669 | pack .diagram.$view -expand yes -fill both |
---|
| 670 | } |
---|
[1273] | 671 | |
---|
| 672 | proc test_bids {} { |
---|
| 673 | set info [Rappture::foreman::bids] |
---|
| 674 | .client.bids.info delete 0 end |
---|
| 675 | eval .client.bids.info insert end $info |
---|
| 676 | } |
---|