home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / html_lib.tcl < prev    next >
Encoding:
Text File  |  1995-11-06  |  22.4 KB  |  801 lines
  1. # Simple HTML display library by Stephen Uhler (stephen.uhler@sun.com)
  2. # Copyright (c) 1995 by Sun Microsystems
  3. # Version 0.3 Fri Sep  1 10:47:17 PDT 1995
  4. #
  5. # *** Modified for SpecTcl *****
  6. # *  removed forms and image maps
  7. # *  added support for <li src=symbol.gif> for graphical list symbols
  8. # *  added '\' fix from 0.4 version
  9. #
  10. # See the file "license.txt" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13. # To use this package,  create a text widget (say, .text)
  14. # and set a variable full of html, (say $html), and issue:
  15. #    HMinit_win .text
  16. #    HMparse_html $html "HMrender .text"
  17. # You also need to supply the routine:
  18. #   proc HMlink_callback {win href} { ...}
  19. #      win:  The name of the text widget
  20. #      href  The name of the link
  21. # which will be called anytime the user "clicks" on a link.
  22. # The supplied version just prints the link to stdout.
  23. # In addition, if you wish to use embedded images, you will need to write
  24. #   proc HMset_image {handle src}
  25. #      handle  an arbitrary handle (not really)
  26. #      src     The name of the image
  27. # Which calls
  28. #    HMgot_image $handle $image
  29. # with the TK image.
  30. #
  31. # To return a "used" text widget to its initialized state, call:
  32. #   HMreset_win .text
  33. # See "sample.tcl" for sample usage
  34. ##################################################################
  35. # mapping of html tags to text tag properties
  36. # properties beginning with "T" map directly to text tags
  37.  
  38. # These are Defined in HTML 2.0
  39.  
  40. array set HMtag_map {
  41.     b      {weight bold}
  42.     blockquote    {style i indent 1 Trindent rindent}
  43.     bq        {style i indent 1 Trindent rindent}
  44.     cite   {style i}
  45.     code   {family courier}
  46.     dfn    {style i}    
  47.     dir    {indent 1}
  48.     dl     {indent 1}
  49.     em     {style i}
  50.     h1     {size 24 weight bold}
  51.     h2     {size 22}        
  52.     h3     {size 20}    
  53.     h4     {size 18}
  54.     h5     {size 16}
  55.     h6     {style i}
  56.     i      {style i}
  57.     kbd    {family courier weight bold}
  58.     menu     {indent 1}
  59.     ol     {indent 1}
  60.     pre    {fill 0 family courier Tnowrap nowrap}
  61.     samp   {family courier}        
  62.     strong {weight bold}        
  63.     tt     {family courier}
  64.     u     {Tunderline underline}
  65.     ul     {indent 1}
  66.     var    {style i}    
  67. }
  68.  
  69. # These are in common(?) use, but not defined in html2.0
  70.  
  71. array set HMtag_map {
  72.     center {Tcenter center}
  73.     strike {Tstrike strike}
  74.     u       {Tunderline underline}
  75. }
  76.  
  77. # initial values
  78.  
  79. set HMtag_map(hmstart) {
  80.     family times   weight medium   style r   size 14
  81.     Tcenter ""   Tlink ""   Tnowrap ""   Tunderline ""   list list
  82.     fill 1   indent "" counter 0 adjust 0
  83. }
  84.  
  85. # html tags that insert white space
  86.  
  87. array set HMinsert_map {
  88.     blockquote "\n\n" /blockquote "\n"
  89.     br    "\n"
  90.     dd    "\n" /dd    "\n"
  91.     dl    "\n" /dl    "\n"
  92.     dt    "\n"
  93.     form "\n"    /form "\n"
  94.     h1    "\n\n"    /h1    "\n"
  95.     h2    "\n\n"    /h2    "\n"
  96.     h3    "\n\n"    /h3    "\n"
  97.     h4    "\n"    /h4    "\n"
  98.     h5    "\n"    /h5    "\n"
  99.     h6    "\n"    /h6    "\n"
  100.     li   "\n"
  101.     /dir "\n"
  102.     /ul "\n"
  103.     /ol "\n"
  104.     /menu "\n"
  105.     p    "\n\n"
  106.     pre "\n"    /pre "\n"
  107. }
  108.  
  109. # tags that are list elements, that support "compact" rendering
  110.  
  111. array set HMlist_elements {
  112.     ol 1   ul 1   menu 1   dl 1   dir 1
  113. }
  114. ############################################
  115. # initialize the window and stack state
  116.  
  117. proc HMinit_win {win} {
  118.     upvar #0 HM$win var
  119.     
  120.     HMinit_state $win
  121.     $win tag configure underline -underline 1
  122.     $win tag configure center -justify center
  123.     $win tag configure nowrap -wrap none
  124.     $win tag configure rindent -rmargin $var(S_tab)c
  125.     $win tag configure strike -overstrike 1
  126.     $win tag configure mark -foreground red        ;# list markers
  127.     $win tag configure list -spacing1 3p -spacing3 3p        ;# regular lists
  128.     $win tag configure compact -spacing1 0p        ;# compact lists
  129.     $win tag configure link -borderwidth 2 -foreground blue    ;# hypertext links
  130.     HMset_indent $win $var(S_tab)
  131.     $win configure -wrap word
  132.  
  133.     # configure the text insertion point
  134.     $win mark set $var(S_insert) 1.0
  135.  
  136.     # for horizontal rules
  137.     $win tag configure thin -font [HMx_font times 2 medium r]
  138.     $win tag configure hr -relief sunken -borderwidth 2 -wrap none \
  139.         -tabs [expr [winfo width $win] -8]
  140.     bind $win <Configure> {
  141.         %W tag configure hr -tabs %w
  142.         %W tag configure last -spacing3 %h
  143.     }
  144.  
  145.     # generic link enter callback
  146.  
  147.     $win tag bind link <1> "HMlink_hit $win %x %y"
  148. }
  149.  
  150. # set the indent spacing (in cm) for lists
  151. # TK uses a "weird" tabbing model that causes \t to insert a single
  152. # space if the current line position is past the tab setting
  153.  
  154. proc HMset_indent {win cm} {
  155.     set tabs [expr $cm / 2.0]
  156.     $win configure -tabs ${tabs}c
  157.     foreach i {1 2 3 4 5 6 7 8 9} {
  158.         set tab [expr $i * $cm]
  159.         $win tag configure indent$i -lmargin1 ${tab}c -lmargin2 ${tab}c \
  160.             -tabs "[expr $tab + $tabs]c  right [expr $tab + 2*$tabs]c"
  161.     }
  162. }
  163.  
  164. # reset the state of window - get ready for the next page
  165. # remove all but the font tags, and remove all form state
  166.  
  167. proc HMreset_win {win} {
  168.     upvar #0 HM$win var
  169.     regsub -all { +[^L ][^ ]*} " [$win tag names] " {} tags
  170.     catch "$win tag delete $tags"
  171.     eval $win mark unset [$win mark names]
  172.     $win delete 0.0 end
  173.     $win tag configure hr -tabs [winfo width $win]
  174.  
  175.     # configure the text insertion point
  176.     $win mark set $var(S_insert) 1.0
  177.  
  178.     # remove form state.  If any check/radio buttons still exists, 
  179.     # their variables will be magically re-created, and never get
  180.     # cleaned up.
  181.     catch unset [info globals HM$win.form*]
  182.  
  183.     HMinit_state $win
  184.     return HM$win
  185. }
  186.  
  187. # initialize the window's state array
  188. # Parameters beginning with S_ are NOT reset
  189. #  adjust_size:        global font size adjuster
  190. #  unknown:        character to use for unknown entities
  191. #  tab:            tab stop (in cm)
  192. #  stop:        enabled to stop processing
  193. #  update:        how many tags between update calls
  194. #  tags:        number of tags processed so far
  195. #  symbols:        Symbols to use on un-ordered lists
  196.  
  197. proc HMinit_state {win} {
  198.     upvar #0 HM$win var
  199.     array set tmp [array get var S_*]
  200.     catch {unset var}
  201.     array set var {
  202.         stop 0
  203.         tags 0
  204.         fill 0
  205.         list list
  206.         S_adjust_size 0
  207.         S_tab 1.0
  208.         S_unknown \xb7
  209.         S_update 10
  210.         S_symbols O*=+-o\xd7\xb0>:\xb7
  211.         S_insert Insert
  212.     }
  213.     array set var [array get tmp]
  214. }
  215.  
  216. # alter the parameters of the text state
  217. # this allows an application to over-ride the default settings
  218. # it is called as: HMset_state -param value -param value ...
  219.  
  220. array set HMparam_map {
  221.     -update S_update
  222.     -tab S_tab
  223.     -unknown S_unknown
  224.     -stop stop
  225.     -size S_adjust_size
  226.     -symbols S_symbols
  227.     -insert S_insert
  228. }
  229.  
  230. proc HMset_state {win args} {
  231.     upvar #0 HM$win var
  232.     global HMparam_map
  233.     set bad 0
  234.     if {[catch {array set params $args}]} {return 0}
  235.     foreach i [array names params] {
  236.         incr bad [catch {set var($HMparam_map($i)) $params($i)}]
  237.     }
  238.     return [expr $bad == 0]
  239. }
  240.  
  241. ############################################
  242. # manage the display of html
  243.  
  244. # HMrender gets called for every html tag
  245. #   win:   The name of the text widget to render into
  246. #   tag:   The html tag (in arbitrary case)
  247. #   not:   a "/" or the empty string
  248. #   param: The un-interpreted parameter list
  249. #   text:  The plain text until the next html tag
  250.  
  251. proc HMrender {win tag not param text} {
  252.     upvar #0 HM$win var
  253.     if {$var(stop)} return
  254.     global HMtag_map HMinsert_map HMlist_elements
  255.     set tag [string tolower $tag]
  256.     set text [HMmap_esc $text]
  257.  
  258.     # manage compact rendering of lists
  259.     if {[info exists HMlist_elements($tag)]} {
  260.         set list "list [expr {[HMextract_param $param compact] ? "compact" : "list"}]"
  261.     } else {
  262.         set list ""
  263.     }
  264.  
  265.     # Allow text to be diverted to a different window (for tables)
  266.     # this is not currently used
  267.     if {[info exists var(divert)]} {
  268.         set win $var(divert)
  269.         upvar #0 HM$win var
  270.     }
  271.  
  272.     # adjust (push or pop) tag state
  273.     catch {HMstack $win $not "$HMtag_map($tag) $list"}
  274.  
  275.     # insert white space (with current font)
  276.     # adding white space can get a bit tricky.  This isn't quite right
  277.     set bad [catch {$win insert $var(S_insert) $HMinsert_map($not$tag) "space $var(font)"}]
  278.     if {!$bad && [lindex $var(fill) end]} {
  279.         set text [string trimleft $text]
  280.     }
  281.  
  282.     # to fill or not to fill
  283.     if {[lindex $var(fill) end]} {
  284.         set text [HMzap_white $text]
  285.     }
  286.  
  287.     # generic mark hook
  288.     catch {HMmark $not$tag $win $param text} err
  289.  
  290.     # do any special tag processing
  291.     catch {HMtag_$not$tag $win $param text} msg
  292.  
  293.  
  294.     # add the text with proper tags
  295.  
  296.     set tags [HMcurrent_tags $win]
  297.     $win insert $var(S_insert) $text $tags
  298.  
  299.     # We need to do an update every so often to insure interactive response.
  300.     # This can cause us to re-enter the event loop, and cause recursive
  301.     # invocations of HMrender, so we need to be careful.
  302.     if {!([incr var(tags)] % $var(S_update))} {
  303.         update
  304.     }
  305. }
  306.  
  307. # html tags requiring special processing
  308. # Procs of the form HMtag_<tag> or HMtag_</tag> get called just before
  309. # the text for this tag is displayed.  These procs are called inside a 
  310. # "catch" so it is OK to fail.
  311. #   win:   The name of the text widget to render into
  312. #   param: The un-interpreted parameter list
  313. #   text:  A pass-by-reference name of the plain text until the next html tag
  314. #          Tag commands may change this to affect what text will be inserted
  315. #          next.
  316.  
  317. # A pair of pseudo tags are added automatically as the 1st and last html
  318. # tags in the document.  The default is <HMstart> and </HMstart>.
  319. # Append enough blank space at the end of the text widget while
  320. # rendering so HMgoto can place the target near the top of the page,
  321. # then remove the extra space when done rendering.
  322.  
  323. proc HMtag_hmstart {win param text} {
  324.     upvar #0 HM$win var
  325.     $win mark gravity $var(S_insert) left
  326.     $win insert end "\n " last
  327.     $win mark gravity $var(S_insert) right
  328. }
  329.  
  330. proc HMtag_/hmstart {win param text} {
  331.     $win delete last.first end
  332. }
  333.  
  334. # put the document title in the window banner, and remove the title text
  335. # from the document
  336.  
  337. proc HMtag_title {win param text} {
  338.     upvar $text data
  339.     wm title [winfo toplevel $win] $data
  340.     set data ""
  341. }
  342.  
  343. proc HMtag_hr {win param text} {
  344.     upvar #0 HM$win var
  345.     $win insert $var(S_insert) "\n" space "\n" thin "\t" "thin hr" "\n" thin
  346. }
  347.  
  348. # list element tags
  349.  
  350. proc HMtag_ol {win param text} {
  351.     upvar #0 HM$win var
  352.     set var(count$var(level)) 0
  353. }
  354.  
  355. proc HMtag_ul {win param text} {
  356.     upvar #0 HM$win var
  357.     catch {unset var(count$var(level))}
  358. }
  359.  
  360. proc HMtag_menu {win param text} {
  361.     upvar #0 HM$win var
  362.     set var(menu) ->
  363.     set var(compact) 1
  364. }
  365.  
  366. proc HMtag_/menu {win param text} {
  367.     upvar #0 HM$win var
  368.     catch {unset var(menu)}
  369.     catch {unset var(compact)}
  370. }
  371.     
  372. proc HMtag_dt {win param text} {
  373.     upvar #0 HM$win var
  374.     upvar $text data
  375.     set level $var(level)
  376.     incr level -1
  377.     $win insert $var(S_insert) "$data" \
  378.         "hi [lindex $var(list) end] indent$level $var(font)"
  379.     set data {}
  380. }
  381.  
  382. proc HMtag_li {win param text} {
  383.     upvar #0 HM$win var
  384.     set level $var(level)
  385.     incr level -1
  386.     set x [string index $var(S_symbols)+-+-+-+-" $level]
  387.     catch {set x [incr var(count$level)]}
  388.     catch {set x $var(menu)}
  389.  
  390.     # Let Lists use gif's as symbol indicators.
  391.     # Call the <img> tag if a source is specified, 
  392.     # then fix-up the tags so the indenting ends up OK
  393.  
  394.     if {[HMextract_param $param src]} {
  395.         set item [uplevel [list HMtag_img $win $param $text]]
  396.  
  397.         # if we didn't get the image, and no "alt" is specified, punt back
  398.         # to the default symbol
  399.  
  400.         if {"[$item cget -image]" == ""} {
  401.             HMextract_param $param alt x
  402.             $item configure -text $x
  403.         }
  404.  
  405.         # don't add leading tab if image is too wide
  406.         #scan [$win tag cget indent1 -tabs] "%fc %fc" t1 t2
  407.         #set tpix [winfo fpixels . [expr $t2 - $t1]c]
  408.         #if {int($tpix) > [winfo reqwidth $item]} {
  409.         #    $win insert $item \t "mark [lindex $var(list) end] indent$level $var(font)"
  410.         #}
  411.  
  412.         $win insert $item \t "mark [lindex $var(list) end] indent$level $var(font)"
  413.         $win insert $var(S_insert) \t "mark [lindex $var(list) end] indent$level $var(font)"
  414.         $win tag remove indent[expr $level + 1] $item
  415.         $win tag add indent$level $item
  416.     } else { 
  417.         $win insert $var(S_insert) \t$x\t "mark [lindex $var(list) end] indent$level $var(font)"
  418.     }
  419. }
  420.  
  421. # Manage hypertext "anchor" links.  A link can be either a source (href)
  422. # a destination (name) or both.  If its a source, register it via a callback,
  423. # and set its default behavior.  If its a destination, check to see if we need
  424. # to go there now, as a result of a previous HMgoto request.  If so, schedule
  425. # it to happen with the closing </a> tag, so we can highlight the text up to
  426. # the </a>.
  427.  
  428. proc HMtag_a {win param text} {
  429.     upvar #0 HM$win var
  430.  
  431.     # a source
  432.  
  433.     if {[HMextract_param $param href]} {
  434.         set var(Tref) [list L:$href]
  435.         HMstack $win "" "Tlink link"
  436.         HMlink_setup $win $href
  437.     }
  438.  
  439.     # a destination
  440.  
  441.     if {[HMextract_param $param name]} {
  442.         set var(Tname) [list N:$name]
  443.         HMstack $win "" "Tanchor anchor"
  444.         $win mark set N:$name "$var(S_insert) - 1 chars"
  445.         $win mark gravity N:$name left
  446.         if {[info exists var(goto)] && $var(goto) == $name} {
  447.             unset var(goto)
  448.             set var(going) $name
  449.         }
  450.     }
  451. }
  452.  
  453. # The application should call here with the fragment name
  454. # to cause the display to go to this spot.
  455. # If the target exists, go there (and do the callback),
  456. # otherwise schedule the goto to happen when we see the reference.
  457.  
  458. proc HMgoto {win where {callback HMwent_to}} {
  459.     upvar #0 HM$win var
  460.     if {[regexp N:$where [$win mark names]]} {
  461.         $win see N:$where
  462.         update
  463.         eval $callback $win [list $where]
  464.         return 1
  465.     } else {
  466.         set var(goto) $where
  467.         return 0
  468.     }
  469. }
  470.  
  471. # We actually got to the spot, so highlight it!
  472. # This should/could be replaced by the application
  473. # We'll flash it orange a couple of times.
  474.  
  475. proc HMwent_to {win where {count 0} {color orange}} {
  476.     upvar #0 HM$win var
  477.     if {$count > 5} return
  478.     catch {$win tag configure N:$where -foreground $color}
  479.     update
  480.     after 200 [list HMwent_to $win $where [incr count] \
  481.                 [expr {$color=="orange" ? "" : "orange"}]]
  482. }
  483.  
  484. proc HMtag_/a {win param text} {
  485.     upvar #0 HM$win var
  486.     if {[info exists var(Tref)]} {
  487.         unset var(Tref)
  488.         HMstack $win / "Tlink link"
  489.     }
  490.  
  491.     # goto this link, then invoke the call-back.
  492.  
  493.     if {[info exists var(going)]} {
  494.         $win yview N:$var(going)
  495.         update
  496.         HMwent_to $win $var(going)
  497.         unset var(going)
  498.     }
  499.  
  500.     if {[info exists var(Tname)]} {
  501.         unset var(Tname)
  502.         HMstack $win / "Tanchor anchor"
  503.     }
  504. }
  505.  
  506. #           Inline Images
  507. # This interface is subject to change
  508. # Most of the work is getting around a limitation of TK that prevents
  509. # setting the size of a label to a widthxheight in pixels
  510. #
  511. # Images have the following parameters:
  512. #    align:  top,middle,bottom
  513. #    alt:    alternate text
  514. #    src:    The URL link
  515. #    border: The size of the window border
  516.  
  517. proc HMtag_img {win param text} {
  518.     upvar #0 HM$win var
  519.  
  520.     # get alignment
  521.     array set align_map {top top  middle center  bottom bottom baseline baseline}
  522.     set align bottom        ;# The spec isn't clear what the default should be
  523.     HMextract_param $param align
  524.     catch {set align $align_map([string tolower $align])}
  525.  
  526.     # get alternate text
  527.     set alt "<image>"
  528.     HMextract_param $param alt
  529.     set alt [HMmap_esc $alt]
  530.  
  531.     # get the border width
  532.     set border 0
  533.     HMextract_param $param border
  534.  
  535.     set item $win.$var(tags)
  536.     catch {destroy $item}
  537.     set label $item
  538.     label $label 
  539.  
  540.     $label configure -relief ridge -fg orange -text $alt -padx 0 -pady 0
  541.     catch {$label configure -bd $border}
  542.     $win window create $var(S_insert) -align $align -window $item
  543.  
  544.     # add in all the current tags (this is overkill)
  545.     set tags [HMcurrent_tags $win]
  546.     foreach tag $tags {
  547.         $win tag add $tag $item
  548.     }
  549.  
  550.     # now callback to the application
  551.     set src ""
  552.     HMextract_param $param src
  553.     HMset_image $win $label $src
  554.     return $item
  555. }
  556.  
  557. # The app needs to supply one of these
  558. proc HMset_image {win handle src} {
  559.     HMgot_image $handle "can't get\n$src"
  560. }
  561.  
  562. # When the image is available, the application should call back here.
  563. # If we have the image, put it in the label, otherwise display the error
  564. # message.  If we don't get a callback, the "alt" text remains.
  565. # if we have a clickable image, arrange for a callback
  566.  
  567. proc HMgot_image {win image_error} {
  568.     if {[catch {$win configure -image $image_error}]} {
  569.         $win configure -image {}
  570.         $win configure -text $image_error
  571.     }
  572. }
  573.  
  574. # Sample hypertext link callback routine - should be replaced by app
  575. # This proc is called once for each <A> tag.
  576. # Applications can overwrite this procedure, as required, or
  577. # replace the HMevents array
  578. #   win:   The name of the text widget to render into
  579. #   href:  The HREF link for this <a> tag.
  580.  
  581. array set HMevents {
  582.     Enter    {-borderwidth 2 -relief raised }
  583.     Leave    {-borderwidth 2 -relief flat }
  584.     1        {-borderwidth 2 -relief sunken}
  585.     ButtonRelease-1    {-borderwidth 2 -relief raised}
  586. }
  587.  
  588. # We need to escape any %'s in the href tag name so the bind command
  589. # doesn't try to substitute them.
  590.  
  591. proc HMlink_setup {win href} {
  592.     global HMevents
  593.     regsub -all {%} $href {%%} href2
  594.     foreach i [array names HMevents] {
  595.         eval {$win tag bind  L:$href <$i>} \
  596.             \{$win tag configure \{L:$href2\} $HMevents($i)\}
  597.     }
  598. }
  599.  
  600. # generic link-hit callback
  601. # This gets called upon button hits on hypertext links
  602. # Applications are expected to supply ther own HMlink_callback routine
  603. #   win:   The name of the text widget to render into
  604. #   x,y:   The cursor position at the "click"
  605.  
  606. proc HMlink_hit {win x y} {
  607.     set tags [$win tag names @$x,$y]
  608.     set link [lindex $tags [lsearch -glob $tags L:*]]
  609.     # regsub -all {[^L]*L:([^ ]*).*}  $tags {\1} link
  610.     regsub L: $link {} link
  611.     HMlink_callback $win $link
  612. }
  613.  
  614. # replace this!
  615. #   win:   The name of the text widget to render into
  616. #   href:  The HREF link for this <a> tag.
  617.  
  618. proc HMlink_callback {win href} {
  619.     puts "Got hit on $win, link $href"
  620. }
  621.  
  622. # extract a value from parameter list (this needs a re-do)
  623. # returns "1" if the keyword is found, "0" otherwise
  624. #   param:  A parameter list.  It should alredy have been processed to
  625. #           remove any entity references
  626. #   key:    The parameter name
  627. #   val:    The variable to put the value into (use key as default)
  628.  
  629. proc HMextract_param {param key {val ""}} {
  630.  
  631.     if {$val == ""} {
  632.         upvar $key result
  633.     } else {
  634.         upvar $val result
  635.     }
  636.     set ws "    \n\r"
  637.  
  638.     # look for name=value combinations.  Either (') or (") are valid delimeters
  639.     if {
  640.       [regsub -nocase [format {.*%s[%s]*=[%s]*"([^"]*).*} $key $ws $ws] $param {\1} value] ||
  641.       [regsub -nocase [format {.*%s[%s]*=[%s]*'([^']*).*} $key $ws $ws] $param {\1} value] ||
  642.       [regsub -nocase [format {.*%s[%s]*=[%s]*([^%s]+).*} $key $ws $ws $ws] $param {\1} value] } {
  643.         set result $value
  644.         return 1
  645.     }
  646.  
  647.     # now look for valueless names
  648.     # I should strip out name=value pairs, so we don't end up with "name"
  649.     # inside the "value" part of some other key word - some day
  650.     
  651.     set bad \[^a-zA-Z\]+
  652.     if {[regexp -nocase  "$bad$key$bad" -$param-]} {
  653.         return 1
  654.     } else {
  655.         return 0
  656.     }
  657. }
  658.  
  659. # These next two routines manage the display state of the page.
  660.  
  661. # Push or pop tags to/from stack.
  662. # Each orthogonal text property has its own stack, stored as a list.
  663. # The current (most recent) tag is the last item on the list.
  664. # Push is {} for pushing and {/} for popping
  665.  
  666. proc HMstack {win push list} {
  667.     upvar #0 HM$win var
  668.     array set tags $list
  669.     if {$push == ""} {
  670.         foreach tag [array names tags] {
  671.             lappend var($tag) $tags($tag)
  672.         }
  673.     } else {
  674.         foreach tag [array names tags] {
  675.             # set cnt [regsub { *[^ ]+$} $var($tag) {} var($tag)]
  676.             set var($tag) [lreplace $var($tag) end end]
  677.         }
  678.     }
  679. }
  680.  
  681. # extract set of current text tags
  682. # tags starting with T map directly to text tags, all others are
  683. # handled specially.  There is an application callback, HMset_font
  684. # to allow the application to do font error handling
  685.  
  686. proc HMcurrent_tags {win} {
  687.     upvar #0 HM$win var
  688.     set font font
  689.     foreach i {family size weight style} {
  690.         set $i [lindex $var($i) end]
  691.         append font :[set $i]
  692.     }
  693.     set xfont [HMx_font $family $size $weight $style $var(S_adjust_size)]
  694.     HMset_font $win $font $xfont
  695.     set indent [llength $var(indent)]
  696.     incr indent -1
  697.     lappend tags $font indent$indent
  698.     foreach tag [array names var T*] {
  699.         lappend tags [lindex $var($tag) end]    ;# test
  700.     }
  701.     set var(font) $font
  702.     set var(xfont) [$win tag cget $font -font]
  703.     set var(level) $indent
  704.     return $tags
  705. }
  706.  
  707. # allow the application to do do better font management
  708. # by overriding this procedure
  709.  
  710. proc HMset_font {win tag font} {
  711.     catch {$win tag configure $tag -font $font} msg
  712. }
  713.  
  714. # generate an X font name
  715. proc HMx_font {family size weight style {adjust_size 0}} {
  716.     catch {incr size $adjust_size}
  717.     return "-*-$family-$weight-$style-normal-*-*-${size}0-*-*-*-*-*-*"
  718. }
  719.  
  720. ############################################
  721. # Turn HTML into TCL commands
  722. #   html    A string containing an html document
  723. #   cmd        A command to run for each html tag found
  724. #   start    The name of the dummy html start/stop tags
  725.  
  726. proc HMparse_html {html {cmd HMtest_parse} {start hmstart}} {
  727.     regsub -all \{ $html {\&ob;} html
  728.     regsub -all \} $html {\&cb;} html
  729.     regsub -all {\\} $html {\&bsl;} html
  730.     set w " \t\r\n\f"    ;# white space
  731.     proc HMcl x {return "\[$x\]"}
  732.     set exp <(/?)([HMcl ^$w>]+)[HMcl $w]*([HMcl ^>]*)>
  733.     set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
  734.     regsub -all $exp $html $sub html
  735.     eval "$cmd {$start} {} {} \{ $html \}"
  736.     eval "$cmd {$start} / {} {}"
  737. }
  738.  
  739. proc HMtest_parse {command tag slash text_after_tag} {
  740.     puts "==> $command $tag $slash $text_after_tag"
  741. }
  742.  
  743. # Convert multiple white space into a single space
  744.  
  745. proc HMzap_white {data} {
  746.     regsub -all "\[ \t\r\f\n\]+" $data " " data
  747.     return $data
  748. }
  749.  
  750. # find HTML escape characters of the form &xxx;
  751.  
  752. proc HMmap_esc {text} {
  753.     if {![regexp & $text]} {return $text}
  754.     regsub -all {([][$\\])} $text {\\\1} new
  755.     regsub -all {&#([0-9][0-9]?[0-9]?);?} \
  756.         $new {[format %c [scan \1 %d tmp;set tmp]]} new
  757.     regsub -all {&([a-zA-Z]+);?} $new {[HMdo_map \1]} new
  758.     return [subst $new]
  759. }
  760.  
  761. # convert an HTML escape sequence into character
  762.  
  763. proc HMdo_map {text {unknown ?}} {
  764.     global HMesc_map
  765.     set result $unknown
  766.     catch {set result $HMesc_map($text)}
  767.     return $result
  768. }
  769.  
  770. # table of escape characters (ISO latin-1 esc's are in a different table)
  771.  
  772. array set HMesc_map {
  773.    lt <   gt >   amp &   quot \"   copy \xa9
  774.    reg \xae   ob \x7b   cb \x7d   nbsp \xa0   bsl \\
  775. }
  776. #############################################################
  777. # ISO Latin-1 escape codes
  778.  
  779. array set HMesc_map {
  780.     nbsp \xa0 iexcl \xa1 cent \xa2 pound \xa3 curren \xa4
  781.     yen \xa5 brvbar \xa6 sect \xa7 uml \xa8 copy \xa9
  782.     ordf \xaa laquo \xab not \xac shy \xad reg \xae
  783.     hibar \xaf deg \xb0 plusmn \xb1 sup2 \xb2 sup3 \xb3
  784.     acute \xb4 micro \xb5 para \xb6 middot \xb7 cedil \xb8
  785.     sup1 \xb9 ordm \xba raquo \xbb frac14 \xbc frac12 \xbd
  786.     frac34 \xbe iquest \xbf Agrave \xc0 Aacute \xc1 Acirc \xc2
  787.     Atilde \xc3 Auml \xc4 Aring \xc5 AElig \xc6 Ccedil \xc7
  788.     Egrave \xc8 Eacute \xc9 Ecirc \xca Euml \xcb Igrave \xcc
  789.     Iacute \xcd Icirc \xce Iuml \xcf ETH \xd0 Ntilde \xd1
  790.     Ograve \xd2 Oacute \xd3 Ocirc \xd4 Otilde \xd5 Ouml \xd6
  791.     times \xd7 Oslash \xd8 Ugrave \xd9 Uacute \xda Ucirc \xdb
  792.     Uuml \xdc Yacute \xdd THORN \xde szlig \xdf agrave \xe0
  793.     aacute \xe1 acirc \xe2 atilde \xe3 auml \xe4 aring \xe5
  794.     aelig \xe6 ccedil \xe7 egrave \xe8 eacute \xe9 ecirc \xea
  795.     euml \xeb igrave \xec iacute \xed icirc \xee iuml \xef
  796.     eth \xf0 ntilde \xf1 ograve \xf2 oacute \xf3 ocirc \xf4
  797.     otilde \xf5 ouml \xf6 divide \xf7 oslash \xf8 ugrave \xf9
  798.     uacute \xfa ucirc \xfb uuml \xfc yacute \xfd thorn \xfe
  799.     yuml \xff
  800. }
  801.