source: trunk/gui/scripts/htmlviewer.tcl @ 1599

Last change on this file since 1599 was 1342, checked in by gah, 15 years ago

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