home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / htmlib / sample.tcl < prev   
Text File  |  2000-11-02  |  8KB  |  259 lines
  1. #!/bin/sh
  2. # here is a sample html viewer to demonstrate the library usage
  3. # Copyright (c) 1995 by Sun Microsystems
  4. #
  5. # See the file "license.terms" for information on usage and redistribution
  6. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  7. #
  8. # This REQUIRES Tk4.0 -- make sure "wish" on the next line is a 4.0 version
  9. # The next line is a TK comment, but a shell command \
  10.   exec wish4.0 -f "$0" "$@" & exit 0
  11.  
  12. if {$tk_version < 4.0 || [regexp {b[123]} $tk_patchLevel] } {
  13.     puts stderr "This library requires TK4.0, this is only $tk_version, \
  14.             patchlevel $tk_patchLevel"
  15.     exit 1
  16. }
  17. if {[catch {array get env *}]} {
  18.     puts stderr "This library requires tcl7.4, this version is too old!"
  19.     exit 1
  20. }
  21. puts stderr "Starting sample HTML viewer..."
  22. source html_library.tcl
  23.  
  24. # construct a simple user interface
  25.  
  26. proc setup {} {
  27.     frame .frame
  28.     menubutton .menu -relief raised -bd 2 -text options... -menu .menu.m
  29.     button .quit  -command exit  -text quit
  30.     entry .entry  -textvariable Url -width 35
  31.     label .file  -text file:
  32.     label .status -textvariable Running -width 6 -relief ridge \
  33.             -bd 2 -padx 9 -pady 3
  34.     label .msg -textvariable message
  35.     scrollbar .scrollbar  -command ".text yview"  -orient v
  36.     option add *Text.height 40 startup
  37.     option add *Text.width 80 startup
  38.     text .text  -yscrollcommand ".scrollbar set" -padx 3 -pady 3 -takefocus 0
  39.  
  40.     pack .frame .msg -side top
  41.     pack .scrollbar -side left -expand 0 -fill y
  42.     pack .text -side left -fill both -expand 1
  43.     pack .file .entry .status .menu .quit -in .frame -side left
  44.  
  45.     # set up some sample keyboard bindings for the text widget
  46.     bind .entry <Return> {render $Url}
  47.     bind all <End> {.text yview end}
  48.     bind all <Home> {.text yview 0.0}
  49.     bind all <Next> {.text yview scroll 1 page}
  50.     bind all <Prior> {.text yview scroll -1 page}
  51.  
  52.     # I'm constantly being criticized for never using menus.
  53.     # so here's a menu.  So there.
  54.     menu .menu.m
  55.     .menu.m add command -label "option menu"
  56.     .menu.m add separator
  57.     .menu.m add command -label "font size" -foreground red 
  58.     .menu.m add radiobutton -label small -value 0   -variable Size \
  59.         -command {HMset_state .text -size $Size; render $Url}
  60.     .menu.m add radiobutton -label medium -value 4  -variable Size \
  61.         -command {HMset_state .text -size $Size; render $Url}
  62.     .menu.m add radiobutton -label large -value 12  -variable Size \
  63.         -command {HMset_state .text -size $Size; render $Url}
  64.     .menu.m add separator
  65.     .menu.m add command -label "indent level" -foreground red
  66.     .menu.m add radiobutton -label small -value 0.6 -variable Indent \
  67.         -command {HMset_indent .text $Indent}
  68.     .menu.m add radiobutton -label medium -value 1.2 -variable Indent \
  69.         -command {HMset_indent .text $Indent}
  70.     .menu.m add radiobutton -label large -value 2.4 -variable Indent \
  71.         -command {HMset_indent .text $Indent}
  72. }
  73.  
  74. # Go render a page.  We have to make sure we don't render one page while
  75. # still rendering the previous one.  If we get here from a recursive 
  76. # invocation of the event loop, cancel whatever we were rendering when
  77. # we were called.
  78. # If we have a fragment name, try to go there.
  79.  
  80. proc render {file} {
  81.     global HM.text Url
  82.     global Running message
  83.  
  84.     set fragment ""
  85.     regexp {([^#]*)#(.+)} $file dummy file fragment
  86.     if {$file == "" && $fragment != ""} {
  87.         HMgoto .text $fragment
  88.         return
  89.     }
  90.     HMreset_win .text
  91.     set Running busy
  92.     set message "Displaying $file"
  93.     update idletasks
  94.     if {$fragment != ""} {
  95.         HMgoto .text $fragment
  96.     }
  97.     set Url $file
  98.     HMparse_html [get_html $file] {HMrender .text}
  99.     set Running ready
  100.     HMset_state .text -stop 1    ;# stop rendering previous page if busy
  101.     set message ""
  102. }
  103.  
  104. # given a file name, return its html, or invent some html if the file can't
  105. # be opened.
  106.  
  107. proc get_html {file} {
  108.     global Home
  109.     if {[catch {set fd [open $file]} msg]} {
  110.         return "
  111.             <title>Bad file $file</title>
  112.             <h1>Error reading $file</h1><p>
  113.             $msg<hr>
  114.             <a href=$Home>Go home</a>
  115.         "
  116.     }
  117.     set result [read $fd]
  118.     close $fd
  119.     return $result
  120. }
  121.  
  122. # Override the library link-callback routine for the sample app.
  123. # It only handles the simple cases.
  124.  
  125. proc HMlink_callback {win href} {
  126.     global Url
  127.  
  128.     if {[string match #* $href]} {
  129.         render $href
  130.         return
  131.     }
  132.     if {[string match /* $href]} {
  133.         set Url $href
  134.     } else {
  135.         set Url [file dirname $Url]/$href
  136.     }
  137.     update
  138.     render $Url
  139. }
  140.  
  141. # Supply an image callback function
  142. # Read in an image if we don't already have one
  143. # callback to library for display
  144.  
  145. proc HMset_image {win handle src} {
  146.     global Url message
  147.     if {[string match /* $src]} {
  148.         set image $src
  149.     } else {
  150.         set image [file dirname $Url]/$src
  151.     }
  152.     set message "fetching image $image"
  153.     update
  154.     if {[string first " $image " " [image names] "] >= 0} {
  155.         HMgot_image $handle $image
  156.     } else {
  157.         set type photo
  158.         if {[file extension $image] == ".bmp"} {set type bitmap}
  159.         catch {image create $type $image -file $image} image
  160.         HMgot_image $handle $image
  161.     }
  162. }
  163.  
  164. # Handle base tags.  This breaks if more than 1 base tag is in the document
  165.  
  166. proc HMtag_base {win param text} {
  167.     global Url
  168.     upvar #0 HM$win var
  169.     HMextract_param $param href Url
  170. }
  171.  
  172. # downloading fonts can take a long time.  We'll override the default
  173. # font-setting routine to permit better user feedback on fonts.  We'll
  174. # keep our own list of installed fonts on the side, to guess when delays
  175. # are likely
  176.  
  177. proc HMset_font {win tag font} {
  178.     global message Fonts
  179.     if {![info exists Fonts($font)]} {
  180.         set Fonts($font) 1
  181.         .msg configure -fg blue
  182.         set message "downloading font $font"
  183.         update
  184.     }
  185.     .msg configure -fg black
  186.     set message ""
  187.     catch {$win tag configure $tag -font $font} message
  188. }
  189.  
  190. # Lets invent a new HTML tag, just for fun.
  191. # Change the color of the text. Use html tags of the form:
  192. # <color value=blue> ... </color>
  193. # We can invent a new tag for the display stack.  If it starts with "T"
  194. # it will automatically get mapped directly to a text widget tag.
  195.  
  196. proc HMtag_color {win param text} {
  197.     upvar #0 HM$win var
  198.     set value bad_color
  199.     HMextract_param $param value
  200.     $win tag configure $value -foreground $value
  201.     HMstack $win "" "Tcolor $value"
  202. }
  203.  
  204. proc HMtag_/color {win param text} {
  205.     upvar #0 HM$win var
  206.     HMstack $win / "Tcolor {}"
  207. }
  208.  
  209. # Add a font size manipulation primitive, so we can use this sample program
  210. # for on-line presentations.  sizes prefixed with + or - are relative.
  211. #  <font size=[+-]3>  ..... </font>.  Note that this is not the same as
  212. # Netscape's <font> tag.
  213.  
  214. proc HMtag_font {win param text} {
  215.     upvar #0 HM$win var
  216.     set size 0; set sign ""
  217.     HMextract_param $param size
  218.     regexp {([+-])? *([0-9]+)} $size dummy sign size
  219.     if {$sign != ""} {
  220.         set size [expr [lindex $var(size) end] $sign $size]
  221.     }
  222.     HMstack $win {} "size $size"
  223. }
  224.  
  225. # This version is closer to what Netscape does
  226.  
  227. proc HMtag_font {win param text} {
  228.     upvar #0 HM$win var
  229.     set size 0; set sign ""
  230.     HMextract_param $param size
  231.     regexp {([+-])? *([0-9]+)} $size dummy sign size
  232.     if {$sign != ""} {
  233.         set size [expr [lindex $var(size) end] $sign  $size*2]
  234.         HMstack $win {} "size $size"
  235.     } else {
  236.         HMstack $win {} "size [expr 10 + 2 * $size]"
  237.     }
  238. }
  239.  
  240. proc HMtag_/font {win param text} {
  241.     upvar #0 HM$win var
  242.     HMstack $win / "size {}"
  243. }
  244.  
  245. # set initial values
  246. set Size 4                    ;# font size adjustment
  247. set Indent 1.2                ;# tab spacing (cm)
  248. set Home [pwd]/html/help.html        ;# home document
  249. set Url $Home                ;# current file
  250. set Running busy            ;# page status
  251. set message ""                ;# message line
  252.  
  253. # make the interface and render the home page
  254. catch setup        ;# the catch lets us re-source this file
  255. HMinit_win .text
  256. HMset_state .text -size $Size
  257. HMset_indent .text $Indent
  258. render $Home
  259.