[3330] | 1 | # -*- mode: tcl; indent-tabs-mode: nil -*- |
---|
[761] | 2 | # ---------------------------------------------------------------------- |
---|
| 3 | # COMPONENT: htmlviewer - easy way to display HTML text |
---|
| 4 | # |
---|
| 5 | # This is a thin layer on top of the Tkhtml widget. It makes it |
---|
| 6 | # easier to load HTML text and render it with proper behaviors. |
---|
| 7 | # ====================================================================== |
---|
| 8 | # AUTHOR: Michael McLennan, Purdue University |
---|
[3177] | 9 | # Copyright (c) 2004-2012 HUBzero Foundation, LLC |
---|
[761] | 10 | # |
---|
| 11 | # See the file "license.terms" for information on usage and |
---|
| 12 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 13 | # ====================================================================== |
---|
| 14 | package require Itk |
---|
| 15 | package require Tkhtml |
---|
| 16 | package require Img |
---|
| 17 | |
---|
| 18 | option add *HTMLviewer.width 3i widgetDefault |
---|
| 19 | option add *HTMLviewer.height 0 widgetDefault |
---|
| 20 | option add *HTMLviewer.maxLines 4 widgetDefault |
---|
| 21 | |
---|
| 22 | itcl::class Rappture::HTMLviewer { |
---|
| 23 | inherit itk::Widget |
---|
| 24 | |
---|
| 25 | itk_option define -foreground foreground Foreground black |
---|
| 26 | itk_option define -background background Background white |
---|
| 27 | itk_option define -linknormalcolor linkNormalColor LinkColor blue |
---|
| 28 | itk_option define -linkactivecolor linkActiveColor LinkColor black |
---|
| 29 | itk_option define -linkactivebackground linkActiveBackground LinkActiveBackground #cccccc |
---|
| 30 | itk_option define -xscrollcommand xScrollCommand XScrollCommand "" |
---|
| 31 | itk_option define -yscrollcommand yScrollCommand YScrollCommand "" |
---|
| 32 | itk_option define -width width Width 0 |
---|
| 33 | itk_option define -height height Height 0 |
---|
| 34 | itk_option define -maxlines maxLines MaxLines 0 |
---|
| 35 | |
---|
| 36 | constructor {args} { # defined below } |
---|
| 37 | |
---|
| 38 | public method load {htmlText args} |
---|
| 39 | public method add {htmlText args} |
---|
| 40 | public method followLink {url} |
---|
| 41 | |
---|
| 42 | # this widget works with scrollbars |
---|
| 43 | public method xview {args} { eval $itk_component(html) xview $args } |
---|
| 44 | public method yview {args} { eval $itk_component(html) yview $args } |
---|
| 45 | |
---|
| 46 | protected method _config {args} |
---|
| 47 | private variable _dispatcher "" ;# dispatcher for !events |
---|
| 48 | |
---|
| 49 | protected method _fixHeight {args} |
---|
| 50 | private variable _linesize "" ;# height of default font size |
---|
| 51 | |
---|
| 52 | protected method _mouse {option x y} |
---|
| 53 | private variable _hover "" ;# list of nodes that mouse is hovering over |
---|
| 54 | |
---|
| 55 | protected method _getImage {file} |
---|
[1224] | 56 | protected method _freeImage {file} |
---|
| 57 | private common _file2icon ;# maps file name => image handle |
---|
| 58 | private common _icon2file ;# maps image handle => file name |
---|
[761] | 59 | private variable _dirlist "" ;# list of directories where HTML came from |
---|
| 60 | } |
---|
| 61 | |
---|
| 62 | itk::usual HTMLviewer { |
---|
| 63 | keep -cursor |
---|
| 64 | keep -foreground -background |
---|
| 65 | } |
---|
| 66 | |
---|
| 67 | # ---------------------------------------------------------------------- |
---|
| 68 | # CONSTRUCTOR |
---|
| 69 | # ---------------------------------------------------------------------- |
---|
| 70 | itcl::body Rappture::HTMLviewer::constructor {args} { |
---|
| 71 | Rappture::dispatcher _dispatcher |
---|
| 72 | $_dispatcher register !config |
---|
| 73 | $_dispatcher dispatch $this !config [itcl::code $this _config] |
---|
| 74 | $_dispatcher register !fixHeight |
---|
| 75 | $_dispatcher dispatch $this !fixHeight [itcl::code $this _fixHeight] |
---|
| 76 | |
---|
| 77 | itk_component add html { |
---|
[1641] | 78 | html $itk_interior.html -imagecmd [itcl::code $this _getImage] |
---|
[761] | 79 | } { |
---|
[1641] | 80 | # no real options to work with for this widget |
---|
[761] | 81 | } |
---|
| 82 | pack $itk_component(html) -expand yes -fill both |
---|
| 83 | |
---|
| 84 | bind $itk_component(html) <Motion> \ |
---|
[1641] | 85 | [itcl::code $this _mouse over %x %y] |
---|
[761] | 86 | bind $itk_component(html) <ButtonPress-1> \ |
---|
[1641] | 87 | [itcl::code $this _mouse over %x %y] |
---|
[761] | 88 | bind $itk_component(html) <ButtonRelease-1> \ |
---|
[1641] | 89 | [itcl::code $this _mouse release %x %y] |
---|
[761] | 90 | |
---|
| 91 | # measure the default font height |
---|
| 92 | $itk_component(html) reset |
---|
| 93 | $itk_component(html) parse -final "Testing" |
---|
| 94 | set node [$itk_component(html) node] |
---|
| 95 | foreach {x0 y0 x1 y1} [$itk_component(html) bbox $node] break |
---|
| 96 | set _linesize [expr {$y1-$y0}] |
---|
| 97 | $itk_component(html) reset |
---|
| 98 | |
---|
| 99 | eval itk_initialize $args |
---|
| 100 | } |
---|
| 101 | |
---|
| 102 | # ---------------------------------------------------------------------- |
---|
[785] | 103 | # USAGE: load <htmlText> ?-in <fileName>? |
---|
[761] | 104 | # |
---|
| 105 | # Clients use this to clear the contents and load a new string of |
---|
| 106 | # <htmlText>. If the text is empty, this has the effect of clearing |
---|
| 107 | # the widget. |
---|
| 108 | # ---------------------------------------------------------------------- |
---|
| 109 | itcl::body Rappture::HTMLviewer::load {htmlText args} { |
---|
| 110 | Rappture::getopts args params { |
---|
[1641] | 111 | value -in "" |
---|
[761] | 112 | } |
---|
| 113 | if {[llength $args] > 0} { |
---|
[1641] | 114 | error "wrong # args: should be \"load text ?-in name?\"" |
---|
[761] | 115 | } |
---|
| 116 | |
---|
| 117 | $itk_component(html) reset |
---|
| 118 | set _hover "" |
---|
| 119 | set _dirlist "" |
---|
| 120 | |
---|
| 121 | $itk_component(html) parse $htmlText |
---|
| 122 | |
---|
[785] | 123 | if {"" != $params(-in) && [file exists $params(-in)]} { |
---|
[1641] | 124 | if {[file isdirectory $params(-in)]} { |
---|
| 125 | lappend _dirlist $params(-in) |
---|
| 126 | } else { |
---|
| 127 | lappend _dirlist [file dirname $params(-in)] |
---|
| 128 | } |
---|
[761] | 129 | } |
---|
[785] | 130 | $_dispatcher event -now !config |
---|
[761] | 131 | } |
---|
| 132 | |
---|
| 133 | # ---------------------------------------------------------------------- |
---|
[785] | 134 | # USAGE: add <htmlText> ?-in <fileName>? |
---|
[761] | 135 | # |
---|
| 136 | # Clients use this to add the <htmlText> to the bottom of the contents |
---|
| 137 | # being displayed in the widget. |
---|
| 138 | # ---------------------------------------------------------------------- |
---|
| 139 | itcl::body Rappture::HTMLviewer::add {htmlText args} { |
---|
| 140 | Rappture::getopts args params { |
---|
[1641] | 141 | value -in "" |
---|
[761] | 142 | } |
---|
| 143 | if {[llength $args] > 0} { |
---|
[1641] | 144 | error "wrong # args: should be \"add text ?-in name?\"" |
---|
[761] | 145 | } |
---|
| 146 | |
---|
| 147 | $itk_component(html) parse $htmlText |
---|
| 148 | |
---|
[785] | 149 | if {"" != $params(-in) && [file exists $params(-in)]} { |
---|
[1641] | 150 | if {[file isdirectory $params(-in)]} { |
---|
| 151 | lappend _dirlist $params(-in) |
---|
| 152 | } else { |
---|
| 153 | lappend _dirlist [file dirname $params(-in)] |
---|
| 154 | } |
---|
[761] | 155 | } |
---|
[785] | 156 | $_dispatcher event -now !config |
---|
[761] | 157 | } |
---|
| 158 | |
---|
| 159 | # ---------------------------------------------------------------------- |
---|
| 160 | # USAGE: followLink <url> |
---|
| 161 | # |
---|
| 162 | # Invoked automatically whenever the user clicks on a link within |
---|
| 163 | # an HTML page. Tries to follow the <url> by invoking "exportfile" |
---|
| 164 | # to pop up further information. If the <url> starts with http:// |
---|
| 165 | # or https://, then it is used directly. Otherwise, it is treated |
---|
[785] | 166 | # as a relative file path and resolved with respect to the -in |
---|
[761] | 167 | # options passed into load/add. |
---|
| 168 | # ---------------------------------------------------------------------- |
---|
| 169 | itcl::body Rappture::HTMLviewer::followLink {url} { |
---|
| 170 | if {[regexp -nocase {^https?://} $url]} { |
---|
[2056] | 171 | foreach prog { |
---|
| 172 | clientaction |
---|
| 173 | /apps/bin/clientaction |
---|
| 174 | /apps/xvnc/bin/clientaction |
---|
| 175 | /usr/lib/mw/bin/clientaction |
---|
| 176 | "" |
---|
| 177 | } { |
---|
[1641] | 178 | if {"" != [auto_execok $prog]} { |
---|
| 179 | break |
---|
| 180 | } |
---|
| 181 | } |
---|
| 182 | if {"" != $prog} { |
---|
| 183 | exec $prog url $url & |
---|
| 184 | } else { |
---|
| 185 | bell |
---|
| 186 | } |
---|
| 187 | return |
---|
[761] | 188 | } |
---|
| 189 | |
---|
| 190 | # must be a file -- use exportfile |
---|
| 191 | set url [string trimleft $url /] |
---|
| 192 | set path "" |
---|
| 193 | foreach dir $_dirlist { |
---|
[1641] | 194 | if {[file readable [file join $dir $url]]} { |
---|
| 195 | set path [file join $dir $url] |
---|
| 196 | break |
---|
| 197 | } |
---|
[761] | 198 | } |
---|
| 199 | |
---|
| 200 | foreach prog {exportfile /apps/bin/exportfile ""} { |
---|
[1641] | 201 | if {"" != [auto_execok $prog]} { |
---|
| 202 | break |
---|
| 203 | } |
---|
[761] | 204 | } |
---|
| 205 | if {"" != $path && "" != $prog} { |
---|
[1641] | 206 | exec $prog --format html $path & |
---|
[761] | 207 | } else { |
---|
[1641] | 208 | bell |
---|
[761] | 209 | } |
---|
| 210 | } |
---|
| 211 | |
---|
| 212 | # ---------------------------------------------------------------------- |
---|
| 213 | # USAGE: _mouse over <x> <y> |
---|
| 214 | # USAGE: _mouse release <x> <y> |
---|
| 215 | # |
---|
| 216 | # Invoked automatically as the mouse pointer moves around or otherwise |
---|
| 217 | # interacts with this widget. When the mouse is over a link, the link |
---|
| 218 | # becomes annotated with the "hover" style, so it can be highlighted. |
---|
| 219 | # Clicking and releasing on the same link invokes the action associated |
---|
| 220 | # with the link. |
---|
| 221 | # ---------------------------------------------------------------------- |
---|
| 222 | itcl::body Rappture::HTMLviewer::_mouse {option x y} { |
---|
| 223 | switch -- $option { |
---|
[1641] | 224 | over { |
---|
| 225 | # get a list of nodes with tags we care about |
---|
| 226 | set nlist "" |
---|
| 227 | foreach node [$itk_component(html) node $x $y] { |
---|
| 228 | while {"" != $node} { |
---|
| 229 | if {[$node tag] == "a"} { |
---|
| 230 | lappend nlist $node |
---|
| 231 | break |
---|
| 232 | } |
---|
| 233 | set node [$node parent] |
---|
| 234 | } |
---|
| 235 | } |
---|
[761] | 236 | |
---|
[1641] | 237 | # over something new? then tag it with "hover" |
---|
| 238 | if {$nlist != $_hover} { |
---|
| 239 | foreach node $_hover { |
---|
| 240 | catch {$node dynamic clear hover} |
---|
| 241 | } |
---|
| 242 | set _hover $nlist |
---|
| 243 | foreach node $_hover { |
---|
| 244 | catch {$node dynamic set hover} |
---|
| 245 | } |
---|
| 246 | } |
---|
| 247 | } |
---|
| 248 | release { |
---|
| 249 | set prev $_hover |
---|
| 250 | _mouse over $x $y |
---|
[761] | 251 | |
---|
[1641] | 252 | # mouse release on same node as mouse click? then follow link |
---|
| 253 | if {$prev == $_hover} { |
---|
| 254 | foreach node $_hover { |
---|
| 255 | if {[$node tag] == "a"} { |
---|
| 256 | followLink [$node attr -default {} href] |
---|
| 257 | } |
---|
| 258 | } |
---|
| 259 | } |
---|
| 260 | } |
---|
| 261 | default { |
---|
| 262 | error "bad option \"$option\": should be over or release" |
---|
| 263 | } |
---|
[761] | 264 | } |
---|
| 265 | } |
---|
| 266 | |
---|
| 267 | # ---------------------------------------------------------------------- |
---|
| 268 | # USAGE: _config <arg> <arg>... |
---|
| 269 | # |
---|
| 270 | # Invoked automatically whenever the style-related configuration |
---|
| 271 | # options change for this widget. Changes the main style sheet to |
---|
| 272 | # configure the widget. |
---|
| 273 | # ---------------------------------------------------------------------- |
---|
| 274 | itcl::body Rappture::HTMLviewer::_config {args} { |
---|
| 275 | component html style -id "author" " |
---|
| 276 | body { |
---|
[1641] | 277 | background: $itk_option(-background); |
---|
| 278 | color: $itk_option(-foreground); |
---|
[3642] | 279 | font: 12px helvetica,arial; |
---|
[761] | 280 | } |
---|
| 281 | a { |
---|
[1641] | 282 | color: $itk_option(-linknormalcolor); |
---|
| 283 | text-decoration: underline; |
---|
[761] | 284 | } |
---|
| 285 | a:hover { |
---|
[1641] | 286 | color: $itk_option(-linkactivecolor); |
---|
| 287 | background: $itk_option(-linkactivebackground); |
---|
[761] | 288 | } |
---|
| 289 | " |
---|
| 290 | } |
---|
| 291 | |
---|
| 292 | # ---------------------------------------------------------------------- |
---|
| 293 | # USAGE: _fixHeight <arg> <arg>... |
---|
| 294 | # |
---|
| 295 | # Invoked automatically whenever the height-related configuration |
---|
| 296 | # options change for this widget. If -height is set to 0, then this |
---|
| 297 | # routine figures out a good height for the widget based on -maxlines. |
---|
| 298 | # ---------------------------------------------------------------------- |
---|
| 299 | itcl::body Rappture::HTMLviewer::_fixHeight {args} { |
---|
| 300 | set ht [winfo pixels $itk_component(html) $itk_option(-height)] |
---|
| 301 | if {$ht <= 0} { |
---|
[1641] | 302 | # figure out a good size automatically |
---|
| 303 | set realht [winfo pixels $itk_component(html) 1i] |
---|
| 304 | set node [$itk_component(html) node] |
---|
| 305 | if {"" != $node} { |
---|
| 306 | set bbox [$itk_component(html) bbox $node] |
---|
[3156] | 307 | if { [llength $bbox] == 4 } { |
---|
| 308 | set realht [expr {[lindex $bbox 3]-[lindex $bbox 1]}] |
---|
| 309 | } |
---|
[1641] | 310 | } |
---|
| 311 | if {$itk_option(-maxlines) > 0} { |
---|
| 312 | set ht [expr {$itk_option(-maxlines)*$_linesize}] |
---|
| 313 | if {$realht < $ht} { |
---|
| 314 | set ht $realht |
---|
| 315 | } |
---|
| 316 | } else { |
---|
| 317 | set ht $realht |
---|
| 318 | } |
---|
[761] | 319 | } |
---|
| 320 | $itk_component(html) configure -height $ht |
---|
| 321 | } |
---|
| 322 | |
---|
| 323 | # ---------------------------------------------------------------------- |
---|
| 324 | # USAGE: _getImage <fileName> |
---|
| 325 | # |
---|
| 326 | # Used internally to convert a <fileName> to its corresponding image |
---|
| 327 | # handle. If the <fileName> is relative, then it is loaded with |
---|
[785] | 328 | # respect to the paths given by the -in option for the load/add |
---|
[761] | 329 | # methods. Returns an image handle for the image within the file, |
---|
| 330 | # or the broken image icon if anything goes wrong. |
---|
| 331 | # ---------------------------------------------------------------------- |
---|
| 332 | itcl::body Rappture::HTMLviewer::_getImage {fileName} { |
---|
[1224] | 333 | if {[info exists _file2icon($fileName)]} { |
---|
[1641] | 334 | set imh $_file2icon($fileName) |
---|
| 335 | return [list $imh [itcl::code $this _freeImage]] |
---|
[761] | 336 | } |
---|
| 337 | |
---|
| 338 | set searchlist $fileName |
---|
| 339 | if {[file pathtype $fileName] != "absolute"} { |
---|
[1641] | 340 | foreach dir $_dirlist { |
---|
| 341 | lappend searchlist [file join $dir $fileName] |
---|
| 342 | } |
---|
[761] | 343 | } |
---|
| 344 | |
---|
| 345 | foreach name $searchlist { |
---|
[1641] | 346 | if {[catch {image create photo -file $name} imh] == 0} { |
---|
| 347 | set _file2icon($fileName) $imh |
---|
| 348 | set _icon2file($imh) $fileName |
---|
| 349 | return [list $imh [itcl::code $this _freeImage]] |
---|
| 350 | } |
---|
[761] | 351 | } |
---|
[2981] | 352 | puts stderr "Problem in your html: image \"$fileName\" does not exist" |
---|
[1943] | 353 | # The htmlwidget assumes it owns the image and will delete it. |
---|
| 354 | # Always create a copy of the image. |
---|
| 355 | set img [Rappture::icon exclaim] |
---|
[2980] | 356 | set file [$img cget -file] |
---|
[1943] | 357 | set img [image create photo -file $file] |
---|
| 358 | return $img |
---|
[761] | 359 | } |
---|
| 360 | |
---|
[1224] | 361 | itcl::body Rappture::HTMLviewer::_freeImage { imh } { |
---|
| 362 | if {[info exists _icon2file($imh)]} { |
---|
[1641] | 363 | image delete $imh |
---|
| 364 | set fileName $_icon2file($imh) |
---|
| 365 | unset _icon2file($imh) |
---|
| 366 | unset _file2icon($fileName) |
---|
[1224] | 367 | } |
---|
| 368 | } |
---|
| 369 | |
---|
[761] | 370 | # ---------------------------------------------------------------------- |
---|
| 371 | # OPTION: -background |
---|
| 372 | # ---------------------------------------------------------------------- |
---|
| 373 | itcl::configbody Rappture::HTMLviewer::background { |
---|
| 374 | $_dispatcher event -idle !config |
---|
| 375 | } |
---|
| 376 | |
---|
| 377 | # ---------------------------------------------------------------------- |
---|
| 378 | # OPTION: -foreground |
---|
| 379 | # ---------------------------------------------------------------------- |
---|
| 380 | itcl::configbody Rappture::HTMLviewer::foreground { |
---|
| 381 | $_dispatcher event -idle !config |
---|
| 382 | } |
---|
| 383 | |
---|
| 384 | # ---------------------------------------------------------------------- |
---|
| 385 | # OPTION: -linknormalcolor |
---|
| 386 | # ---------------------------------------------------------------------- |
---|
| 387 | itcl::configbody Rappture::HTMLviewer::linknormalcolor { |
---|
| 388 | $_dispatcher event -idle !config |
---|
| 389 | } |
---|
| 390 | |
---|
| 391 | # ---------------------------------------------------------------------- |
---|
| 392 | # OPTION: -linkactivecolor |
---|
| 393 | # ---------------------------------------------------------------------- |
---|
| 394 | itcl::configbody Rappture::HTMLviewer::linkactivecolor { |
---|
| 395 | $_dispatcher event -idle !config |
---|
| 396 | } |
---|
| 397 | |
---|
| 398 | # ---------------------------------------------------------------------- |
---|
| 399 | # OPTION: -linkactivebackground |
---|
| 400 | # ---------------------------------------------------------------------- |
---|
| 401 | itcl::configbody Rappture::HTMLviewer::linkactivebackground { |
---|
| 402 | $_dispatcher event -idle !config |
---|
| 403 | } |
---|
| 404 | |
---|
| 405 | # ---------------------------------------------------------------------- |
---|
| 406 | # OPTION: -xscrollcommand |
---|
| 407 | # ---------------------------------------------------------------------- |
---|
| 408 | itcl::configbody Rappture::HTMLviewer::xscrollcommand { |
---|
| 409 | $itk_component(html) configure -xscrollcommand $itk_option(-xscrollcommand) |
---|
| 410 | } |
---|
| 411 | |
---|
| 412 | # ---------------------------------------------------------------------- |
---|
| 413 | # OPTION: -yscrollcommand |
---|
| 414 | # ---------------------------------------------------------------------- |
---|
| 415 | itcl::configbody Rappture::HTMLviewer::yscrollcommand { |
---|
| 416 | $itk_component(html) configure -yscrollcommand $itk_option(-yscrollcommand) |
---|
| 417 | } |
---|
| 418 | |
---|
| 419 | # ---------------------------------------------------------------------- |
---|
| 420 | # OPTION: -width |
---|
| 421 | # ---------------------------------------------------------------------- |
---|
| 422 | itcl::configbody Rappture::HTMLviewer::width { |
---|
| 423 | $itk_component(html) configure -width $itk_option(-width) |
---|
| 424 | } |
---|
| 425 | |
---|
| 426 | # ---------------------------------------------------------------------- |
---|
| 427 | # OPTION: -maxlines |
---|
| 428 | # Sets the maximum number of lines for widgets with "-height 0" |
---|
| 429 | # ---------------------------------------------------------------------- |
---|
| 430 | itcl::configbody Rappture::HTMLviewer::maxlines { |
---|
| 431 | $_dispatcher event -idle !fixHeight |
---|
| 432 | } |
---|
| 433 | |
---|
| 434 | # ---------------------------------------------------------------------- |
---|
| 435 | # OPTION: -height |
---|
| 436 | # Set to absolute size ("3i") or 0 for default size based on -maxlines. |
---|
| 437 | # ---------------------------------------------------------------------- |
---|
| 438 | itcl::configbody Rappture::HTMLviewer::height { |
---|
| 439 | $_dispatcher event -idle !fixHeight |
---|
| 440 | } |
---|