1 | # ---------------------------------------------------------------------- |
---|
2 | # COMPONENT: Note - widget for displaying HTML notes |
---|
3 | # |
---|
4 | # This widget represents an entry on a control panel that displays |
---|
5 | # information to the user. It is not an input; it helps to describe |
---|
6 | # the interface. |
---|
7 | # ====================================================================== |
---|
8 | # AUTHOR: Michael McLennan, Purdue University |
---|
9 | # Copyright (c) 2004-2007 Purdue Research Foundation |
---|
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 http |
---|
16 | |
---|
17 | itcl::class Rappture::Note { |
---|
18 | inherit itk::Widget |
---|
19 | |
---|
20 | # need this only to be like other controls |
---|
21 | itk_option define -state state State "" |
---|
22 | |
---|
23 | constructor {owner path args} { # defined below } |
---|
24 | |
---|
25 | public method value {args} |
---|
26 | |
---|
27 | public method label {} |
---|
28 | public method tooltip {} |
---|
29 | |
---|
30 | protected method _setContents {info} |
---|
31 | protected method _escapeChars {text} |
---|
32 | |
---|
33 | private variable _owner "" ;# thing managing this control |
---|
34 | private variable _path "" ;# path in XML to this note |
---|
35 | } |
---|
36 | |
---|
37 | itk::usual Note { |
---|
38 | keep -cursor |
---|
39 | keep -foreground -background |
---|
40 | } |
---|
41 | |
---|
42 | # ---------------------------------------------------------------------- |
---|
43 | # CONSTRUCTOR |
---|
44 | # ---------------------------------------------------------------------- |
---|
45 | itcl::body Rappture::Note::constructor {owner path args} { |
---|
46 | if {[catch {$owner isa Rappture::ControlOwner} valid] != 0 || !$valid} { |
---|
47 | error "bad object \"$owner\": should be Rappture::ControlOwner" |
---|
48 | } |
---|
49 | set _owner $owner |
---|
50 | set _path $path |
---|
51 | |
---|
52 | # |
---|
53 | # Create the widget and configure it properly based on other |
---|
54 | # hints in the XML. |
---|
55 | # |
---|
56 | itk_component add scroller { |
---|
57 | Rappture::Scroller $itk_interior.scroller \ |
---|
58 | -xscrollmode auto -yscrollmode auto |
---|
59 | } |
---|
60 | pack $itk_component(scroller) -expand yes -fill both |
---|
61 | |
---|
62 | itk_component add html { |
---|
63 | Rappture::HTMLviewer $itk_component(scroller).html |
---|
64 | } |
---|
65 | $itk_component(scroller) contents $itk_component(html) |
---|
66 | |
---|
67 | eval itk_initialize $args |
---|
68 | |
---|
69 | _setContents [$_owner xml get $_path.contents] |
---|
70 | } |
---|
71 | |
---|
72 | # ---------------------------------------------------------------------- |
---|
73 | # USAGE: value ?-check? ?<newval>? |
---|
74 | # |
---|
75 | # Clients use this to query/set the value for this widget. With |
---|
76 | # no args, it returns the current value for the widget. If the |
---|
77 | # <newval> is specified, it sets the value of the widget and |
---|
78 | # sends a <<Value>> event. If the -check flag is included, the |
---|
79 | # new value is not actually applied, but just checked for correctness. |
---|
80 | # ---------------------------------------------------------------------- |
---|
81 | itcl::body Rappture::Note::value {args} { |
---|
82 | error "can't set value" |
---|
83 | } |
---|
84 | |
---|
85 | # ---------------------------------------------------------------------- |
---|
86 | # USAGE: label |
---|
87 | # |
---|
88 | # Clients use this to query the label associated with this widget. |
---|
89 | # Reaches into the XML and pulls out the appropriate label string. |
---|
90 | # ---------------------------------------------------------------------- |
---|
91 | itcl::body Rappture::Note::label {} { |
---|
92 | error "can't get label" |
---|
93 | } |
---|
94 | |
---|
95 | # ---------------------------------------------------------------------- |
---|
96 | # USAGE: tooltip |
---|
97 | # |
---|
98 | # Clients use this to query the tooltip associated with this widget. |
---|
99 | # Reaches into the XML and pulls out the appropriate description |
---|
100 | # string. Returns the string that should be used with the |
---|
101 | # Rappture::Tooltip facility. |
---|
102 | # ---------------------------------------------------------------------- |
---|
103 | itcl::body Rappture::Note::tooltip {} { |
---|
104 | error "can't get tooltip" |
---|
105 | } |
---|
106 | |
---|
107 | # ---------------------------------------------------------------------- |
---|
108 | # USAGE: _setContents <info> |
---|
109 | # |
---|
110 | # Used internally to load HTML info into the display area for this |
---|
111 | # widget. |
---|
112 | # ---------------------------------------------------------------------- |
---|
113 | itcl::body Rappture::Note::_setContents {info} { |
---|
114 | switch -regexp -- $info { |
---|
115 | ^https?:// { |
---|
116 | if {[catch {http::geturl $info} token] == 0} { |
---|
117 | set html [http::data $token] |
---|
118 | http::cleanup $token |
---|
119 | } else { |
---|
120 | set html "<html><body><h1>Oops! Internal Error</h1><p>[_escapeChars $token]</p></body></html>" |
---|
121 | } |
---|
122 | $itk_component(html) load $html |
---|
123 | } |
---|
124 | ^file:// { |
---|
125 | set file [string range $info 7 end] |
---|
126 | if {[file pathtype $file] != "absolute"} { |
---|
127 | # find the file on a search path |
---|
128 | set dir [[$_owner tool] installdir] |
---|
129 | set searchlist [list $dir [file join $dir docs]] |
---|
130 | foreach dir $searchlist { |
---|
131 | if {[file readable [file join $dir $file]]} { |
---|
132 | set file [file join $dir $file] |
---|
133 | break |
---|
134 | } |
---|
135 | } |
---|
136 | } |
---|
137 | |
---|
138 | # load the contents of the file |
---|
139 | set cmds { |
---|
140 | set fid [open $file r] |
---|
141 | set html [read $fid] |
---|
142 | close $fid |
---|
143 | } |
---|
144 | if {[catch $cmds result]} { |
---|
145 | set html "<html><body><h1>Oops! File Not Found</h1><p>[_escapeChars $result]</p></body></html>" |
---|
146 | } |
---|
147 | |
---|
148 | # not HTML? then escape nasty characters and display it. |
---|
149 | if {![regexp {<html>.*</html>} $html]} { |
---|
150 | set html "<html><body><p>[_escapeChars $html]</p></body></html>" |
---|
151 | } |
---|
152 | $itk_component(html) load $html -in $file |
---|
153 | } |
---|
154 | default { |
---|
155 | set html "<html><body><p>[_escapeChars $info]</p></body></html>" |
---|
156 | $itk_component(html) load $html |
---|
157 | } |
---|
158 | } |
---|
159 | } |
---|
160 | |
---|
161 | # ---------------------------------------------------------------------- |
---|
162 | # USAGE: _escapeChars <info> |
---|
163 | # |
---|
164 | # Used internally to escape HTML characters in ordinary text. Used |
---|
165 | # when trying to display ordinary text, which may have things like |
---|
166 | # "<b>" or "x < 2" embedded within it. |
---|
167 | # ---------------------------------------------------------------------- |
---|
168 | itcl::body Rappture::Note::_escapeChars {info} { |
---|
169 | regsub -all & $info \001 info |
---|
170 | regsub -all \" $info {\"} info |
---|
171 | regsub -all < $info {\<} info |
---|
172 | regsub -all > $info {\>} info |
---|
173 | regsub -all \001 $info {\&} info |
---|
174 | return $info |
---|
175 | } |
---|