| 1 | # ---------------------------------------------------------------------- |
|---|
| 2 | # COMPONENT: objview - show an overview of a Rappture object |
|---|
| 3 | # |
|---|
| 4 | # This component is used when examining the details of a particular |
|---|
| 5 | # diff. It shows an overview of the affected object, so the user |
|---|
| 6 | # can understand where the diff is coming from. The overview can be |
|---|
| 7 | # short or long, and the widget can show the object itself or any |
|---|
| 8 | # diffs in the test object. |
|---|
| 9 | # ====================================================================== |
|---|
| 10 | # AUTHOR: Michael McLennan, Purdue University |
|---|
| 11 | # Copyright (c) 2004-2012 HUBzero Foundation, LLC |
|---|
| 12 | # |
|---|
| 13 | # See the file "license.terms" for information on usage and |
|---|
| 14 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
|---|
| 15 | # ====================================================================== |
|---|
| 16 | package require Itk |
|---|
| 17 | package require RapptureGUI |
|---|
| 18 | |
|---|
| 19 | namespace eval Rappture::Tester { # forward declaration } |
|---|
| 20 | |
|---|
| 21 | option add *ObjView.headingFont {Arial -12 bold} widgetDefault |
|---|
| 22 | option add *ObjView.infoFont {Arial -12} widgetDefault |
|---|
| 23 | option add *ObjView.codeFont {Courier -12} widgetDefault |
|---|
| 24 | option add *ObjView.addedBackground #ccffcc widgetDefault |
|---|
| 25 | option add *ObjView.deletedBackground #ffcccc widgetDefault |
|---|
| 26 | |
|---|
| 27 | itcl::class Rappture::Tester::ObjView { |
|---|
| 28 | inherit itk::Widget |
|---|
| 29 | |
|---|
| 30 | itk_option define -testobj testObj TestObj "" |
|---|
| 31 | itk_option define -path path Path "" |
|---|
| 32 | itk_option define -details details Details "min" |
|---|
| 33 | itk_option define -showdiffs showDiffs ShowDiffs "off" |
|---|
| 34 | |
|---|
| 35 | itk_option define -addedbackground addedBackground Background "" |
|---|
| 36 | itk_option define -deletedbackground deletedBackground Background "" |
|---|
| 37 | itk_option define -infofont infoFont Font "" |
|---|
| 38 | itk_option define -codefont codeFont Font "" |
|---|
| 39 | |
|---|
| 40 | constructor {args} { # defined later } |
|---|
| 41 | |
|---|
| 42 | protected method _reload {} |
|---|
| 43 | |
|---|
| 44 | private variable _dispatcher "" ;# dispatcher for !events |
|---|
| 45 | } |
|---|
| 46 | |
|---|
| 47 | # ---------------------------------------------------------------------- |
|---|
| 48 | # CONSTRUCTOR |
|---|
| 49 | # ---------------------------------------------------------------------- |
|---|
| 50 | itcl::body Rappture::Tester::ObjView::constructor {args} { |
|---|
| 51 | Rappture::dispatcher _dispatcher |
|---|
| 52 | $_dispatcher register !reload |
|---|
| 53 | $_dispatcher dispatch $this !reload "[itcl::code $this _reload]; list" |
|---|
| 54 | |
|---|
| 55 | # object icon on the left-hand side |
|---|
| 56 | itk_component add icon { |
|---|
| 57 | label $itk_interior.icon |
|---|
| 58 | } |
|---|
| 59 | |
|---|
| 60 | # create label/value for "path" parameter -- this is a special case |
|---|
| 61 | itk_component add lpath { |
|---|
| 62 | label $itk_interior.lpath -text "Identifier:" |
|---|
| 63 | } { |
|---|
| 64 | usual |
|---|
| 65 | rename -font -headingfont headingFont Font |
|---|
| 66 | } |
|---|
| 67 | |
|---|
| 68 | itk_component add vpath { |
|---|
| 69 | label $itk_interior.vpath -justify left -anchor w |
|---|
| 70 | } { |
|---|
| 71 | usual |
|---|
| 72 | rename -font -codefont codeFont Font |
|---|
| 73 | } |
|---|
| 74 | |
|---|
| 75 | # set up the layout to resize properly |
|---|
| 76 | grid columnconfigure $itk_interior 2 -weight 1 |
|---|
| 77 | |
|---|
| 78 | eval itk_initialize $args |
|---|
| 79 | } |
|---|
| 80 | |
|---|
| 81 | itk::usual ObjView { |
|---|
| 82 | keep -background -foreground -cursor |
|---|
| 83 | } |
|---|
| 84 | |
|---|
| 85 | # ---------------------------------------------------------------------- |
|---|
| 86 | # USAGE: _reload |
|---|
| 87 | # |
|---|
| 88 | # Called internally to load information from the object at the |
|---|
| 89 | # current -path in the -testobj XML definition. |
|---|
| 90 | # ---------------------------------------------------------------------- |
|---|
| 91 | itcl::body Rappture::Tester::ObjView::_reload {} { |
|---|
| 92 | set testobj $itk_option(-testobj) |
|---|
| 93 | set path $itk_option(-path) |
|---|
| 94 | |
|---|
| 95 | # clear everything out |
|---|
| 96 | foreach win [grid slaves $itk_interior] { |
|---|
| 97 | grid forget $win |
|---|
| 98 | } |
|---|
| 99 | grid $itk_component(icon) -row 0 -rowspan 6 -column 0 \ |
|---|
| 100 | -sticky ne -padx {0 20} |
|---|
| 101 | |
|---|
| 102 | # look for an object at the path |
|---|
| 103 | set type "" |
|---|
| 104 | if {$testobj ne "" && $path ne ""} { |
|---|
| 105 | set type [$testobj getTestInfo element -as type $path] |
|---|
| 106 | if {$type eq ""} { |
|---|
| 107 | set type [$testobj getRunInfo element -as type $path] |
|---|
| 108 | } |
|---|
| 109 | } |
|---|
| 110 | |
|---|
| 111 | if {$type eq ""} { |
|---|
| 112 | $itk_component(icon) configure -image "" |
|---|
| 113 | } else { |
|---|
| 114 | set icon [Rappture::objects::get $type -image] |
|---|
| 115 | $itk_component(icon) configure -image $icon |
|---|
| 116 | |
|---|
| 117 | # decide what to show -- short or long format |
|---|
| 118 | set items {label description path} |
|---|
| 119 | foreach rec [Rappture::objects::get $type -attributes] { |
|---|
| 120 | set name [lindex $rec 0] |
|---|
| 121 | array set attr [lrange $rec 1 end] |
|---|
| 122 | set titles($name) $attr(-title) |
|---|
| 123 | set loc($name) $path.$attr(-path) |
|---|
| 124 | set path2attr($path.$attr(-path)) $name |
|---|
| 125 | |
|---|
| 126 | if {$itk_option(-details) == "max" && [lsearch $items $name] < 0} { |
|---|
| 127 | lappend items $name |
|---|
| 128 | } |
|---|
| 129 | } |
|---|
| 130 | |
|---|
| 131 | # if we're showing diffs, query them now |
|---|
| 132 | if {$itk_option(-showdiffs)} { |
|---|
| 133 | foreach rec [$testobj getDiffs $path] { |
|---|
| 134 | catch {unset df} |
|---|
| 135 | array set df $rec |
|---|
| 136 | if {[lindex $df(-what) 0] eq "attr"} { |
|---|
| 137 | set apath $df(-path).[lindex $df(-what) 2] |
|---|
| 138 | |
|---|
| 139 | if {[info exists path2attr($apath)]} { |
|---|
| 140 | # store the diff for this attribute -- we need it below |
|---|
| 141 | set name $path2attr($apath) |
|---|
| 142 | set diffs($name) [list [lindex $df(-what) 1] $df(-v1) $df(-v2)] |
|---|
| 143 | } |
|---|
| 144 | } |
|---|
| 145 | } |
|---|
| 146 | } |
|---|
| 147 | |
|---|
| 148 | # run through the items and show values |
|---|
| 149 | set row 0 |
|---|
| 150 | foreach aname $items { |
|---|
| 151 | set show 0 |
|---|
| 152 | if {$aname == "path"} { |
|---|
| 153 | # use a special widget to handle the "path" report |
|---|
| 154 | set lcomp "lpath" |
|---|
| 155 | set vcomp "vpath" |
|---|
| 156 | $itk_component(vpath) configure -text $path |
|---|
| 157 | set show 1 |
|---|
| 158 | } else { |
|---|
| 159 | # get a label with the attribute name for this row |
|---|
| 160 | set lcomp "lattr$row" |
|---|
| 161 | if {![info exists itk_component($lcomp)]} { |
|---|
| 162 | itk_component add $lcomp { |
|---|
| 163 | label $itk_interior.$lcomp |
|---|
| 164 | } { |
|---|
| 165 | usual |
|---|
| 166 | rename -font -headingfont headingFont Font |
|---|
| 167 | } |
|---|
| 168 | } |
|---|
| 169 | $itk_component($lcomp) configure -text "$titles($aname):" |
|---|
| 170 | |
|---|
| 171 | set vcomp "" |
|---|
| 172 | set bg [cget -background] |
|---|
| 173 | set fn $itk_option(-infofont) |
|---|
| 174 | |
|---|
| 175 | if {[info exists diffs($aname)]} { |
|---|
| 176 | set show 1 |
|---|
| 177 | set fn $itk_option(-codefont) |
|---|
| 178 | |
|---|
| 179 | foreach {op v1 v2} $diffs($aname) break |
|---|
| 180 | switch -- $op { |
|---|
| 181 | - { |
|---|
| 182 | # use a normal label below, but change the bg |
|---|
| 183 | set bg $itk_option(-deletedbackground) |
|---|
| 184 | set str $v1 |
|---|
| 185 | } |
|---|
| 186 | + { |
|---|
| 187 | # use a normal label below, but change the bg |
|---|
| 188 | set bg $itk_option(-addedbackground) |
|---|
| 189 | set str $v2 |
|---|
| 190 | } |
|---|
| 191 | c { |
|---|
| 192 | # get a value that can show diffs on this row |
|---|
| 193 | set vcomp "vdiff$row" |
|---|
| 194 | if {![info exists itk_component($vcomp)]} { |
|---|
| 195 | itk_component add $vcomp { |
|---|
| 196 | Rappture::Scroller \ |
|---|
| 197 | $itk_interior.$vcomp \ |
|---|
| 198 | -xscrollmode auto -yscrollmode auto \ |
|---|
| 199 | -height 1i |
|---|
| 200 | } |
|---|
| 201 | itk_component add ${vcomp}val { |
|---|
| 202 | Rappture::Diffview \ |
|---|
| 203 | $itk_component($vcomp).dv \ |
|---|
| 204 | -borderwidth 0 \ |
|---|
| 205 | -diff 1->2 -layout inline |
|---|
| 206 | } |
|---|
| 207 | $itk_component($vcomp) contents \ |
|---|
| 208 | $itk_component(${vcomp}val) |
|---|
| 209 | } |
|---|
| 210 | set dv $itk_component(${vcomp}val) |
|---|
| 211 | $dv text 1 $v1 |
|---|
| 212 | $dv text 2 $v2 |
|---|
| 213 | |
|---|
| 214 | # more than a 1-line diff? then show scrollbars |
|---|
| 215 | if {[llength [split $v1 \n]] > 1 |
|---|
| 216 | || [llength [split $v2 \n]] > 1} { |
|---|
| 217 | $itk_component($vcomp) configure \ |
|---|
| 218 | -yscrollmode auto -height 1i |
|---|
| 219 | } else { |
|---|
| 220 | foreach {x0 y0 x1 y1} [$dv bbox all] break |
|---|
| 221 | set bd [$dv cget -borderwidth] |
|---|
| 222 | set yht [expr {$y1-$y0+2*$bd}] |
|---|
| 223 | $itk_component($vcomp) configure \ |
|---|
| 224 | -yscrollmode off -height $yht |
|---|
| 225 | } |
|---|
| 226 | } |
|---|
| 227 | } |
|---|
| 228 | } else { |
|---|
| 229 | # no diff -- get the attribute value |
|---|
| 230 | set str [$testobj getTestInfo $loc($aname)] |
|---|
| 231 | } |
|---|
| 232 | |
|---|
| 233 | # don't have a diff comp from above? then create a viewer here |
|---|
| 234 | if {$vcomp eq "" && $str ne ""} { |
|---|
| 235 | set show 1 |
|---|
| 236 | set lines [split $str \n] |
|---|
| 237 | if {[llength $lines] > 2 |
|---|
| 238 | || [string length [lindex $lines 0]] > 40 |
|---|
| 239 | || [string length [lindex $lines 1]] > 40} { |
|---|
| 240 | |
|---|
| 241 | # long string -- use a scroller and a text area |
|---|
| 242 | set vcomp "vattrlong$row" |
|---|
| 243 | if {![info exists itk_component($vcomp)]} { |
|---|
| 244 | itk_component add $vcomp { |
|---|
| 245 | Rappture::Scroller $itk_interior.$vcomp \ |
|---|
| 246 | -xscrollmode auto -yscrollmode auto \ |
|---|
| 247 | -height 1i |
|---|
| 248 | } |
|---|
| 249 | itk_component add ${vcomp}val { |
|---|
| 250 | text $itk_component($vcomp).tx -wrap word |
|---|
| 251 | } |
|---|
| 252 | $itk_component($vcomp) contents \ |
|---|
| 253 | $itk_component(${vcomp}val) |
|---|
| 254 | } |
|---|
| 255 | set tx $itk_component(${vcomp}val) |
|---|
| 256 | $tx configure -state normal |
|---|
| 257 | $tx delete 1.0 end |
|---|
| 258 | $tx insert end $str |
|---|
| 259 | $tx configure -state disabled -background $bg -font $fn |
|---|
| 260 | } else { |
|---|
| 261 | # short string -- use a 1-line label |
|---|
| 262 | set vcomp "vattr$row" |
|---|
| 263 | if {![info exists itk_component($vcomp)]} { |
|---|
| 264 | itk_component add $vcomp { |
|---|
| 265 | label $itk_interior.$vcomp \ |
|---|
| 266 | -justify left -anchor w |
|---|
| 267 | } { |
|---|
| 268 | usual |
|---|
| 269 | rename -font -infofont infoFont Font |
|---|
| 270 | } |
|---|
| 271 | } |
|---|
| 272 | $itk_component($vcomp) configure -text $str \ |
|---|
| 273 | -background $bg -font $fn |
|---|
| 274 | } |
|---|
| 275 | } |
|---|
| 276 | |
|---|
| 277 | } |
|---|
| 278 | grid rowconfigure $itk_interior $row -weight 0 |
|---|
| 279 | |
|---|
| 280 | if {$show} { |
|---|
| 281 | grid $itk_component($lcomp) -row $row -column 1 \ |
|---|
| 282 | -sticky e -pady 2 |
|---|
| 283 | grid $itk_component($vcomp) -row $row -column 2 \ |
|---|
| 284 | -sticky ew -pady 2 |
|---|
| 285 | incr row |
|---|
| 286 | } |
|---|
| 287 | } |
|---|
| 288 | grid rowconfigure $itk_interior $row -weight 1 |
|---|
| 289 | } |
|---|
| 290 | } |
|---|
| 291 | |
|---|
| 292 | # ---------------------------------------------------------------------- |
|---|
| 293 | # CONFIGURATION OPTIONS |
|---|
| 294 | # ---------------------------------------------------------------------- |
|---|
| 295 | itcl::configbody Rappture::Tester::ObjView::testobj { |
|---|
| 296 | $_dispatcher event -idle !reload |
|---|
| 297 | } |
|---|
| 298 | itcl::configbody Rappture::Tester::ObjView::path { |
|---|
| 299 | $_dispatcher event -idle !reload |
|---|
| 300 | } |
|---|
| 301 | itcl::configbody Rappture::Tester::ObjView::details { |
|---|
| 302 | if {[lsearch {min max} $itk_option(-details)] < 0} { |
|---|
| 303 | error "bad value \"$itk_option(-details)\": should be min, max" |
|---|
| 304 | } |
|---|
| 305 | $_dispatcher event -idle !reload |
|---|
| 306 | } |
|---|
| 307 | itcl::configbody Rappture::Tester::ObjView::showdiffs { |
|---|
| 308 | if {![string is boolean -strict $itk_option(-showdiffs)]} { |
|---|
| 309 | error "bad value \"$itk_option(-showdiffs)\": should be boolean" |
|---|
| 310 | } |
|---|
| 311 | $_dispatcher event -idle !reload |
|---|
| 312 | } |
|---|
