source: branches/1.4/gui/scripts/htmlviewer.tcl @ 5660

Last change on this file since 5660 was 5660, checked in by ldelgass, 9 years ago

Merge r5657:5659 from trunk (whitespace/style)
File size: 15.4 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
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
9#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
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# ======================================================================
14package require Itk
15package require Tkhtml
16package require Img
17
18option add *HTMLviewer.width 3i widgetDefault
19option add *HTMLviewer.height 0 widgetDefault
20option add *HTMLviewer.maxLines 4 widgetDefault
21
22itcl::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}
56    protected method _freeImage {file}
57    private common _file2icon        ;# maps file name => image handle
58    private common _icon2file        ;# maps image handle => file name
59    private variable _dirlist "" ;# list of directories where HTML came from
60}
61
62itk::usual HTMLviewer {
63    keep -cursor
64    keep -foreground -background
65}
66
67# ----------------------------------------------------------------------
68# CONSTRUCTOR
69# ----------------------------------------------------------------------
70itcl::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 {
78        html $itk_interior.html -imagecmd [itcl::code $this _getImage]
79    } {
80        # no real options to work with for this widget
81    }
82    pack $itk_component(html) -expand yes -fill both
83
84    bind $itk_component(html) <Motion> \
85        [itcl::code $this _mouse over %x %y]
86    bind $itk_component(html) <ButtonPress-1> \
87        [itcl::code $this _mouse over %x %y]
88    bind $itk_component(html) <ButtonRelease-1> \
89        [itcl::code $this _mouse release %x %y]
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# ----------------------------------------------------------------------
103# USAGE: load <htmlText> ?-in <fileName>?
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# ----------------------------------------------------------------------
109itcl::body Rappture::HTMLviewer::load {htmlText args} {
110    Rappture::getopts args params {
111        value -in ""
112    }
113    if {[llength $args] > 0} {
114        error "wrong # args: should be \"load text ?-in name?\""
115    }
116
117    $itk_component(html) reset
118    set _hover ""
119    set _dirlist ""
120
121    $itk_component(html) parse $htmlText
122
123    if {"" != $params(-in) && [file exists $params(-in)]} {
124        if {[file isdirectory $params(-in)]} {
125            lappend _dirlist $params(-in)
126        } else {
127            lappend _dirlist [file dirname $params(-in)]
128        }
129    }
130    $_dispatcher event -now !config
131}
132
133# ----------------------------------------------------------------------
134# USAGE: add <htmlText> ?-in <fileName>?
135#
136# Clients use this to add the <htmlText> to the bottom of the contents
137# being displayed in the widget.
138# ----------------------------------------------------------------------
139itcl::body Rappture::HTMLviewer::add {htmlText args} {
140    Rappture::getopts args params {
141        value -in ""
142    }
143    if {[llength $args] > 0} {
144        error "wrong # args: should be \"add text ?-in name?\""
145    }
146
147    $itk_component(html) parse $htmlText
148
149    if {"" != $params(-in) && [file exists $params(-in)]} {
150        if {[file isdirectory $params(-in)]} {
151            lappend _dirlist $params(-in)
152        } else {
153            lappend _dirlist [file dirname $params(-in)]
154        }
155    }
156    $_dispatcher event -now !config
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
166# as a relative file path and resolved with respect to the -in
167# options passed into load/add.
168# ----------------------------------------------------------------------
169itcl::body Rappture::HTMLviewer::followLink {url} {
170    if {[regexp -nocase {^https?://} $url]} {
171        foreach prog {
172                clientaction
173                /apps/bin/clientaction
174                /apps/xvnc/bin/clientaction
175                /usr/lib/mw/bin/clientaction
176                ""
177        } {
178            if {"" != [auto_execok $prog]} {
179                break
180            }
181        }
182        if {"" != $prog} {
183            exec $prog url $url &
184        } else {
185            bell
186        }
187        return
188    }
189
190    # must be a file -- use exportfile
191    set url [string trimleft $url /]
192    set path ""
193    foreach dir $_dirlist {
194        if {[file readable [file join $dir $url]]} {
195            set path [file join $dir $url]
196            break
197        }
198    }
199
200    foreach prog {exportfile /apps/bin/exportfile ""} {
201        if {"" != [auto_execok $prog]} {
202            break
203        }
204    }
205    if {"" != $path && "" != $prog} {
206        exec $prog --format html $path &
207    } else {
208        bell
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# ----------------------------------------------------------------------
222itcl::body Rappture::HTMLviewer::_mouse {option x y} {
223    switch -- $option {
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            }
236
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
251
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        }
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# ----------------------------------------------------------------------
274itcl::body Rappture::HTMLviewer::_config {args} {
275    component html style -id "author" "
276      body {
277        background: $itk_option(-background);
278        color: $itk_option(-foreground);
279        font: 12px helvetica,arial;
280      }
281      a {
282        color: $itk_option(-linknormalcolor);
283        text-decoration: underline;
284      }
285      a:hover {
286        color: $itk_option(-linkactivecolor);
287        background: $itk_option(-linkactivebackground);
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# ----------------------------------------------------------------------
299itcl::body Rappture::HTMLviewer::_fixHeight {args} {
300    set ht [winfo pixels $itk_component(html) $itk_option(-height)]
301    if {$ht <= 0} {
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]
307            if { [llength $bbox] == 4 } {
308                set realht [expr {[lindex $bbox 3]-[lindex $bbox 1]}]
309            }
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        }
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
328# respect to the paths given by the -in option for the load/add
329# methods.  Returns an image handle for the image within the file,
330# or the broken image icon if anything goes wrong.
331# ----------------------------------------------------------------------
332itcl::body Rappture::HTMLviewer::_getImage {fileName} {
333    if {[info exists _file2icon($fileName)]} {
334        set imh $_file2icon($fileName)
335        return [list $imh [itcl::code $this _freeImage]]
336    }
337
338    set searchlist $fileName
339    if {[file pathtype $fileName] != "absolute"} {
340        foreach dir $_dirlist {
341            lappend searchlist [file join $dir $fileName]
342        }
343    }
344
345    foreach name $searchlist {
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        }
351    }
352    puts stderr "Problem in your html: image \"$fileName\" does not exist"
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]
356    set file [$img cget -file]
357    set img [image create photo -file $file]
358    return $img
359}
360
361itcl::body Rappture::HTMLviewer::_freeImage { imh } {
362    if {[info exists _icon2file($imh)]} {
363        image delete $imh
364        set fileName $_icon2file($imh)
365        unset _icon2file($imh)
366        unset _file2icon($fileName)
367    }
368}
369
370# ----------------------------------------------------------------------
371# OPTION: -background
372# ----------------------------------------------------------------------
373itcl::configbody Rappture::HTMLviewer::background {
374    $_dispatcher event -idle !config
375}
376
377# ----------------------------------------------------------------------
378# OPTION: -foreground
379# ----------------------------------------------------------------------
380itcl::configbody Rappture::HTMLviewer::foreground {
381    $_dispatcher event -idle !config
382}
383
384# ----------------------------------------------------------------------
385# OPTION: -linknormalcolor
386# ----------------------------------------------------------------------
387itcl::configbody Rappture::HTMLviewer::linknormalcolor {
388    $_dispatcher event -idle !config
389}
390
391# ----------------------------------------------------------------------
392# OPTION: -linkactivecolor
393# ----------------------------------------------------------------------
394itcl::configbody Rappture::HTMLviewer::linkactivecolor {
395    $_dispatcher event -idle !config
396}
397
398# ----------------------------------------------------------------------
399# OPTION: -linkactivebackground
400# ----------------------------------------------------------------------
401itcl::configbody Rappture::HTMLviewer::linkactivebackground {
402    $_dispatcher event -idle !config
403}
404
405# ----------------------------------------------------------------------
406# OPTION: -xscrollcommand
407# ----------------------------------------------------------------------
408itcl::configbody Rappture::HTMLviewer::xscrollcommand {
409    $itk_component(html) configure -xscrollcommand $itk_option(-xscrollcommand)
410}
411
412# ----------------------------------------------------------------------
413# OPTION: -yscrollcommand
414# ----------------------------------------------------------------------
415itcl::configbody Rappture::HTMLviewer::yscrollcommand {
416    $itk_component(html) configure -yscrollcommand $itk_option(-yscrollcommand)
417}
418
419# ----------------------------------------------------------------------
420# OPTION: -width
421# ----------------------------------------------------------------------
422itcl::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# ----------------------------------------------------------------------
430itcl::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# ----------------------------------------------------------------------
438itcl::configbody Rappture::HTMLviewer::height {
439    $_dispatcher event -idle !fixHeight
440}
Note: See TracBrowser for help on using the repository browser.