Posted to tcl by bleb at Fri Nov 03 03:32:49 GMT 2023view raw

  1. #
  2. # This script implements the "hv" application. Type "hv FILE" to
  3. # view FILE as HTML.
  4. #
  5. # This application is used for testing the HTML widget. It can
  6. # also server as an example of how to use the HTML widget.
  7. #
  8. # @(#) $Id: hv.tcl,v 1.31 2003/01/28 09:43:23 hkoba Exp $
  9. #
  10. wm title . {HTML File Viewer}
  11. wm iconname . {HV}
  12.  
  13. # Make sure the html widget is loaded into
  14. # our interpreter
  15. #
  16. if {[info command html]==""} {
  17. if {[catch {package require Tkhtml} error]} {
  18. foreach f {
  19. ./libTkhtml*.so
  20. ../libTkhtml*.so
  21. /usr/lib/libTkhtml*.so
  22. /usr/local/lib/libTkhtml*.so
  23. ./tkhtml.dll
  24. } {
  25. if {[set f [lindex [glob -nocomplain $f] end]] != ""} {
  26. if {[catch {load $f Tkhtml}]==0} break
  27. }
  28. }
  29. }
  30. }
  31.  
  32. load libTkhtml.so Tkhtml
  33.  
  34. # The HtmlTraceMask only works if the widget was compiled with
  35. # the -DDEBUG=1 command-line option. "file" is the name of the
  36. # first HTML file to be loaded.
  37. #
  38. set HtmlTraceMask 0
  39. set file {}
  40. foreach a $argv {
  41. if {[regexp {^debug=} $a]} {
  42. scan $a "debug=0x%x" HtmlTraceMask
  43. } else {
  44. set file $a
  45. }
  46. }
  47.  
  48. # These images are used in place of GIFs or of form elements
  49. #
  50. image create photo biggray -data {
  51. R0lGODdhPAA+APAAALi4uAAAACwAAAAAPAA+AAACQISPqcvtD6OctNqLs968+w+G4kiW5omm
  52. 6sq27gvH8kzX9o3n+s73/g8MCofEovGITCqXzKbzCY1Kp9Sq9YrNFgsAO///
  53. }
  54. image create photo smgray -data {
  55. R0lGODdhOAAYAPAAALi4uAAAACwAAAAAOAAYAAACI4SPqcvtD6OctNqLs968+w+G4kiW5omm
  56. 6sq27gvH8kzX9m0VADv/
  57. }
  58. image create photo nogifbig -data {
  59. R0lGODdhJAAkAPEAAACQkADQ0PgAAAAAACwAAAAAJAAkAAACmISPqcsQD6OcdJqKM71PeK15
  60. AsSJH0iZY1CqqKSurfsGsex08XuTuU7L9HywHWZILAaVJssvgoREk5PolFo1XrHZ29IZ8oo0
  61. HKEYVDYbyc/jFhz2otvdcyZdF68qeKh2DZd3AtS0QWcDSDgWKJXY+MXS9qY4+JA2+Vho+YPp
  62. FzSjiTIEWslDQ1rDhPOY2sXVOgeb2kBbu1AAADv/
  63. }
  64. image create photo nogifsm -data {
  65. R0lGODdhEAAQAPEAAACQkADQ0PgAAAAAACwAAAAAEAAQAAACNISPacHtD4IQz80QJ60as25d
  66. 3idKZdR0IIOm2ta0Lhw/Lz2S1JqvK8ozbTKlEIVYceWSjwIAO///
  67. }
  68.  
  69. # Construct the main window
  70. #
  71. frame .mbar -bd 2 -relief raised
  72. pack .mbar -side top -fill x
  73. menubutton .mbar.file -text File -underline 0 -menu .mbar.file.m
  74. pack .mbar.file -side left -padx 5
  75. set m [menu .mbar.file.m]
  76. $m add command -label Open -underline 0 -command Load
  77. $m add command -label Refresh -underline 0 -command Refresh
  78. $m add separator
  79. $m add command -label Exit -underline 1 -command exit
  80. menubutton .mbar.view -text View -underline 0 -menu .mbar.view.m
  81. pack .mbar.view -side left -padx 5
  82. set m [menu .mbar.view.m]
  83. set underlineHyper 0
  84. $m add checkbutton -label {Underline Hyperlinks} -variable underlineHyper
  85. trace variable underlineHyper w ChangeUnderline
  86. proc ChangeUnderline args {
  87. global underlineHyper
  88. .h.h config -underlinehyperlinks $underlineHyper
  89. }
  90. set showTableStruct 0
  91. $m add checkbutton -label {Show Table Structure} -variable showTableStruct
  92. trace variable showTableStruct w ShowTableStruct
  93. proc ShowTableStruct args {
  94. global showTableStruct HtmlTraceMask
  95. if {$showTableStruct} {
  96. set HtmlTraceMask [expr {$HtmlTraceMask|0x8}]
  97. .h.h config -tablerelief flat
  98. } else {
  99. set HtmlTraceMask [expr {$HtmlTraceMask&~0x8}]
  100. .h.h config -tablerelief raised
  101. }
  102. Refresh
  103. }
  104. set showImages 1
  105. $m add checkbutton -label {Show Images} -variable showImages
  106. trace variable showImages w Refresh
  107.  
  108. # Construct the main HTML viewer
  109. #
  110. frame .h
  111. pack .h -side top -fill both -expand 1
  112. html .h.h \
  113. -yscrollcommand {.h.vsb set} \
  114. -xscrollcommand {.f2.hsb set} \
  115. -padx 5 \
  116. -pady 9 \
  117. -formcommand FormCmd \
  118. -imagecommand ImageCmd \
  119. -scriptcommand ScriptCmd \
  120. -appletcommand AppletCmd \
  121. -underlinehyperlinks 0 \
  122. -bg white -tablerelief raised
  123.  
  124. # If the tracemask is not 0, then draw the outline of all
  125. # tables as a blank line, not a 3D relief.
  126. #
  127. if {$HtmlTraceMask} {
  128. .h.h config -tablerelief flat
  129. }
  130.  
  131. # A font chooser routine.
  132. #
  133. # .h.h config -fontcommand pickFont
  134. proc pickFont {size attrs} {
  135. puts "FontCmd: $size $attrs"
  136. set a [expr {-1<[lsearch $attrs fixed]?{courier}:{charter}}]
  137. set b [expr {-1<[lsearch $attrs italic]?{italic}:{roman}}]
  138. set c [expr {-1<[lsearch $attrs bold]?{bold}:{normal}}]
  139. set d [expr {int(12*pow(1.2,$size-4))}]
  140. list $a $d $b $c
  141. }
  142.  
  143. # This routine is called for each form element
  144. #
  145. proc FormCmd {n cmd style args} {
  146. # puts "FormCmd: $n $cmd $args"
  147. switch $cmd {
  148. select -
  149. textarea -
  150. input {
  151. set w [lindex $args 0]
  152. label $w -image nogifsm
  153. }
  154. }
  155. }
  156.  
  157. # This routine is called for every <IMG> markup
  158. #
  159. # proc ImageCmd {args} {
  160. # puts "image: $args"
  161. # set fn [lindex $args 0]
  162. # if {[catch {image create photo -file $fn} img]} {
  163. # return nogifsm
  164. # } else {
  165. # global Images
  166. # set Images($img) 1
  167. # return $img
  168. # }
  169. #}
  170. proc ImageCmd {args} {
  171. global OldImages Images showImages
  172. if {!$showImages} {
  173. return smgray
  174. }
  175. set fn [lindex $args 0]
  176. if {[info exists OldImages($fn)]} {
  177. set Images($fn) $OldImages($fn)
  178. unset OldImages($fn)
  179. return $Images($fn)
  180. }
  181. if {[catch {image create photo -file $fn} img]} {
  182. return smgray
  183. }
  184. if {[image width $img]*[image height $img]>20000} {
  185. global BigImages
  186. set b [image create photo -width [image width $img] \
  187. -height [image height $img]]
  188. set BigImages($b) $img
  189. set img $b
  190. after idle "MoveBigImage $b"
  191. }
  192. set Images($fn) $img
  193. return $img
  194. }
  195. proc MoveBigImage b {
  196. global BigImages
  197. if {![info exists BigImages($b)]} return
  198. $b copy $BigImages($b)
  199. image delete $BigImages($b)
  200. unset BigImages($b)
  201. update
  202. }
  203.  
  204.  
  205. # This routine is called for every <SCRIPT> markup
  206. #
  207. proc ScriptCmd {args} {
  208. # puts "ScriptCmd: $args"
  209. }
  210.  
  211. # This routine is called for every <APPLET> markup
  212. #
  213. proc AppletCmd {w arglist} {
  214. # puts "AppletCmd: w=$w arglist=$arglist"
  215. label $w -text "The Applet $w" -bd 2 -relief raised
  216. }
  217. namespace eval tkhtml {
  218. array set Priv {}
  219. }
  220.  
  221. # This procedure is called when the user clicks on a hyperlink.
  222. # See the "bind .h.h.x" below for the binding that invokes this
  223. # procedure
  224. #
  225. proc HrefBinding {x y} {
  226. # koba & dg marking text
  227. .h.h selection clear
  228. set ::tkhtml::Priv(mark) $x,$y
  229. set list [.h.h href $x $y]
  230. if {![llength $list]} {return}
  231. foreach {new target} $list break
  232. if {$new!=""} {
  233. global LastFile
  234. set pattern $LastFile#
  235. set len [string length $pattern]
  236. incr len -1
  237. if {[string range $new 0 $len]==$pattern} {
  238. incr len
  239. .h.h yview [string range $new $len end]
  240. } else {
  241. LoadFile $new
  242. }
  243. }
  244. }
  245. bind .h.h.x <1> {HrefBinding %x %y}
  246. # marking text with the mouse and copying to the clipboard just with tkhtml2.0 working
  247. bind .h.h.x <B1-Motion> {
  248. %W selection set @$::tkhtml::Priv(mark) @%x,%y
  249. clipboard clear
  250. # avoid tkhtml0.0 errors
  251. # anyone can fix this for tkhtml0.0
  252. catch {
  253. clipboard append [selection get]
  254. }
  255. }
  256.  
  257. # Pack the HTML widget into the main screen.
  258. #
  259. pack .h.h -side left -fill both -expand 1
  260. scrollbar .h.vsb -orient vertical -command {.h.h yview}
  261. pack .h.vsb -side left -fill y
  262.  
  263. frame .f2
  264. pack .f2 -side top -fill x
  265. frame .f2.sp -width [winfo reqwidth .h.vsb] -bd 2 -relief raised
  266. pack .f2.sp -side right -fill y
  267. scrollbar .f2.hsb -orient horizontal -command {.h.h xview}
  268. pack .f2.hsb -side top -fill x
  269.  
  270. # This procedure is called when the user selects the File/Open
  271. # menu option.
  272. #
  273. set lastDir [pwd]
  274. proc Load {} {
  275. set filetypes {
  276. {{Html Files} {.html .htm}}
  277. {{All Files} *}
  278. }
  279. global lastDir htmltext
  280. set f [tk_getOpenFile -initialdir $lastDir -filetypes $filetypes]
  281. if {$f!=""} {
  282. LoadFile $f
  283. set lastDir [file dirname $f]
  284. }
  285. }
  286.  
  287. # Clear the screen.
  288. #
  289. # Clear the screen.
  290. #
  291. proc Clear {} {
  292. global Images OldImages hotkey
  293. if {[winfo exists .fs.h]} {set w .fs.h} {set w .h.h}
  294. $w clear
  295. catch {unset hotkey}
  296. ClearBigImages
  297. ClearOldImages
  298. foreach fn [array names Images] {
  299. set OldImages($fn) $Images($fn)
  300. }
  301. catch {unset Images}
  302. }
  303. proc ClearOldImages {} {
  304. global OldImages
  305. foreach fn [array names OldImages] {
  306. image delete $OldImages($fn)
  307. }
  308. catch {unset OldImages}
  309. }
  310. proc ClearBigImages {} {
  311. global BigImages
  312. foreach b [array names BigImages] {
  313. image delete $BigImages($b)
  314. }
  315. catch {unset BigImages}
  316. }
  317.  
  318. # Read a file
  319. #
  320. proc ReadFile {name} {
  321. if {[catch {open $name r} fp]} {
  322. tk_messageBox -icon error -message $fp -type ok
  323. return {}
  324. } else {
  325. set r [read $fp [file size $name]]
  326. close $fp
  327. return $r
  328. }
  329. }
  330.  
  331. # Load a file into the HTML widget
  332. #
  333. proc LoadFile {name} {
  334. set html [ReadFile $name]
  335. if {$html==""} return
  336. Clear
  337. global LastFile
  338. set LastFile $name
  339. .h.h config -base $name
  340. .h.h parse $html
  341. ClearOldImages
  342. }
  343.  
  344. # Refresh the current file.
  345. #
  346. proc Refresh {args} {
  347. global LastFile
  348. if {![info exists LastFile]} return
  349. LoadFile $LastFile
  350. }
  351.  
  352. # If an arguent was specified, read it into the HTML widget.
  353. #
  354. update
  355. if {$file!=""} {
  356. LoadFile $file
  357. }
  358.  
  359.  
  360. # This binding changes the cursor when the mouse move over
  361. # top of a hyperlink.
  362. #
  363. bind HtmlClip <Motion> {
  364. set parent [winfo parent %W]
  365. set url [$parent href %x %y]
  366. if {[string length $url] > 0} {
  367. $parent configure -cursor hand2
  368. } else {
  369. $parent configure -cursor {}
  370. }
  371. }
  372.