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

Last change on this file since 3100 was 3100, checked in by gah, 12 years ago

fixes for drawing. Allow empty html file.
File size: 15.3 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 {
171                clientaction
172                /apps/bin/clientaction
173                /apps/xvnc/bin/clientaction
174                /usr/lib/mw/bin/clientaction
175                ""
176        } {
177            if {"" != [auto_execok $prog]} {
178                break
179            }
180        }
181        if {"" != $prog} {
182            exec $prog url $url &
183        } else {
184            bell
185        }
186        return
187    }
188
189    # must be a file -- use exportfile
190    set url [string trimleft $url /]
191    set path ""
192    foreach dir $_dirlist {
193        if {[file readable [file join $dir $url]]} {
194            set path [file join $dir $url]
195            break
196        }
197    }
198
199    foreach prog {exportfile /apps/bin/exportfile ""} {
200        if {"" != [auto_execok $prog]} {
201            break
202        }
203    }
204    if {"" != $path && "" != $prog} {
205        exec $prog --format html $path &
206    } else {
207        bell
208    }
209}
210
211# ----------------------------------------------------------------------
212# USAGE: _mouse over <x> <y>
213# USAGE: _mouse release <x> <y>
214#
215# Invoked automatically as the mouse pointer moves around or otherwise
216# interacts with this widget.  When the mouse is over a link, the link
217# becomes annotated with the "hover" style, so it can be highlighted.
218# Clicking and releasing on the same link invokes the action associated
219# with the link.
220# ----------------------------------------------------------------------
221itcl::body Rappture::HTMLviewer::_mouse {option x y} {
222    switch -- $option {
223        over {
224            # get a list of nodes with tags we care about
225            set nlist ""
226            foreach node [$itk_component(html) node $x $y] {
227                while {"" != $node} {
228                    if {[$node tag] == "a"} {
229                        lappend nlist $node
230                        break
231                    }
232                    set node [$node parent]
233                }
234            }
235
236            # over something new? then tag it with "hover"
237            if {$nlist != $_hover} {
238                foreach node $_hover {
239                    catch {$node dynamic clear hover}
240                }
241                set _hover $nlist
242                foreach node $_hover {
243                    catch {$node dynamic set hover}
244                }
245            }
246        }
247        release {
248            set prev $_hover
249            _mouse over $x $y
250
251            # mouse release on same node as mouse click? then follow link
252            if {$prev == $_hover} {
253                foreach node $_hover {
254                    if {[$node tag] == "a"} {
255                        followLink [$node attr -default {} href]
256                    }
257                }
258            }
259        }
260        default {
261            error "bad option \"$option\": should be over or release"
262        }
263    }
264}
265
266# ----------------------------------------------------------------------
267# USAGE: _config <arg> <arg>...
268#
269# Invoked automatically whenever the style-related configuration
270# options change for this widget.  Changes the main style sheet to
271# configure the widget.
272# ----------------------------------------------------------------------
273itcl::body Rappture::HTMLviewer::_config {args} {
274    component html style -id "author" "
275      body {
276        background: $itk_option(-background);
277        color: $itk_option(-foreground);
278        font: 10px helvetica,arial;
279      }
280      a {
281        color: $itk_option(-linknormalcolor);
282        text-decoration: underline;
283      }
284      a:hover {
285        color: $itk_option(-linkactivecolor);
286        background: $itk_option(-linkactivebackground);
287      }
288    "
289}
290
291# ----------------------------------------------------------------------
292# USAGE: _fixHeight <arg> <arg>...
293#
294# Invoked automatically whenever the height-related configuration
295# options change for this widget.  If -height is set to 0, then this
296# routine figures out a good height for the widget based on -maxlines.
297# ----------------------------------------------------------------------
298itcl::body Rappture::HTMLviewer::_fixHeight {args} {
299    set ht [winfo pixels $itk_component(html) $itk_option(-height)]
300    if {$ht <= 0} {
301        # figure out a good size automatically
302        set realht [winfo pixels $itk_component(html) 1i]
303        set node [$itk_component(html) node]
304        if {"" != $node} {
305            set bbox [$itk_component(html) bbox $node]
306            set realht [expr {[lindex $bbox 3]-[lindex $bbox 1]}]
307        }
308        if {$itk_option(-maxlines) > 0} {
309            set ht [expr {$itk_option(-maxlines)*$_linesize}]
310            if {$realht < $ht} {
311                set ht $realht
312            }
313        } else {
314            set ht $realht
315        }
316    }
317    $itk_component(html) configure -height $ht
318}
319
320# ----------------------------------------------------------------------
321# USAGE: _getImage <fileName>
322#
323# Used internally to convert a <fileName> to its corresponding image
324# handle.  If the <fileName> is relative, then it is loaded with
325# respect to the paths given by the -in option for the load/add
326# methods.  Returns an image handle for the image within the file,
327# or the broken image icon if anything goes wrong.
328# ----------------------------------------------------------------------
329itcl::body Rappture::HTMLviewer::_getImage {fileName} {
330    if {[info exists _file2icon($fileName)]} {
331        set imh $_file2icon($fileName)
332        return [list $imh [itcl::code $this _freeImage]]
333    }
334
335    set searchlist $fileName
336    if {[file pathtype $fileName] != "absolute"} {
337        foreach dir $_dirlist {
338            lappend searchlist [file join $dir $fileName]
339        }
340    }
341
342    foreach name $searchlist {
343        if {[catch {image create photo -file $name} imh] == 0} {
344            set _file2icon($fileName) $imh
345            set _icon2file($imh) $fileName
346            return [list $imh [itcl::code $this _freeImage]]
347        }
348    }
349    puts stderr "Problem in your html: image \"$fileName\" does not exist"
350    # The htmlwidget assumes it owns the image and will delete it.
351    # Always create a copy of the image.
352    set img [Rappture::icon exclaim]
353    set file [$img cget -file]
354    set img [image create photo -file $file]
355    return $img
356}
357
358itcl::body Rappture::HTMLviewer::_freeImage { imh } {
359    if {[info exists _icon2file($imh)]} {
360        image delete $imh
361        set fileName $_icon2file($imh)
362        unset _icon2file($imh)
363        unset _file2icon($fileName)
364    }
365}
366
367# ----------------------------------------------------------------------
368# OPTION: -background
369# ----------------------------------------------------------------------
370itcl::configbody Rappture::HTMLviewer::background {
371    $_dispatcher event -idle !config
372}
373
374# ----------------------------------------------------------------------
375# OPTION: -foreground
376# ----------------------------------------------------------------------
377itcl::configbody Rappture::HTMLviewer::foreground {
378    $_dispatcher event -idle !config
379}
380
381# ----------------------------------------------------------------------
382# OPTION: -linknormalcolor
383# ----------------------------------------------------------------------
384itcl::configbody Rappture::HTMLviewer::linknormalcolor {
385    $_dispatcher event -idle !config
386}
387
388# ----------------------------------------------------------------------
389# OPTION: -linkactivecolor
390# ----------------------------------------------------------------------
391itcl::configbody Rappture::HTMLviewer::linkactivecolor {
392    $_dispatcher event -idle !config
393}
394
395# ----------------------------------------------------------------------
396# OPTION: -linkactivebackground
397# ----------------------------------------------------------------------
398itcl::configbody Rappture::HTMLviewer::linkactivebackground {
399    $_dispatcher event -idle !config
400}
401
402# ----------------------------------------------------------------------
403# OPTION: -xscrollcommand
404# ----------------------------------------------------------------------
405itcl::configbody Rappture::HTMLviewer::xscrollcommand {
406    $itk_component(html) configure -xscrollcommand $itk_option(-xscrollcommand)
407}
408
409# ----------------------------------------------------------------------
410# OPTION: -yscrollcommand
411# ----------------------------------------------------------------------
412itcl::configbody Rappture::HTMLviewer::yscrollcommand {
413    $itk_component(html) configure -yscrollcommand $itk_option(-yscrollcommand)
414}
415
416# ----------------------------------------------------------------------
417# OPTION: -width
418# ----------------------------------------------------------------------
419itcl::configbody Rappture::HTMLviewer::width {
420    $itk_component(html) configure -width $itk_option(-width)
421}
422
423# ----------------------------------------------------------------------
424# OPTION: -maxlines
425# Sets the maximum number of lines for widgets with "-height 0"
426# ----------------------------------------------------------------------
427itcl::configbody Rappture::HTMLviewer::maxlines {
428    $_dispatcher event -idle !fixHeight
429}
430
431# ----------------------------------------------------------------------
432# OPTION: -height
433# Set to absolute size ("3i") or 0 for default size based on -maxlines.
434# ----------------------------------------------------------------------
435itcl::configbody Rappture::HTMLviewer::height {
436    $_dispatcher event -idle !fixHeight
437}
Note: See TracBrowser for help on using the repository browser.