[3330] | 1 | # -*- mode: tcl; indent-tabs-mode: nil -*- |
---|
[11] | 2 | # ---------------------------------------------------------------------- |
---|
[3024] | 3 | # COMPONENT: ResultSet - set of XML objects for simulated results |
---|
[11] | 4 | # |
---|
[3024] | 5 | # This data structure collects all of the simulated results |
---|
| 6 | # produced by a series of tool runs. It is used by the Analyzer, |
---|
| 7 | # ResultSelector, and other widgets to keep track of all known runs |
---|
| 8 | # and visualize the result that is currently selected. Each run |
---|
| 9 | # has an index number ("#1", "#2", "#3", etc.) that can be used to |
---|
| 10 | # label the run and refer to it later. |
---|
[11] | 11 | # ====================================================================== |
---|
| 12 | # AUTHOR: Michael McLennan, Purdue University |
---|
[3177] | 13 | # Copyright (c) 2004-2012 HUBzero Foundation, LLC |
---|
[115] | 14 | # |
---|
| 15 | # See the file "license.terms" for information on usage and |
---|
| 16 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
[11] | 17 | # ====================================================================== |
---|
[3024] | 18 | package require Itcl |
---|
[11] | 19 | |
---|
| 20 | itcl::class Rappture::ResultSet { |
---|
| 21 | constructor {args} { # defined below } |
---|
| 22 | destructor { # defined below } |
---|
| 23 | |
---|
| 24 | public method add {xmlobj} |
---|
[2943] | 25 | public method clear {{xmlobj ""}} |
---|
[3024] | 26 | public method diff {option args} |
---|
| 27 | public method find {collist vallist} |
---|
| 28 | public method get {collist xmlobj} |
---|
[11] | 29 | public method contains {xmlobj} |
---|
[3024] | 30 | public method size {} |
---|
[11] | 31 | |
---|
[3024] | 32 | public method notify {option args} |
---|
| 33 | protected method _notifyHandler {args} |
---|
| 34 | |
---|
[2943] | 35 | protected method _addOneResult {tuples xmlobj {simnum ""}} |
---|
[11] | 36 | |
---|
| 37 | private variable _dispatcher "" ;# dispatchers for !events |
---|
| 38 | private variable _results "" ;# tuple of known results |
---|
[2943] | 39 | private variable _resultnum 0 ;# counter for result #1, #2, etc. |
---|
[3024] | 40 | private variable _notify ;# info used for notify command |
---|
[11] | 41 | } |
---|
[1929] | 42 | |
---|
[11] | 43 | # ---------------------------------------------------------------------- |
---|
| 44 | # CONSTRUCTOR |
---|
| 45 | # ---------------------------------------------------------------------- |
---|
| 46 | itcl::body Rappture::ResultSet::constructor {args} { |
---|
| 47 | # create a dispatcher for events |
---|
| 48 | Rappture::dispatcher _dispatcher |
---|
[3024] | 49 | $_dispatcher register !change |
---|
| 50 | $_dispatcher dispatch $this !change \ |
---|
| 51 | [itcl::code $this _notifyHandler] |
---|
[11] | 52 | |
---|
| 53 | # create a list of tuples for data |
---|
| 54 | set _results [Rappture::Tuples ::#auto] |
---|
| 55 | $_results column insert end -name xmlobj -label "top-level XML object" |
---|
[2943] | 56 | $_results column insert end -name simnum -label "simulation number" |
---|
[11] | 57 | |
---|
[3024] | 58 | # clear notification info |
---|
| 59 | set _notify(ALL) "" |
---|
[11] | 60 | |
---|
[3024] | 61 | eval configure $args |
---|
[11] | 62 | } |
---|
| 63 | |
---|
| 64 | # ---------------------------------------------------------------------- |
---|
| 65 | # DESTRUCTOR |
---|
| 66 | # ---------------------------------------------------------------------- |
---|
| 67 | itcl::body Rappture::ResultSet::destructor {} { |
---|
[3024] | 68 | clear |
---|
[11] | 69 | itcl::delete object $_results |
---|
| 70 | } |
---|
| 71 | |
---|
| 72 | # ---------------------------------------------------------------------- |
---|
| 73 | # USAGE: add <xmlobj> |
---|
| 74 | # |
---|
| 75 | # Adds a new result to this result set. Scans through all existing |
---|
| 76 | # results to look for a difference compared to previous results. |
---|
[2943] | 77 | # Returns the simulation number (#1, #2, #3, etc.) of this new result |
---|
| 78 | # to the caller. The various data objects for this result set should |
---|
| 79 | # be added to their result viewers at the same index. |
---|
[11] | 80 | # ---------------------------------------------------------------------- |
---|
| 81 | itcl::body Rappture::ResultSet::add {xmlobj} { |
---|
| 82 | set xmlobj0 [$_results get -format xmlobj end] |
---|
[3024] | 83 | if {$xmlobj0 eq ""} { |
---|
| 84 | # |
---|
| 85 | # If this is the first result, then there are no diffs. |
---|
| 86 | # Add it right in. |
---|
| 87 | # |
---|
[2943] | 88 | set simnum "#[incr _resultnum]" |
---|
| 89 | $_results insert end [list $xmlobj $simnum] |
---|
[3024] | 90 | } else { |
---|
| 91 | # |
---|
| 92 | # For all later results, find the diffs and add any new columns |
---|
| 93 | # into the results tuple. The latest result is the most recent. |
---|
| 94 | # |
---|
| 95 | set simnum [_addOneResult $_results $xmlobj] |
---|
[11] | 96 | } |
---|
| 97 | |
---|
[3024] | 98 | # make sure we fix up associated controls |
---|
| 99 | $_dispatcher event -now !change op add what $xmlobj |
---|
[1400] | 100 | |
---|
[2943] | 101 | return $simnum |
---|
| 102 | } |
---|
[1400] | 103 | |
---|
[2943] | 104 | # ---------------------------------------------------------------------- |
---|
| 105 | # USAGE: clear ?<xmlobj>? |
---|
| 106 | # |
---|
| 107 | # Clears one or all results in this result set. If no specific |
---|
| 108 | # result object is specified, then all results are cleared. |
---|
| 109 | # ---------------------------------------------------------------------- |
---|
| 110 | itcl::body Rappture::ResultSet::clear {{xmlobj ""}} { |
---|
| 111 | if {$xmlobj ne ""} { |
---|
| 112 | # |
---|
| 113 | # Delete just one result. Look for the result among the |
---|
| 114 | # tuples and remove it. Then, rebuild all of the tuples |
---|
| 115 | # by scanning back through them and building them back up. |
---|
| 116 | # This will rebuild the columns/controls as they should |
---|
| 117 | # be now, removing anything that is no longer necessary. |
---|
| 118 | # |
---|
| 119 | set irun [$_results find -format xmlobj $xmlobj] |
---|
| 120 | if {[llength $irun] == 1} { |
---|
[3024] | 121 | # grab a description of what we're about to delete |
---|
| 122 | set dlist [list simnum [$_results get -format simnum $irun]] |
---|
| 123 | foreach col [lrange [$_results column names] 2 end] { |
---|
| 124 | set raw [lindex [Rappture::LibraryObj::value $xmlobj $col] 0] |
---|
| 125 | lappend dlist $col $raw ;# use "raw" (user-readable) label |
---|
[2943] | 126 | } |
---|
[11] | 127 | |
---|
[3024] | 128 | # delete this from the tuples of all results |
---|
| 129 | itcl::delete object $xmlobj |
---|
[2943] | 130 | $_results delete $irun |
---|
[11] | 131 | |
---|
[2943] | 132 | set new [Rappture::Tuples ::#auto] |
---|
| 133 | $new column insert end -name xmlobj -label "top-level XML object" |
---|
| 134 | $new column insert end -name simnum -label "simulation number" |
---|
[11] | 135 | |
---|
[2943] | 136 | for {set n 0} {$n < [$_results size]} {incr n} { |
---|
| 137 | set rec [lindex [$_results get -format {xmlobj simnum} $n] 0] |
---|
| 138 | foreach {obj num} $rec break |
---|
| 139 | if {$n == 0} { |
---|
| 140 | $new insert end [list $obj $num] |
---|
| 141 | } else { |
---|
| 142 | _addOneResult $new $obj $num |
---|
| 143 | } |
---|
| 144 | } |
---|
[11] | 145 | |
---|
[2943] | 146 | # plug in the new set of rebuilt tuples |
---|
| 147 | itcl::delete object $_results |
---|
| 148 | set _results $new |
---|
[11] | 149 | |
---|
[3024] | 150 | # make sure we fix up associated controls at some point |
---|
| 151 | $_dispatcher event -now !change op clear what $dlist |
---|
[2943] | 152 | } |
---|
| 153 | } else { |
---|
| 154 | # |
---|
| 155 | # Delete all results. |
---|
| 156 | # |
---|
[3024] | 157 | for {set irun 0} {$irun < [$_results size]} {incr irun} { |
---|
| 158 | set xo [$_results get -format xmlobj $irun] |
---|
| 159 | itcl::delete object $xo |
---|
| 160 | } |
---|
[2943] | 161 | $_results delete 0 end |
---|
| 162 | |
---|
[3024] | 163 | # make sure we fix up associated controls at some point |
---|
| 164 | $_dispatcher event -now !change op clear what all |
---|
[413] | 165 | } |
---|
[11] | 166 | |
---|
[2943] | 167 | if {[$_results size] == 0} { |
---|
[3024] | 168 | # no results left? then reset to a clean state |
---|
| 169 | eval $_results column delete [lrange [$_results column names] 2 end] |
---|
| 170 | set _resultnum 0 |
---|
| 171 | } |
---|
| 172 | } |
---|
[11] | 173 | |
---|
[3024] | 174 | # ---------------------------------------------------------------------- |
---|
| 175 | # USAGE: diff names |
---|
| 176 | # USAGE: diff values <column> ?<which>? |
---|
| 177 | # |
---|
| 178 | # Returns information about the diffs in the current set of known |
---|
| 179 | # results. The "diff names" returns a list of column names for |
---|
| 180 | # parameters that have diffs. (These are the columns in the tuples.) |
---|
| 181 | # |
---|
| 182 | # The "diff values" returns the various values associated with a |
---|
| 183 | # particular <column> name. If the optional <which> is specified, |
---|
| 184 | # then it is treated as an index into the list of values--0 for the |
---|
| 185 | # first value, 1 for the second, etc. Each value is returned as |
---|
| 186 | # a list with two words. The first is the the label associated with |
---|
| 187 | # the value. The second is the normalized (numeric) value, which can |
---|
| 188 | # be sorted to get a particular ordering. |
---|
| 189 | # ---------------------------------------------------------------------- |
---|
| 190 | itcl::body Rappture::ResultSet::diff {option args} { |
---|
| 191 | switch -- $option { |
---|
| 192 | names { |
---|
| 193 | return [$_results column names] |
---|
[2943] | 194 | } |
---|
[3024] | 195 | values { |
---|
| 196 | if {[llength $args] < 1} { |
---|
| 197 | error "wrong # args: should be \"diff values col ?which?\"" |
---|
| 198 | } |
---|
| 199 | set col [lindex $args 0] |
---|
[413] | 200 | |
---|
[3024] | 201 | set which "all" |
---|
| 202 | if {[llength $args] > 1} { |
---|
| 203 | set which [lindex $args 1] |
---|
| 204 | } |
---|
[2943] | 205 | |
---|
[3099] | 206 | set rlist "" |
---|
| 207 | # build an array of normalized values and their labels |
---|
| 208 | if {$col == "simnum"} { |
---|
| 209 | set nruns [$_results size] |
---|
| 210 | for {set n 0} {$n < $nruns} {incr n} { |
---|
| 211 | set simnum [$_results get -format simnum $n] |
---|
| 212 | lappend rlist $simnum $n |
---|
| 213 | } |
---|
| 214 | } else { |
---|
| 215 | set havenums 1 |
---|
| 216 | foreach rec [$_results get -format [list xmlobj $col]] { |
---|
| 217 | set xo [lindex $rec 0] |
---|
| 218 | set v [lindex $rec 1] |
---|
| 219 | foreach {raw norm} \ |
---|
| 220 | [Rappture::LibraryObj::value $xo $col] break |
---|
[2943] | 221 | |
---|
[3099] | 222 | if {![info exists unique($v)]} { |
---|
| 223 | # keep only unique label strings |
---|
| 224 | set unique($v) $norm |
---|
[3024] | 225 | } |
---|
[3099] | 226 | if {$havenums && ![string is double $norm]} { |
---|
| 227 | set havenums 0 |
---|
| 228 | } |
---|
| 229 | } |
---|
[413] | 230 | |
---|
[3099] | 231 | if {!$havenums} { |
---|
| 232 | # don't have normalized nums? then sort and create nums |
---|
| 233 | set rlist "" |
---|
| 234 | set n 0 |
---|
| 235 | foreach val [lsort -dictionary [array names unique]] { |
---|
| 236 | lappend rlist $val [incr n] |
---|
[3024] | 237 | } |
---|
[3099] | 238 | } else { |
---|
| 239 | set rlist [array get unique] |
---|
[3024] | 240 | } |
---|
[3099] | 241 | } |
---|
| 242 | |
---|
| 243 | if {$which eq "all"} { |
---|
[3024] | 244 | return $rlist |
---|
| 245 | } |
---|
[2943] | 246 | |
---|
[3024] | 247 | # treat the "which" parameter as an XML object |
---|
| 248 | set irun [lindex [$_results find -format xmlobj $which] 0] |
---|
| 249 | if {$irun ne ""} { |
---|
[3099] | 250 | set val [$_results get -format $col $irun] |
---|
| 251 | array set val2norm $rlist |
---|
| 252 | if {[info exists val2norm($val)]} { |
---|
| 253 | return [list $val $val2norm($val)] |
---|
[3024] | 254 | } |
---|
| 255 | } |
---|
| 256 | } |
---|
| 257 | default { |
---|
| 258 | error "bad option \"$option\": should be names or values" |
---|
| 259 | } |
---|
[2943] | 260 | } |
---|
[11] | 261 | } |
---|
| 262 | |
---|
| 263 | # ---------------------------------------------------------------------- |
---|
[3024] | 264 | # USAGE: find <columnList> <valueList> |
---|
[413] | 265 | # |
---|
[3024] | 266 | # Searches through the results for a set of tuple values that match |
---|
| 267 | # the <valueList> for the given <columnList>. Returns a list of |
---|
| 268 | # matching xml objects or "" if there is no match. If the <valueList> |
---|
| 269 | # is *, then it returns a list of all xml objects. |
---|
[413] | 270 | # ---------------------------------------------------------------------- |
---|
[3024] | 271 | itcl::body Rappture::ResultSet::find {collist vallist} { |
---|
| 272 | if {$vallist eq "*"} { |
---|
| 273 | return [$_results get -format xmlobj] |
---|
[413] | 274 | } |
---|
| 275 | |
---|
[3024] | 276 | set rlist "" |
---|
[3099] | 277 | foreach irun [$_results find -format $collist -- $vallist] { |
---|
[3024] | 278 | lappend rlist [$_results get -format xmlobj $irun] |
---|
| 279 | } |
---|
| 280 | return $rlist |
---|
| 281 | } |
---|
[413] | 282 | |
---|
[3024] | 283 | # ---------------------------------------------------------------------- |
---|
| 284 | # USAGE: get <columnList> <xmlobj> |
---|
| 285 | # |
---|
| 286 | # Returns values for the specified <columnList> for the given <xmlobj>. |
---|
| 287 | # This is a way of querying associated data for the given object. |
---|
| 288 | # ---------------------------------------------------------------------- |
---|
| 289 | itcl::body Rappture::ResultSet::get {collist xmlobj} { |
---|
| 290 | set irun [lindex [$_results find -format xmlobj $xmlobj] 0] |
---|
| 291 | if {$irun ne ""} { |
---|
| 292 | return [lindex [$_results get -format $collist $irun] 0] |
---|
| 293 | } |
---|
| 294 | return "" |
---|
[413] | 295 | } |
---|
| 296 | |
---|
| 297 | # ---------------------------------------------------------------------- |
---|
[11] | 298 | # USAGE: contains <xmlobj> |
---|
| 299 | # |
---|
| 300 | # Checks to see if the given <xmlobj> is already represented by |
---|
| 301 | # some result in this result set. This comes in handy when checking |
---|
| 302 | # to see if an input case is already covered. |
---|
| 303 | # |
---|
| 304 | # Returns 1 if the result set already contains this result, and |
---|
| 305 | # 0 otherwise. |
---|
| 306 | # ---------------------------------------------------------------------- |
---|
| 307 | itcl::body Rappture::ResultSet::contains {xmlobj} { |
---|
| 308 | # no results? then this must be new |
---|
| 309 | if {[$_results size] == 0} { |
---|
[1929] | 310 | return 0 |
---|
[11] | 311 | } |
---|
| 312 | |
---|
| 313 | # |
---|
| 314 | # Compare this new object against the last XML object in the |
---|
| 315 | # results set. If it has a difference, make sure that there |
---|
| 316 | # is a column to represent the quantity with the difference. |
---|
| 317 | # |
---|
| 318 | set xmlobj0 [$_results get -format xmlobj end] |
---|
| 319 | foreach {op vpath oldval newval} [$xmlobj0 diff $xmlobj] { |
---|
[1929] | 320 | if {[$xmlobj get $vpath.about.diffs] == "ignore"} { |
---|
| 321 | continue |
---|
| 322 | } |
---|
| 323 | if {$op == "+" || $op == "-"} { |
---|
| 324 | # ignore differences where parameters come and go |
---|
| 325 | # such differences make it hard to work controls |
---|
| 326 | continue |
---|
| 327 | } |
---|
| 328 | if {[$_results column names $vpath] == ""} { |
---|
| 329 | # no column for this quantity yet |
---|
| 330 | return 0 |
---|
| 331 | } |
---|
[11] | 332 | } |
---|
| 333 | |
---|
| 334 | # |
---|
| 335 | # If we got this far, then look through existing results for |
---|
| 336 | # matching tuples, then check each one for diffs. |
---|
| 337 | # |
---|
| 338 | set format "" |
---|
| 339 | set tuple "" |
---|
[2943] | 340 | foreach col [lrange [$_results column names] 2 end] { |
---|
[1929] | 341 | lappend format $col |
---|
| 342 | set raw [lindex [Rappture::LibraryObj::value $xmlobj $col] 0] |
---|
| 343 | lappend tuple $raw ;# use the "raw" (user-readable) label |
---|
[11] | 344 | } |
---|
| 345 | if {[llength $format] > 0} { |
---|
[1929] | 346 | set ilist [$_results find -format $format -- $tuple] |
---|
[11] | 347 | } else { |
---|
[1929] | 348 | set ilist 0 ;# no diffs -- must match first entry |
---|
[11] | 349 | } |
---|
| 350 | |
---|
| 351 | foreach i $ilist { |
---|
[1929] | 352 | set xmlobj0 [$_results get -format xmlobj $i] |
---|
| 353 | set diffs [$xmlobj0 diff $xmlobj] |
---|
| 354 | if {[llength $diffs] == 0} { |
---|
| 355 | # no diffs -- already contained here |
---|
| 356 | return 1 |
---|
| 357 | } |
---|
[11] | 358 | } |
---|
| 359 | |
---|
| 360 | # must be some differences |
---|
| 361 | return 0 |
---|
| 362 | } |
---|
| 363 | |
---|
| 364 | |
---|
| 365 | # ---------------------------------------------------------------------- |
---|
[3024] | 366 | # USAGE: size |
---|
[11] | 367 | # |
---|
[3024] | 368 | # Returns the number of results currently stored in the set. |
---|
[11] | 369 | # ---------------------------------------------------------------------- |
---|
[3024] | 370 | itcl::body Rappture::ResultSet::size {} { |
---|
| 371 | return [$_results size] |
---|
[11] | 372 | } |
---|
| 373 | |
---|
| 374 | # ---------------------------------------------------------------------- |
---|
[3024] | 375 | # USAGE: notify add <client> ?!event !event ...? <command> |
---|
| 376 | # USAGE: notify get ?<client>? ?!event? |
---|
| 377 | # USAGE: notify remove <client> ?!event !event ...? |
---|
[11] | 378 | # |
---|
[3024] | 379 | # Clients use this to add/remove requests for notifications about |
---|
| 380 | # various events that signal changes to the data in each ResultSet. |
---|
[11] | 381 | # |
---|
[3024] | 382 | # The "notify add" operation takes a <client> name (any unique string |
---|
| 383 | # identifying the client), an optional list of events, and the <command> |
---|
| 384 | # that should be called for the callback. |
---|
[413] | 385 | # |
---|
[3024] | 386 | # The "notify get" command returns information about clients and their |
---|
| 387 | # registered callbacks. With no args, it returns a list of <client> |
---|
| 388 | # names. If the <client> is specified, it returns a list of !events. |
---|
| 389 | # If the <client> and !event is specified, it returns the <command>. |
---|
| 390 | # |
---|
| 391 | # The "notify remove" command removes any callback associated with |
---|
| 392 | # a given <client>. If no particular !events are specified, then it |
---|
| 393 | # removes callbacks for all events. |
---|
[413] | 394 | # ---------------------------------------------------------------------- |
---|
[3024] | 395 | itcl::body Rappture::ResultSet::notify {option args} { |
---|
| 396 | set allEvents {!change} |
---|
[413] | 397 | switch -- $option { |
---|
[3024] | 398 | add { |
---|
| 399 | if {[llength $args] < 2} { |
---|
| 400 | error "wrong # args: should be \"notify add caller ?!event !event ...? command" |
---|
[1929] | 401 | } |
---|
[3024] | 402 | set caller [lindex $args 0] |
---|
| 403 | set command [lindex $args end] |
---|
| 404 | if {[llength $args] > 2} { |
---|
| 405 | set events [lrange $args 1 end-1] |
---|
[1929] | 406 | } else { |
---|
[3024] | 407 | set events $allEvents |
---|
[1929] | 408 | } |
---|
[413] | 409 | |
---|
[3024] | 410 | foreach name $events { |
---|
| 411 | if {[lsearch -exact $allEvents $name] < 0} { |
---|
| 412 | error "bad event \"$name\": should be [join $allEvents ,]" |
---|
[1929] | 413 | } |
---|
[3024] | 414 | if {[lsearch $_notify(ALL) $caller] < 0} { |
---|
| 415 | lappend _notify(ALL) $caller |
---|
| 416 | } |
---|
| 417 | set _notify($caller-$name) $command |
---|
[1929] | 418 | } |
---|
| 419 | } |
---|
[3024] | 420 | get { |
---|
| 421 | switch -- [llength $args] { |
---|
| 422 | 0 { |
---|
| 423 | return $_notify(ALL) |
---|
| 424 | } |
---|
| 425 | 1 { |
---|
| 426 | set caller [lindex $args 0] |
---|
| 427 | set rlist "" |
---|
| 428 | foreach key [array names _notify $caller-*] { |
---|
| 429 | lappend rlist [lindex [split $key -] end] |
---|
[1929] | 430 | } |
---|
[3024] | 431 | return $rlist |
---|
[1929] | 432 | } |
---|
[3024] | 433 | 2 { |
---|
| 434 | set caller [lindex $args 0] |
---|
| 435 | set name [lindex $args 1] |
---|
| 436 | if {[info exists _notify($caller-$name)]} { |
---|
| 437 | return $_notify($caller-$name) |
---|
| 438 | } |
---|
| 439 | return "" |
---|
[1929] | 440 | } |
---|
[3024] | 441 | default { |
---|
| 442 | error "wrong # args: should be \"notify get ?caller? ?!event?\"" |
---|
[1929] | 443 | } |
---|
| 444 | } |
---|
| 445 | } |
---|
[3024] | 446 | remove { |
---|
| 447 | if {[llength $args] < 1} { |
---|
| 448 | error "wrong # args: should be \"notify remove caller ?!event !event ...?" |
---|
[1929] | 449 | } |
---|
[3024] | 450 | set caller [lindex $args 0] |
---|
| 451 | if {[llength $args] > 1} { |
---|
| 452 | set events [lrange $args 1 end] |
---|
| 453 | } else { |
---|
| 454 | set events $allEvents |
---|
[1929] | 455 | } |
---|
[11] | 456 | |
---|
[3024] | 457 | foreach name $events { |
---|
| 458 | catch {unset _notify($caller-$name)} |
---|
[1929] | 459 | } |
---|
[3024] | 460 | if {[llength [array names _notify $caller-*]] == 0} { |
---|
| 461 | set i [lsearch $_notify(ALL) $caller] |
---|
| 462 | if {$i >= 0} { |
---|
| 463 | set _notify(ALL) [lreplace $_notify(ALL) $i $i] |
---|
[1929] | 464 | } |
---|
| 465 | } |
---|
| 466 | } |
---|
| 467 | default { |
---|
[3024] | 468 | error "wrong # args: should be add, get, remove" |
---|
[1929] | 469 | } |
---|
[766] | 470 | } |
---|
| 471 | } |
---|
| 472 | |
---|
| 473 | # ---------------------------------------------------------------------- |
---|
[3024] | 474 | # USAGE: _notifyHandler ?<eventArgs>...? |
---|
[413] | 475 | # |
---|
[3024] | 476 | # Called automatically whenever a !change event is triggered in this |
---|
| 477 | # object. Scans through the list of clients that want to receive this |
---|
| 478 | # event and executes each of their callbacks. |
---|
[413] | 479 | # ---------------------------------------------------------------------- |
---|
[3024] | 480 | itcl::body Rappture::ResultSet::_notifyHandler {args} { |
---|
| 481 | array set data $args |
---|
| 482 | set event $data(event) |
---|
[413] | 483 | |
---|
[3024] | 484 | foreach caller $_notify(ALL) { |
---|
| 485 | if {[info exists _notify($caller-$event)]} { |
---|
| 486 | if {[catch {uplevel #0 $_notify($caller-$event) $args} result]} { |
---|
| 487 | # anything go wrong? then throw a background error |
---|
| 488 | bgerror "$result\n(while dispatching $event to $caller)" |
---|
[1929] | 489 | } |
---|
| 490 | } |
---|
[413] | 491 | } |
---|
| 492 | } |
---|
| 493 | |
---|
| 494 | # ---------------------------------------------------------------------- |
---|
[2943] | 495 | # USAGE: _addOneResult <tuples> <xmlobj> ?<simNum>? |
---|
| 496 | # |
---|
| 497 | # Used internally to add one new <xmlobj> to the given <tuples> |
---|
| 498 | # object. If the new xmlobj contains different input parameters |
---|
| 499 | # that are not already columns in the tuple, then this routine |
---|
| 500 | # creates the new columns. If the optional <simNum> is specified, |
---|
| 501 | # then it is added as the simulation number #1, #2, #3, etc. If |
---|
| 502 | # not, then the new object is automatically numbered. |
---|
[67] | 503 | # ---------------------------------------------------------------------- |
---|
[2943] | 504 | itcl::body Rappture::ResultSet::_addOneResult {tuples xmlobj {simnum ""}} { |
---|
| 505 | # |
---|
| 506 | # Compare this new object against the last XML object in the |
---|
| 507 | # results set. If it has a difference, make sure that there |
---|
| 508 | # is a column to represent the quantity with the difference. |
---|
| 509 | # |
---|
| 510 | set xmlobj0 [$tuples get -format xmlobj end] |
---|
| 511 | foreach {op vpath oldval newval} [$xmlobj0 diff $xmlobj] { |
---|
| 512 | if {[$xmlobj get $vpath.about.diffs] == "ignore"} { |
---|
| 513 | continue |
---|
| 514 | } |
---|
| 515 | if {$op == "+" || $op == "-"} { |
---|
| 516 | # ignore differences where parameters come and go |
---|
| 517 | # such differences make it hard to work controls |
---|
| 518 | continue |
---|
| 519 | } |
---|
| 520 | |
---|
| 521 | # make sure that these values really are different |
---|
| 522 | set oldval [lindex [Rappture::LibraryObj::value $xmlobj0 $vpath] 0] |
---|
| 523 | set newval [lindex [Rappture::LibraryObj::value $xmlobj $vpath] 0] |
---|
| 524 | |
---|
| 525 | if {$oldval != $newval && [$tuples column names $vpath] == ""} { |
---|
| 526 | # no column for this quantity yet |
---|
| 527 | $tuples column insert end -name $vpath -default $oldval |
---|
| 528 | } |
---|
[67] | 529 | } |
---|
[2943] | 530 | |
---|
| 531 | # build a tuple for this new object |
---|
| 532 | set cols "" |
---|
| 533 | set tuple "" |
---|
| 534 | foreach col [lrange [$tuples column names] 2 end] { |
---|
| 535 | lappend cols $col |
---|
| 536 | set raw [lindex [Rappture::LibraryObj::value $xmlobj $col] 0] |
---|
| 537 | lappend tuple $raw ;# use the "raw" (user-readable) label |
---|
| 538 | } |
---|
| 539 | |
---|
| 540 | # find a matching tuple? then replace it -- only need one |
---|
| 541 | if {[llength $cols] > 0} { |
---|
| 542 | set ilist [$tuples find -format $cols -- $tuple] |
---|
| 543 | } else { |
---|
| 544 | set ilist 0 ;# no diffs -- must match first entry |
---|
| 545 | } |
---|
| 546 | |
---|
| 547 | # add all remaining columns for this new entry |
---|
| 548 | set tuple [linsert $tuple 0 $xmlobj] |
---|
| 549 | set cols [linsert $cols 0 "xmlobj"] |
---|
| 550 | |
---|
| 551 | if {[llength $ilist] > 0} { |
---|
| 552 | if {[llength $ilist] > 1} { |
---|
| 553 | error "why so many matching results?" |
---|
| 554 | } |
---|
| 555 | |
---|
| 556 | # overwrite the first matching entry |
---|
[3024] | 557 | # start by freeing the old result |
---|
[2943] | 558 | set index [lindex $ilist 0] |
---|
[3024] | 559 | set xo [$tuples get -format xmlobj $index] |
---|
| 560 | itcl::delete object $xo |
---|
| 561 | |
---|
| 562 | # put this new result in its place |
---|
[2943] | 563 | $tuples put -format $cols $index $tuple |
---|
[3024] | 564 | set simnum [$tuples get -format simnum $index] |
---|
[2943] | 565 | } else { |
---|
| 566 | if {$simnum eq ""} { |
---|
| 567 | set simnum "#[incr _resultnum]" |
---|
| 568 | } |
---|
| 569 | set tuple [linsert $tuple 1 $simnum] |
---|
| 570 | $tuples insert end $tuple |
---|
| 571 | } |
---|
| 572 | return $simnum |
---|
[67] | 573 | } |
---|