home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / htmlib / html_library.tcl next >
Encoding:
Text File  |  2000-11-02  |  41.6 KB  |  1,440 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. # See the file "license.terms" for information on usage and redistribution
  6. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  7. #
  8. # To use this package,  create a text widget (say, .text)
  9. # and set a variable full of html, (say $html), and issue:
  10. #    HMinit_win .text
  11. #    HMparse_html $html "HMrender .text"
  12. # You also need to supply the routine:
  13. #   proc HMlink_callback {win href} { ...}
  14. #      win:  The name of the text widget
  15. #      href  The name of the link
  16. # which will be called anytime the user "clicks" on a link.
  17. # The supplied version just prints the link to stdout.
  18. # In addition, if you wish to use embedded images, you will need to write
  19. #   proc HMset_image {handle src}
  20. #      handle  an arbitrary handle (not really)
  21. #      src     The name of the image
  22. # Which calls
  23. #    HMgot_image $handle $image
  24. # with the TK image.
  25. #
  26. # To return a "used" text widget to its initialized state, call:
  27. #   HMreset_win .text
  28. # See "sample.tcl" for sample usage
  29. ##################################################################
  30. ############################################
  31. # mapping of html tags to text tag properties
  32. # properties beginning with "T" map directly to text tags
  33.  
  34. # These are Defined in HTML 2.0
  35.  
  36. array set HMtag_map {
  37.     b      {weight bold}
  38.     blockquote    {style i indent 1 Trindent rindent}
  39.     bq        {style i indent 1 Trindent rindent}
  40.     cite   {style i}
  41.     code   {family courier}
  42.     dfn    {style i}    
  43.     dir    {indent 1}
  44.     dl     {indent 1}
  45.     em     {style i}
  46.     h1     {size 24 weight bold}
  47.     h2     {size 22}        
  48.     h3     {size 20}    
  49.     h4     {size 18}
  50.     h5     {size 16}
  51.     h6     {style i}
  52.     i      {style i}
  53.     kbd    {family courier weight bold}
  54.     menu     {indent 1}
  55.     ol     {indent 1}
  56.     pre    {fill 0 family courier Tnowrap nowrap}
  57.     samp   {family courier}        
  58.     strong {weight bold}        
  59.     tt     {family courier}
  60.     u     {Tunderline underline}
  61.     ul     {indent 1}
  62.     var    {style i}    
  63. }
  64.  
  65. # These are in common(?) use, but not defined in html2.0
  66.  
  67. array set HMtag_map {
  68.     center {Tcenter center}
  69.     strike {Tstrike strike}
  70.     u       {Tunderline underline}
  71. }
  72.  
  73. # initial values
  74.  
  75. set HMtag_map(hmstart) {
  76.     family times   weight medium   style r   size 14
  77.     Tcenter ""   Tlink ""   Tnowrap ""   Tunderline ""   list list
  78.     fill 1   indent "" counter 0 adjust 0
  79. }
  80.  
  81. # html tags that insert white space
  82.  
  83. array set HMinsert_map {
  84.     blockquote "\n\n" /blockquote "\n"
  85.     br    "\n"
  86.     br/    "\n"
  87.     dd    "\n" /dd    "\n"
  88.     dl    "\n" /dl    "\n"
  89.     dt    "\n"
  90.     form "\n"    /form "\n"
  91.     h1    "\n\n"    /h1    "\n"
  92.     h2    "\n\n"    /h2    "\n"
  93.     h3    "\n\n"    /h3    "\n"
  94.     h4    "\n"    /h4    "\n"
  95.     h5    "\n"    /h5    "\n"
  96.     h6    "\n"    /h6    "\n"
  97.     li   "\n"
  98.     /dir "\n"
  99.     /ul "\n"
  100.     /ol "\n"
  101.     /menu "\n"
  102.     p    "\n\n"
  103.     pre "\n"    /pre "\n"
  104. }
  105.  
  106. # tags that are list elements, that support "compact" rendering
  107.  
  108. array set HMlist_elements {
  109.     ol 1   ul 1   menu 1   dl 1   dir 1
  110. }
  111. ############################################
  112. # initialize the window and stack state
  113.  
  114. proc HMinit_win {win} {
  115.     upvar #0 HM$win var
  116.     #dani:
  117.     
  118.     $win configure -cursor left_ptr
  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 black        ;# 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    -underline 1;# 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 [winfo width $win]
  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 [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 >
  211.         S_insert Insert
  212.     }
  213.     # S_symbols O*=+-o\xd7\xb0>:\xb7
  214.     array set var [array get tmp]
  215. }
  216.  
  217. # alter the parameters of the text state
  218. # this allows an application to over-ride the default settings
  219. # it is called as: HMset_state -param value -param value ...
  220.  
  221. array set HMparam_map {
  222.     -update S_update
  223.     -tab S_tab
  224.     -unknown S_unknown
  225.     -stop S_stop
  226.     -size S_adjust_size
  227.     -symbols S_symbols
  228.     -insert S_insert
  229. }
  230.  
  231. proc HMset_state {win args} {
  232.     upvar #0 HM$win var
  233.     global HMparam_map
  234.     set bad 0
  235.     if {[catch {array set params $args}]} {return 0}
  236.     foreach i [array names params] {
  237.         incr bad [catch {set var($HMparam_map($i)) $params($i)}]
  238.     }
  239.     return [expr $bad == 0]
  240. }
  241.  
  242. ############################################
  243. # manage the display of html
  244.  
  245. # HMrender gets called for every html tag
  246. #   win:   The name of the text widget to render into
  247. #   tag:   The html tag (in arbitrary case)
  248. #   not:   a "/" or the empty string
  249. #   param: The un-interpreted parameter list
  250. #   text:  The plain text until the next html tag
  251.  
  252. proc HMrender {win tag not param text} {
  253.     upvar #0 HM$win var
  254.     if {$var(stop)} return
  255.     global HMtag_map HMinsert_map HMlist_elements
  256.     set tag [string tolower $tag]
  257.     set text [HMmap_esc $text]
  258.  
  259.     # manage compact rendering of lists
  260.     if {[info exists HMlist_elements($tag)]} {
  261.         set list "list [expr {[HMextract_param $param compact] ? "compact" : "list"}]"
  262.     } else {
  263.         set list ""
  264.     }
  265.  
  266.     # Allow text to be diverted to a different window (for tables)
  267.     # this is not currently used
  268.     if {[info exists var(divert)]} {
  269.         set win $var(divert)
  270.         upvar #0 HM$win var
  271.     }
  272.  
  273.     # adjust (push or pop) tag state
  274.     catch {HMstack $win $not "$HMtag_map($tag) $list"}
  275.  
  276.     # insert white space (with current font)
  277.     # adding white space can get a bit tricky.  This isn't quite right
  278.     set bad [catch {$win insert $var(S_insert) $HMinsert_map($not$tag) "space $var(font)"}]
  279.     catch {
  280.         if {!$bad && [lindex $var(fill) end]} {
  281.         set text [string trimleft $text]
  282.     }
  283.     }
  284.  
  285.     # to fill or not to fill
  286.     catch {
  287.         if {[lindex $var(fill) end]} {
  288.         set text [HMzap_white $text]
  289.     }   } kk
  290.  
  291.     # generic mark hook
  292.     catch {HMmark $not$tag $win $param text} err
  293.  
  294.     # do any special tag processing
  295.     catch {HMtag_$not$tag $win $param text} msg
  296.  
  297.  
  298.     # add the text with proper tags
  299.  
  300.     set tags [HMcurrent_tags $win]
  301.     $win insert $var(S_insert) $text $tags
  302.  
  303.     # We need to do an update every so often to insure interactive response.
  304.     # This can cause us to re-enter the event loop, and cause recursive
  305.     # invocations of HMrender, so we need to be careful.
  306.     if {!([incr var(tags)] % $var(S_update))} {
  307.         update
  308.     }
  309. }
  310.  
  311. # html tags requiring special processing
  312. # Procs of the form HMtag_<tag> or HMtag_</tag> get called just before
  313. # the text for this tag is displayed.  These procs are called inside a 
  314. # "catch" so it is OK to fail.
  315. #   win:   The name of the text widget to render into
  316. #   param: The un-interpreted parameter list
  317. #   text:  A pass-by-reference name of the plain text until the next html tag
  318. #          Tag commands may change this to affect what text will be inserted
  319. #          next.
  320.  
  321. # A pair of pseudo tags are added automatically as the 1st and last html
  322. # tags in the document.  The default is <HMstart> and </HMstart>.
  323. # Append enough blank space at the end of the text widget while
  324. # rendering so HMgoto can place the target near the top of the page,
  325. # then remove the extra space when done rendering.
  326.  
  327. proc HMtag_hmstart {win param text} {
  328.     upvar #0 HM$win var
  329.     $win mark gravity $var(S_insert) left
  330.     $win insert end "\n " last
  331.     $win mark gravity $var(S_insert) right
  332. }
  333.  
  334. proc HMtag_/hmstart {win param text} {
  335.     $win delete last.first end
  336. }
  337.  
  338.  
  339.  
  340. # put the document title in the window banner, and remove the title text
  341. # from the document
  342.  
  343. proc HMtag_title {win param text} {
  344.     upvar $text data
  345.     wm title [winfo toplevel $win] $data
  346.     set data ""
  347. }
  348.  
  349. proc HMtag_hr {win param text} {
  350.     upvar #0 HM$win var
  351.     $win insert $var(S_insert) "\n" space "\n" thin "\t" "thin hr" "\n" thin
  352. }
  353.  
  354. # list element tags
  355.  
  356. proc HMtag_ol {win param text} {
  357.     upvar #0 HM$win var
  358.     set var(count$var(level)) 0
  359. }
  360.  
  361. proc HMtag_ul {win param text} {
  362.     upvar #0 HM$win var
  363.     catch {unset var(count$var(level))}
  364. }
  365.  
  366. proc HMtag_menu {win param text} {
  367.     upvar #0 HM$win var
  368.     set var(menu) ->
  369.     set var(compact) 1
  370. }
  371.  
  372. proc HMtag_/menu {win param text} {
  373.     upvar #0 HM$win var
  374.     catch {unset var(menu)}
  375.     catch {unset var(compact)}
  376. }
  377.     
  378. proc HMtag_dt {win param text} {
  379.     upvar #0 HM$win var
  380.     upvar $text data
  381.     set level $var(level)
  382.     incr level -1
  383.     $win insert $var(S_insert) "$data" \
  384.         "hi [lindex $var(list) end] indent$level $var(font)"
  385.     set data {}
  386. }
  387.  
  388. proc HMtag_li {win param text} {
  389.     upvar #0 HM$win var
  390.     set level $var(level)
  391.     incr level -1
  392.     set x [string index $var(S_symbols)+-+-+-+-" $level]
  393.     catch {set x [incr var(count$level)]}
  394.     catch {set x $var(menu)}
  395.     $win insert $var(S_insert) \t$x\t "mark [lindex $var(list) end] indent$level $var(font)"
  396. }
  397.  
  398. # Manage hypertext "anchor" links.  A link can be either a source (href)
  399. # a destination (name) or both.  If its a source, register it via a callback,
  400. # and set its default behavior.  If its a destination, check to see if we need
  401. # to go there now, as a result of a previous HMgoto request.  If so, schedule
  402. # it to happen with the closing </a> tag, so we can highlight the text up to
  403. # the </a>.
  404.  
  405. proc HMtag_a {win param text} {
  406.     upvar #0 HM$win var
  407.  
  408.     # a source
  409.  
  410.     if {[HMextract_param $param href]} {
  411.         set var(Tref) [list L:$href]
  412.         HMstack $win "" "Tlink link"
  413.         HMlink_setup $win $href
  414.     }
  415.  
  416.     # a destination
  417.  
  418.     if {[HMextract_param $param name]} {
  419.         set var(Tname) [list N:$name]
  420.         HMstack $win "" "Tanchor anchor"
  421.         $win mark set N:$name "$var(S_insert) - 1 chars"
  422.         $win mark gravity N:$name left
  423.         if {[info exists var(goto)] && $var(goto) == $name} {
  424.             unset var(goto)
  425.             set var(going) $name
  426.         }
  427.     }
  428. }
  429.  
  430. # The application should call here with the fragment name
  431. # to cause the display to go to this spot.
  432. # If the target exists, go there (and do the callback),
  433. # otherwise schedule the goto to happen when we see the reference.
  434.  
  435. proc HMgoto {win where {callback HMwent_to}} {
  436.     upvar #0 HM$win var
  437.     if {[regexp N:$where [$win mark names]]} {
  438.         $win see N:$where
  439.         update
  440.         eval $callback $win [list $where]
  441.         return 1
  442.     } else {
  443.         set var(goto) $where
  444.         return 0
  445.     }
  446. }
  447.  
  448. # We actually got to the spot, so highlight it!
  449. # This should/could be replaced by the application
  450. # We'll flash it orange a couple of times.
  451.  
  452. proc HMwent_to {win where {count 0} {color orange}} {
  453.     upvar #0 HM$win var
  454.     if {$count > 5} return
  455.     catch {$win tag configure N:$where -foreground $color}
  456.     update
  457.     after 200 [list HMwent_to $win $where [incr count] \
  458.                 [expr {$color=="orange" ? "" : "orange"}]]
  459. }
  460.  
  461. proc HMtag_/a {win param text} {
  462.     upvar #0 HM$win var
  463.     if {[info exists var(Tref)]} {
  464.         unset var(Tref)
  465.         HMstack $win / "Tlink link"
  466.     }
  467.  
  468.     # goto this link, then invoke the call-back.
  469.  
  470.     if {[info exists var(going)]} {
  471.         $win yview N:$var(going)
  472.         update
  473.         HMwent_to $win $var(going)
  474.         unset var(going)
  475.     }
  476.  
  477.     if {[info exists var(Tname)]} {
  478.         unset var(Tname)
  479.         HMstack $win / "Tanchor anchor"
  480.     }
  481. }
  482.  
  483. #           Inline Images
  484. # This interface is subject to change
  485. # Most of the work is getting around a limitation of TK that prevents
  486. # setting the size of a label to a widthxheight in pixels
  487. #
  488. # Images have the following parameters:
  489. #    align:  top,middle,bottom
  490. #    alt:    alternate text
  491. #    ismap:  A clickable image map
  492. #    src:    The URL link
  493. # Netscape supports (and so do we)
  494. #    width:  A width hint (in pixels)
  495. #    height:  A height hint (in pixels)
  496. #    border: The size of the window border
  497.  
  498. proc HMtag_img {win param text} {
  499.     upvar #0 HM$win var
  500.  
  501.     # get alignment
  502.     array set align_map {top top    middle center    bottom bottom}
  503.     set align bottom        ;# The spec isn't clear what the default should be
  504.     HMextract_param $param align
  505.     catch {set align $align_map([string tolower $align])}
  506.  
  507.     # get alternate text
  508.     set alt "<image>"
  509.     HMextract_param $param alt
  510.     set alt [HMmap_esc $alt]
  511.  
  512.     # get the border width
  513.     set border 1
  514.     HMextract_param $param border
  515.  
  516.     # see if we have an image size hint
  517.     # If so, make a frame the "hint" size to put the label in
  518.     # otherwise just make the label
  519.     set item $win.$var(tags)
  520.     # catch {destroy $item}
  521.     if {[HMextract_param $param width] && [HMextract_param $param height]} {
  522.         frame $item -width $width -height $height
  523.         pack propagate $item 0
  524.         set label $item.label
  525.         label $label
  526.         pack $label -expand 1 -fill both
  527.     } else {
  528.         set label $item
  529.         label $label 
  530.     }
  531.  
  532.     $label configure -fg black -bd 0  -text $alt
  533.     # -relief ridge -fg orange -text $alt
  534.     # catch {$label configure -bd $border}
  535.     $win window create $var(S_insert) -align $align -window $item -pady 2 -padx 2
  536.  
  537.     # add in all the current tags (this is overkill)
  538.     set tags [HMcurrent_tags $win]
  539.     foreach tag $tags {
  540.         $win tag add $tag $item
  541.     }
  542.  
  543.     # set imagemap callbacks
  544.     if {[HMextract_param $param ismap]} {
  545.         # regsub -all {[^L]*L:([^ ]*).*}  $tags {\1} link
  546.         set link [lindex $tags [lsearch -glob $tags L:*]]
  547.         regsub L: $link {} link
  548.         global HMevents
  549.         regsub -all {%} $link {%%} link2
  550.         foreach i [array names HMevents] {
  551.             bind $label <$i> "catch \{%W configure $HMevents($i)\}"
  552.         }
  553.         bind $label <1> "+HMlink_callback $win $link2?%x,%y"
  554.     } 
  555.  
  556.     # now callback to the application
  557.     set src ""
  558.     HMextract_param $param src
  559.     HMset_image $win $label $src
  560.     return $label    ;# used by the forms package for input_image types
  561. }
  562.  
  563. # The app needs to supply one of these
  564. proc HMset_image {win handle src} {
  565.     HMgot_image $handle "can't get\n$src"
  566. }
  567.  
  568. # When the image is available, the application should call back here.
  569. # If we have the image, put it in the label, otherwise display the error
  570. # message.  If we don't get a callback, the "alt" text remains.
  571. # if we have a clickable image, arrange for a callback
  572.  
  573. proc HMgot_image {win image_error} {
  574.     # if we're in a frame turn on geometry propogation
  575.     if {[winfo name $win] == "label"} {
  576.         pack propagate [winfo parent $win] 1
  577.     }
  578.     if {[catch {$win configure -bg white -image $image_error}]} {
  579.         $win configure -image {}
  580.         $win configure -text $image_error
  581.     }
  582. }
  583.  
  584. # Sample hypertext link callback routine - should be replaced by app
  585. # This proc is called once for each <A> tag.
  586. # Applications can overwrite this procedure, as required, or
  587. # replace the HMevents array
  588. #   win:   The name of the text widget to render into
  589. #   href:  The HREF link for this <a> tag.
  590.  
  591. #    Enter    {-borderwidth 2 -relief raised }
  592. #    Leave    {-borderwidth 2 -relief flat }
  593.  
  594. array set HMevents {
  595.     Enter    {-borderwidth 2 }
  596.     Leave    {-borderwidth 0 }
  597.     1        {-borderwidth 2 }
  598.     ButtonRelease-1    {-borderwidth 0 }
  599. }
  600.  
  601. # We need to escape any %'s in the href tag name so the bind command
  602. # doesn't try to substitute them.
  603.  
  604. proc HMlink_setup {win href} {
  605.     global HMevents
  606.     regsub -all {%} $href {%%} href2
  607.     foreach i [array names HMevents] {
  608.         eval {$win tag bind  L:$href <$i>} \
  609.             \{$win tag configure \{L:$href2\} $HMevents($i)\}
  610.     }
  611.     
  612.     # dani: 
  613.     
  614.     eval {$win tag bind  L:$href <Enter>} \
  615.         \{$win  configure -cursor hand2\}
  616.         
  617.     eval {$win tag bind  L:$href <Leave>} \
  618.         \{$win  configure -cursor left_ptr\}
  619. }
  620.  
  621. # generic link-hit callback
  622. # This gets called upon button hits on hypertext links
  623. # Applications are expected to supply ther own HMlink_callback routine
  624. #   win:   The name of the text widget to render into
  625. #   x,y:   The cursor position at the "click"
  626.  
  627. proc HMlink_hit {win x y} {
  628.     set tags [$win tag names @$x,$y]
  629.     set link [lindex $tags [lsearch -glob $tags L:*]]
  630.     # regsub -all {[^L]*L:([^ ]*).*}  $tags {\1} link
  631.     regsub L: $link {} link
  632.     HMlink_callback $win $link
  633. }
  634.  
  635. # replace this!
  636. #   win:   The name of the text widget to render into
  637. #   href:  The HREF link for this <a> tag.
  638.  
  639. proc HMlink_callback {win href} {
  640.     puts "Got hit on $win, link $href"
  641. }
  642.  
  643. # extract a value from parameter list (this needs a re-do)
  644. # returns "1" if the keyword is found, "0" otherwise
  645. #   param:  A parameter list.  It should alredy have been processed to
  646. #           remove any entity references
  647. #   key:    The parameter name
  648. #   val:    The variable to put the value into (use key as default)
  649.  
  650. proc HMextract_param {param key {val ""}} {
  651.  
  652.     if {$val == ""} {
  653.         upvar $key result
  654.     } else {
  655.         upvar $val result
  656.     }
  657.     set ws "    \n\r"
  658.  
  659.     # look for name=value combinations.  Either (') or (") are valid delimeters
  660.     if {
  661.       [regsub -nocase [format {.*%s[%s]*=[%s]*"([^"]*).*} $key $ws $ws] $param {\1} value] ||
  662.       [regsub -nocase [format {.*%s[%s]*=[%s]*'([^']*).*} $key $ws $ws] $param {\1} value] ||
  663.       [regsub -nocase [format {.*%s[%s]*=[%s]*([^%s]+).*} $key $ws $ws $ws] $param {\1} value] } {
  664.         set result $value
  665.         return 1
  666.     }
  667.  
  668.     # now look for valueless names
  669.     # I should strip out name=value pairs, so we don't end up with "name"
  670.     # inside the "value" part of some other key word - some day
  671.     
  672.     set bad \[^a-zA-Z\]+
  673.     if {[regexp -nocase  "$bad$key$bad" -$param-]} {
  674.         return 1
  675.     } else {
  676.         return 0
  677.     }
  678. }
  679.  
  680. # These next two routines manage the display state of the page.
  681.  
  682. # Push or pop tags to/from stack.
  683. # Each orthogonal text property has its own stack, stored as a list.
  684. # The current (most recent) tag is the last item on the list.
  685. # Push is {} for pushing and {/} for popping
  686.  
  687. proc HMstack {win push list} {
  688.     upvar #0 HM$win var
  689.     array set tags $list
  690.     if {$push == ""} {
  691.         foreach tag [array names tags] {
  692.             lappend var($tag) $tags($tag)
  693.         }
  694.     } else {
  695.         foreach tag [array names tags] {
  696.             # set cnt [regsub { *[^ ]+$} $var($tag) {} var($tag)]
  697.             set var($tag) [lreplace $var($tag) end end]
  698.         }
  699.     }
  700. }
  701.  
  702. # extract set of current text tags
  703. # tags starting with T map directly to text tags, all others are
  704. # handled specially.  There is an application callback, HMset_font
  705. # to allow the application to do font error handling
  706.  
  707. proc HMcurrent_tags {win} {
  708.     upvar #0 HM$win var
  709.     set font font
  710.     foreach i {family size weight style} {
  711.         set $i [lindex $var($i) end]
  712.         append font :[set $i]
  713.     }
  714.     set xfont [HMx_font $family $size $weight $style $var(S_adjust_size)]
  715.     HMset_font $win $font $xfont
  716.     set indent [llength $var(indent)]
  717.     incr indent -1
  718.     lappend tags $font indent$indent
  719.     foreach tag [array names var T*] {
  720.         lappend tags [lindex $var($tag) end]    ;# test
  721.     }
  722.     set var(font) $font
  723.     set var(xfont) [$win tag cget $font -font]
  724.     set var(level) $indent
  725.     return $tags
  726. }
  727.  
  728. # allow the application to do do better font management
  729. # by overriding this procedure
  730.  
  731. proc HMset_font {win tag font} {
  732.     catch {$win tag configure $tag -font $font} msg
  733. }
  734.  
  735. # generate an X font name
  736. proc HMx_font {family size weight style {adjust_size 0}} {
  737.     catch {incr size $adjust_size}
  738.     return "-*-$family-$weight-$style-normal-*-*-${size}0-*-*-*-*-*-*"
  739. }
  740.  
  741. # Optimize HMrender (hee hee)
  742. # This is experimental
  743.  
  744. proc HMoptimize {} {
  745.     regsub -all "\n\[     \]*#\[^\n\]*" [info body HMrender] {} body
  746.     regsub -all ";\[     \]*#\[^\n]*" $body {} body
  747.     regsub -all "\n\n+" $body \n body
  748.     proc HMrender {win tag not param text} $body
  749. }
  750. ############################################
  751. # Turn HTML into TCL commands
  752. #   html    A string containing an html document
  753. #   cmd        A command to run for each html tag found
  754. #   start    The name of the dummy html start/stop tags
  755.  
  756. proc HMparse_html {html {cmd HMtest_parse} {start hmstart}} {
  757.     regsub -all \{ $html {\&ob;} html
  758.     regsub -all \} $html {\&cb;} html
  759.     set w " \t\r\n"    ;# white space
  760.     proc HMcl x {return "\[$x\]"}
  761.     set exp <(/?)([HMcl ^$w>]+)[HMcl $w]*([HMcl ^>]*)>
  762.     set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
  763.     regsub -all $exp $html $sub html
  764.     eval "$cmd {$start} {} {} \{ $html \}"
  765.     eval "$cmd {$start} / {} {}"
  766. }
  767.  
  768. proc HMtest_parse {command tag slash text_after_tag} {
  769.     puts "==> $command $tag $slash $text_after_tag"
  770. }
  771.  
  772. # Convert multiple white space into a single space
  773.  
  774. proc HMzap_white {data} {
  775.     regsub -all "\[ \t\r\n\]+" $data " " data
  776.     return $data
  777. }
  778.  
  779. # find HTML escape characters of the form &xxx;
  780.  
  781. proc HMmap_esc {text} {
  782.     if {![regexp & $text]} {return $text}
  783.     regsub -all {([][$\\])} $text {\\\1} new
  784.     regsub -all {&#([0-9][0-9]?[0-9]?);?} \
  785.         $new {[format %c [scan \1 %d tmp;set tmp]]} new
  786.     regsub -all {&([a-zA-Z]+);?} $new {[HMdo_map \1]} new
  787.     return [subst $new]
  788. }
  789.  
  790. # convert an HTML escape sequence into character
  791.  
  792. proc HMdo_map {text {unknown ?}} {
  793.     global HMesc_map
  794.     set result $unknown
  795.     catch {set result $HMesc_map($text)}
  796.     return $result
  797. }
  798.  
  799. # table of escape characters (ISO latin-1 esc's are in a different table)
  800.  
  801. array set HMesc_map {
  802.    lt <   gt >   amp &   quot \"   copy \xa9
  803.    reg \xae   ob \x7b   cb \x7d   nbsp \xa0
  804. }
  805. #############################################################
  806. # ISO Latin-1 escape codes
  807.  
  808. array set HMesc_map {
  809.     nbsp \xa0 iexcl \xa1 cent \xa2 pound \xa3 curren \xa4
  810.     yen \xa5 brvbar \xa6 sect \xa7 uml \xa8 copy \xa9
  811.     ordf \xaa laquo \xab not \xac shy \xad reg \xae
  812.     hibar \xaf deg \xb0 plusmn \xb1 sup2 \xb2 sup3 \xb3
  813.     acute \xb4 micro \xb5 para \xb6 middot \xb7 cedil \xb8
  814.     sup1 \xb9 ordm \xba raquo \xbb frac14 \xbc frac12 \xbd
  815.     frac34 \xbe iquest \xbf Agrave \xc0 Aacute \xc1 Acirc \xc2
  816.     Atilde \xc3 Auml \xc4 Aring \xc5 AElig \xc6 Ccedil \xc7
  817.     Egrave \xc8 Eacute \xc9 Ecirc \xca Euml \xcb Igrave \xcc
  818.     Iacute \xcd Icirc \xce Iuml \xcf ETH \xd0 Ntilde \xd1
  819.     Ograve \xd2 Oacute \xd3 Ocirc \xd4 Otilde \xd5 Ouml \xd6
  820.     times \xd7 Oslash \xd8 Ugrave \xd9 Uacute \xda Ucirc \xdb
  821.     Uuml \xdc Yacute \xdd THORN \xde szlig \xdf agrave \xe0
  822.     aacute \xe1 acirc \xe2 atilde \xe3 auml \xe4 aring \xe5
  823.     aelig \xe6 ccedil \xe7 egrave \xe8 eacute \xe9 ecirc \xea
  824.     euml \xeb igrave \xec iacute \xed icirc \xee iuml \xef
  825.     eth \xf0 ntilde \xf1 ograve \xf2 oacute \xf3 ocirc \xf4
  826.     otilde \xf5 ouml \xf6 divide \xf7 oslash \xf8 ugrave \xf9
  827.     uacute \xfa ucirc \xfb uuml \xfc yacute \xfd thorn \xfe
  828.     yuml \xff
  829. }
  830.  
  831. ##########################################################
  832. # html forms management commands
  833.  
  834. # As each form element is located, it is created and rendered.  Additional
  835. # state is stored in a form specific global variable to be processed at
  836. # the end of the form, including the "reset" and "submit" options.
  837. # Remember, there can be multiple forms existing on multiple pages.  When
  838. # HTML tables are added, a single form could be spread out over multiple
  839. # text widgets, which makes it impractical to hang the form state off the
  840. # HM$win structure.  We don't need to check for the existance of required
  841. # parameters, we just "fail" and get caught in HMrender
  842.  
  843. # This causes line breaks to be preserved in the inital values
  844. # of text areas
  845. array set HMtag_map {
  846.     textarea    {fill 0}
  847. }
  848.  
  849. ##########################################################
  850. # html isindex tag.  Although not strictly forms, they're close enough
  851. # to be in this file
  852.  
  853. # is-index forms
  854. # make a frame with a label, entry, and submit button
  855.  
  856. proc HMtag_isindex {win param text} {
  857.     upvar #0 HM$win var
  858.  
  859.     set item $win.$var(tags)
  860.     if {[winfo exists $item]} {
  861.         destroy $item
  862.     }
  863.     frame $item -relief ridge -bd 3
  864.     set prompt "Enter search keywords here"
  865.     HMextract_param $param prompt
  866.     label $item.label -text [HMmap_esc $prompt] -font $var(xfont)
  867.     entry $item.entry
  868.     bind $item.entry <Return> "$item.submit invoke"
  869.     button $item.submit -text search -font $var(xfont) -command \
  870.         [format {HMsubmit_index %s {%s} [HMmap_reply [%s get]]} \
  871.         $win $param $item.entry]
  872.     pack $item.label -side top
  873.     pack $item.entry $item.submit -side left
  874.  
  875.     # insert window into text widget
  876.  
  877.     $win insert $var(S_insert) \n isindex
  878.     HMwin_install $win $item
  879.     $win insert $var(S_insert) \n isindex
  880.     bind $item <Visibility> {focus %W.entry}
  881. }
  882.  
  883. # This is called when the isindex form is submitted.
  884. # The default version calls HMlink_callback.  Isindex tags should either
  885. # be deprecated, or fully supported (e.g. they need an href parameter)
  886.  
  887. proc HMsubmit_index {win param text} {
  888.     HMlink_callback $win ?$text
  889. }
  890.  
  891. # initialize form state.  All of the state for this form is kept
  892. # in a global array whose name is stored in the form_id field of
  893. # the main window array.
  894. # Parameters: ACTION, METHOD, ENCTYPE
  895.  
  896. proc HMtag_form {win param text} {
  897.     upvar #0 HM$win var
  898.  
  899.     # create a global array for the form
  900.     set id HM$win.form$var(tags)
  901.     upvar #0 $id form
  902.  
  903.     # missing /form tag, simulate it
  904.     if {[info exists var(form_id)]} {
  905.         puts "Missing end-form tag !!!! $var(form_id)"
  906.         HMtag_/form $win {} {}
  907.     }
  908.     catch {unset form}
  909.     set var(form_id) $id
  910.  
  911.     set form(param) $param        ;# form initial parameter list
  912.     set form(reset) ""            ;# command to reset the form
  913.     set form(reset_button) ""    ;# list of all reset buttons
  914.     set form(submit) ""            ;# command to submit the form
  915.     set form(submit_button) ""    ;# list of all submit buttons
  916. }
  917.  
  918. # Where we're done try to get all of the state into the widgets so
  919. # we can free up the form structure here.  Unfortunately, we can't!
  920.  
  921. proc HMtag_/form {win param text} {
  922.     upvar #0 HM$win var
  923.     upvar #0 $var(form_id) form
  924.  
  925.     # make submit button entries for all radio buttons
  926.     foreach name [array names form radio_*] {
  927.         regsub radio_ $name {} name
  928.         lappend form(submit) [list $name \$form(radio_$name)]
  929.     }
  930.  
  931.     # process the reset button(s)
  932.  
  933.     foreach item $form(reset_button) {
  934.         $item configure -command $form(reset)
  935.     }
  936.  
  937.     # no submit button - add one
  938.     if {$form(submit_button) == ""} {
  939.         HMinput_submit $win {}
  940.     }
  941.  
  942.     # process the "submit" command(s)
  943.     # each submit button could have its own name,value pair
  944.  
  945.     foreach item $form(submit_button) {
  946.         set submit $form(submit)
  947.         catch {lappend submit $form(submit_$item)}
  948.         $item configure -command  \
  949.                 [list HMsubmit_button $win $var(form_id) $form(param) \
  950.                 $submit]
  951.     }
  952.  
  953.     # unset all unused fields here
  954.     unset form(reset) form(submit) form(reset_button) form(submit_button)
  955.     unset var(form_id)
  956. }
  957.  
  958. ###################################################################
  959. # handle form input items
  960. # each item type is handled in a separate procedure
  961. # Each "type" procedure needs to:
  962. # - create the window
  963. # - initialize it
  964. # - add the "submit" and "reset" commands onto the proper Q's
  965. #   "submit" is subst'd
  966. #   "reset" is eval'd
  967.  
  968. proc HMtag_input {win param text} {
  969.     upvar #0 HM$win var
  970.  
  971.     set type text    ;# the default
  972.     HMextract_param $param type
  973.     set type [string tolower $type]
  974.     if {[catch {HMinput_$type $win $param} err]} {
  975.         puts stderr $err
  976.     }
  977. }
  978.  
  979. # input type=text
  980. # parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
  981.  
  982. proc HMinput_text {win param {show {}}} {
  983.     upvar #0 HM$win var
  984.     upvar #0 $var(form_id) form
  985.  
  986.     # make the entry
  987.     HMextract_param $param name        ;# required
  988.     set item $win.input_text,$var(tags)
  989.     set size 20; HMextract_param $param size
  990.     set maxlength 0; HMextract_param $param maxlength
  991.     entry $item -width $size -show $show
  992.  
  993.     # set the initial value
  994.     set value ""; HMextract_param $param value
  995.     $item insert 0 $value
  996.         
  997.     # insert the entry
  998.     HMwin_install $win $item
  999.  
  1000.     # set the "reset" and "submit" commands
  1001.     append form(reset) ";$item delete 0 end;$item insert 0 [list $value]"
  1002.     lappend form(submit) [list $name "\[$item get]"]
  1003.  
  1004.     # handle the maximum length (broken - no way to cleanup bindtags state)
  1005.     if {$maxlength} {
  1006.         bindtags $item "[bindtags $item] max$maxlength"
  1007.         bind max$maxlength <KeyPress> "%W delete $maxlength end"
  1008.     }
  1009. }
  1010.  
  1011. # password fields - same as text, only don't show data
  1012. # parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
  1013.  
  1014. proc HMinput_password {win param} {
  1015.     HMinput_text $win $param *
  1016. }
  1017.  
  1018. # checkbuttons are missing a "get" option, so we must use a global
  1019. # variable to store the value.
  1020. # Parameters NAME, VALUE, (reqd), CHECKED
  1021.  
  1022. proc HMinput_checkbox {win param} {
  1023.     upvar #0 HM$win var
  1024.     upvar #0 $var(form_id) form
  1025.  
  1026.     HMextract_param $param name
  1027.     HMextract_param $param value
  1028.  
  1029.     # Set the global variable, don't use the "form" alias as it is not
  1030.     # defined in the global scope of the button
  1031.     set variable $var(form_id)(check_$var(tags))    
  1032.     set item $win.input_checkbutton,$var(tags)
  1033.     checkbutton $item -variable $variable -off {} -on $value -text "  "
  1034.     if {[HMextract_param $param checked]} {
  1035.         $item select
  1036.         append form(reset) ";$item select"
  1037.     } else {
  1038.         append form(reset) ";$item deselect"
  1039.     }
  1040.  
  1041.     HMwin_install $win $item
  1042.     lappend form(submit) [list $name \$form(check_$var(tags))]
  1043. }
  1044.  
  1045. # radio buttons.  These are like check buttons, but only one can be selected
  1046.  
  1047. proc HMinput_radio {win param} {
  1048.     upvar #0 HM$win var
  1049.     upvar #0 $var(form_id) form
  1050.  
  1051.     HMextract_param $param name
  1052.     HMextract_param $param value
  1053.  
  1054.     set first [expr ![info exists form(radio_$name)]]
  1055.     set variable $var(form_id)(radio_$name)
  1056.     set variable $var(form_id)(radio_$name)
  1057.     set item $win.input_radiobutton,$var(tags)
  1058.     radiobutton $item -variable $variable -value $value -text " "
  1059.  
  1060.     HMwin_install $win $item
  1061.  
  1062.     if {$first || [HMextract_param $param checked]} {
  1063.         $item select
  1064.         append form(reset) ";$item select"
  1065.     } else {
  1066.         append form(reset) ";$item deselect"
  1067.     }
  1068.  
  1069.     # do the "submit" actions in /form so we only end up with 1 per button grouping
  1070.     # contributing to the submission
  1071. }
  1072.  
  1073. # hidden fields, just append to the "submit" data
  1074. # params: NAME, VALUE (reqd)
  1075.  
  1076. proc HMinput_hidden {win param} {
  1077.     upvar #0 HM$win var
  1078.     upvar #0 $var(form_id) form
  1079.     HMextract_param $param name
  1080.     HMextract_param $param value
  1081.     lappend form(submit) [list $name $value]
  1082. }
  1083.  
  1084. # handle input images.  The spec isn't very clear on these, so I'm not
  1085. # sure its quite right
  1086. # Use std image tag, only set up our own callbacks
  1087. #  (e.g. make sure ismap isn't set)
  1088. # params: NAME, SRC (reqd) ALIGN
  1089.  
  1090. proc HMinput_image {win param} {
  1091.     upvar #0 HM$win var
  1092.     upvar #0 $var(form_id) form
  1093.     HMextract_param $param name
  1094.     set name        ;# barf if no name is specified
  1095.     set item [HMtag_img $win $param {}]
  1096.     $item configure -relief raised -bd 2 -bg blue
  1097.  
  1098.     # make a dummy "submit" button, and invoke it to send the form.
  1099.     # We have to get the %x,%y in the value somehow, so calculate it during
  1100.     # binding, and save it in the form array for later processing
  1101.  
  1102.     set submit $win.dummy_submit,$var(tags)
  1103.     if {[winfo exists $submit]} {
  1104.         destroy $submit
  1105.     }
  1106.     button $submit    -takefocus 0;# this never gets mapped!
  1107.     lappend form(submit_button) $submit
  1108.     set form(submit_$submit) [list $name $name.\$form(X).\$form(Y)]
  1109.     
  1110.     $item configure -takefocus 1
  1111.     bind $item <FocusIn> "catch \{$win see $item\}"
  1112.     bind $item <1> "$item configure -relief sunken"
  1113.     bind $item <Return> "
  1114.         set $var(form_id)(X) 0
  1115.         set $var(form_id)(Y) 0
  1116.         $submit invoke    
  1117.     "
  1118.     bind $item <ButtonRelease-1> "
  1119.         set $var(form_id)(X) %x
  1120.         set $var(form_id)(Y) %y
  1121.         $item configure -relief raised
  1122.         $submit invoke    
  1123.     "
  1124. }
  1125.  
  1126. # Set up the reset button.  Wait for the /form to attach
  1127. # the -command option.  There could be more that 1 reset button
  1128. # params VALUE
  1129.  
  1130. proc HMinput_reset {win param} {
  1131.     upvar #0 HM$win var
  1132.     upvar #0 $var(form_id) form
  1133.  
  1134.     set value reset
  1135.     HMextract_param $param value
  1136.  
  1137.     set item $win.input_reset,$var(tags)
  1138.     button $item -text [HMmap_esc $value]
  1139.     HMwin_install $win $item
  1140.     lappend form(reset_button) $item
  1141. }
  1142.  
  1143. # Set up the submit button.  Wait for the /form to attach
  1144. # the -command option.  There could be more that 1 submit button
  1145. # params: NAME, VALUE
  1146.  
  1147. proc HMinput_submit {win param} {
  1148.     upvar #0 HM$win var
  1149.     upvar #0 $var(form_id) form
  1150.  
  1151.     HMextract_param $param name
  1152.     set value submit
  1153.     HMextract_param $param value
  1154.     set item $win.input_submit,$var(tags)
  1155.     button $item -text [HMmap_esc $value] -fg blue
  1156.     HMwin_install $win $item
  1157.     lappend form(submit_button) $item
  1158.     # need to tie the "name=value" to this button
  1159.     # save the pair and do it when we finish the submit button
  1160.     catch {set form(submit_$item) [list $name $value]}
  1161. }
  1162.  
  1163. #########################################################################
  1164. # selection items
  1165. # They all go into a list box.  We don't what to do with the listbox until
  1166. # we know how many items end up in it.  Gather up the data for the "options"
  1167. # and finish up in the /select tag
  1168. # params: NAME (reqd), MULTIPLE, SIZE 
  1169.  
  1170. proc HMtag_select {win param text} {
  1171.     upvar #0 HM$win var
  1172.     upvar #0 $var(form_id) form
  1173.  
  1174.     HMextract_param $param name
  1175.     set size 5;  HMextract_param $param size
  1176.     set form(select_size) $size
  1177.     set form(select_name) $name
  1178.     set form(select_values) ""        ;# list of values to submit
  1179.     if {[HMextract_param $param multiple]} {
  1180.         set mode multiple
  1181.     } else {
  1182.         set mode single
  1183.     }
  1184.     set item $win.select,$var(tags)
  1185.     frame $item
  1186.     set form(select_frame) $item
  1187.     listbox $item.list -selectmode $mode -width 0 -exportselection 0
  1188.     HMwin_install $win $item
  1189. }
  1190.  
  1191. # select options
  1192. # The values returned in the query may be different from those
  1193. # displayed in the listbox, so we need to keep a separate list of
  1194. # query values.
  1195. #  form(select_default) - contains the default query value
  1196. #  form(select_frame) - name of the listbox's containing frame
  1197. #  form(select_values)  - list of query values
  1198. # params: VALUE, SELECTED
  1199.  
  1200. proc HMtag_option {win param text} {
  1201.     upvar #0 HM$win var
  1202.     upvar #0 $var(form_id) form
  1203.     upvar $text data
  1204.     set frame $form(select_frame)
  1205.  
  1206.     # set default option (or options)
  1207.     if {[HMextract_param $param selected]} {
  1208.         lappend form(select_default) [$form(select_frame).list size]
  1209.     }
  1210.     set value [string trimright $data " \n"]
  1211.     $frame.list insert end $value
  1212.     HMextract_param $param value
  1213.     lappend form(select_values) $value
  1214.     set data ""
  1215. }
  1216.  
  1217. # do most of the work here!
  1218. # if SIZE>1, make the listbox.  Otherwise make a "drop-down"
  1219. # listbox with a label in it
  1220. # If the # of items > size, add a scroll bar
  1221. # This should probably be broken up into callbacks to make it
  1222. # easier to override the "look".
  1223.  
  1224. proc HMtag_/select {win param text} {
  1225.     upvar #0 HM$win var
  1226.     upvar #0 $var(form_id) form
  1227.     set frame $form(select_frame)
  1228.     set size $form(select_size)
  1229.     set items [$frame.list size]
  1230.  
  1231.     # set the defaults and reset button
  1232.     append form(reset) ";$frame.list selection clear 0  $items"
  1233.     if {[info exists form(select_default)]} {
  1234.         foreach i $form(select_default) {
  1235.             $frame.list selection set $i
  1236.             append form(reset) ";$frame.list selection set $i"
  1237.         }
  1238.     } else {
  1239.         $frame.list selection set 0
  1240.         append form(reset) ";$frame.list selection set 0"
  1241.     }
  1242.  
  1243.     # set up the submit button. This is the general case.  For single
  1244.     # selections we could be smarter
  1245.  
  1246.     for {set i 0} {$i < $size} {incr i} {
  1247.         set value [format {[expr {[%s selection includes %s] ? {%s} : {}}]} \
  1248.                 $frame.list $i [lindex $form(select_values) $i]]
  1249.         lappend form(submit) [list $form(select_name) $value]
  1250.     }
  1251.     
  1252.     # show the listbox - no scroll bar
  1253.  
  1254.     if {$size > 1 && $items <= $size} {
  1255.         $frame.list configure -height $items
  1256.         pack $frame.list
  1257.  
  1258.     # Listbox with scrollbar
  1259.  
  1260.     } elseif {$size > 1} {
  1261.         scrollbar $frame.scroll -command "$frame.list yview"  \
  1262.                 -orient v -takefocus 0
  1263.         $frame.list configure -height $size \
  1264.             -yscrollcommand "$frame.scroll set"
  1265.         pack $frame.list $frame.scroll -side right -fill y
  1266.  
  1267.     # This is a joke!
  1268.  
  1269.     } else {
  1270.         scrollbar $frame.scroll -command "$frame.list yview"  \
  1271.             -orient h -takefocus 0
  1272.         $frame.list configure -height 1 \
  1273.             -yscrollcommand "$frame.scroll set"
  1274.         pack $frame.list $frame.scroll -side top -fill x
  1275.     }
  1276.  
  1277.     # cleanup
  1278.  
  1279.     foreach i [array names form select_*] {
  1280.         unset form($i)
  1281.     }
  1282. }
  1283.  
  1284. # do a text area (multi-line text)
  1285. # params: COLS, NAME, ROWS (all reqd, but default rows and cols anyway)
  1286.  
  1287. proc HMtag_textarea {win param text} {
  1288.     upvar #0 HM$win var
  1289.     upvar #0 $var(form_id) form
  1290.     upvar $text data
  1291.  
  1292.     set rows 5; HMextract_param $param rows
  1293.     set cols 30; HMextract_param $param cols
  1294.     HMextract_param $param name
  1295.     set item $win.textarea,$var(tags)
  1296.     frame $item
  1297.     text $item.text -width $cols -height $rows -wrap none \
  1298.             -yscrollcommand "$item.scroll set" -padx 3 -pady 3
  1299.     scrollbar $item.scroll -command "$item.text yview"  -orient v
  1300.     $item.text insert 1.0 $data
  1301.     HMwin_install $win $item
  1302.     pack $item.text $item.scroll -side right -fill y
  1303.     lappend form(submit) [list $name "\[$item.text get 0.0 end]"]
  1304.     append form(reset) ";$item.text delete 1.0 end; \
  1305.             $item.text insert 1.0 [list $data]"
  1306.     set data ""
  1307. }
  1308.  
  1309. # procedure to install windows into the text widget
  1310. # - win:  name of the text widget
  1311. # - item: name of widget to install
  1312.  
  1313. proc HMwin_install {win item} {
  1314.     upvar #0 HM$win var
  1315.     $win window create $var(S_insert) -window $item -align bottom
  1316.     $win tag add indent$var(level) $item
  1317.     set focus [expr {[winfo class $item] != "Frame"}]
  1318.     $item configure -takefocus $focus
  1319.     bind $item <FocusIn> "$win see $item"
  1320. }
  1321.  
  1322. #####################################################################
  1323. # Assemble and submit the query
  1324. # each list element in "stuff" is a name/value pair
  1325. # - The names are the NAME parameters of the various fields
  1326. # - The values get run through "subst" to extract the values
  1327. # - We do the user callback with the list of name value pairs
  1328.  
  1329. proc HMsubmit_button {win form_id param stuff} {
  1330.     upvar #0 HM$win var
  1331.     upvar #0 $form_id form
  1332.     set query ""
  1333.     foreach pair $stuff {
  1334.         set value [subst [lindex $pair 1]]
  1335.         if {$value != ""} {
  1336.             set item [lindex $pair 0]
  1337.             lappend query $item $value
  1338.         }
  1339.     }
  1340.     # this is the user callback.
  1341.     HMsubmit_form $win $param $query
  1342. }
  1343.  
  1344. # sample user callback for form submission
  1345. # should be replaced by the application
  1346. # Sample version generates a string suitable for http
  1347.  
  1348. proc HMsubmit_form {win param query} {
  1349.     set result ""
  1350.     set sep ""
  1351.     foreach i $query {
  1352.         append result  $sep [HMmap_reply $i]
  1353.         if {$sep != "="} {set sep =} {set sep &}
  1354.     }
  1355.     puts $result
  1356. }
  1357.  
  1358. # do x-www-urlencoded character mapping
  1359. # The spec says: "non-alphanumeric characters are replaced by '%HH'"
  1360.  
  1361. set HMalphanumeric    a-zA-Z0-9    ;# definition of alphanumeric character class
  1362. for {set i 1} {$i <= 256} {incr i} {
  1363.     set c [format %c $i]
  1364.     if {![string match \[$HMalphanumeric\] $c]} {
  1365.         set HMform_map($c) %[format %.2x $i]
  1366.     }
  1367. }
  1368.  
  1369. # These are handled specially
  1370. array set HMform_map {
  1371.     " " +   \n %0d%0a
  1372. }
  1373.  
  1374. # 1 leave alphanumerics characters alone
  1375. # 2 Convert every other character to an array lookup
  1376. # 3 Escape constructs that are "special" to the tcl parser
  1377. # 4 "subst" the result, doing all the array substitutions
  1378.  
  1379. proc HMmap_reply {string} {
  1380.     global HMform_map HMalphanumeric
  1381.     regsub -all \[^$HMalphanumeric\] $string {$HMform_map(&)} string
  1382.     regsub -all \n $string {\\n} string
  1383.     regsub -all \t $string {\\t} string
  1384.     regsub -all {[][{})\\]\)} $string {\\&} string
  1385.     return [subst $string]
  1386. }
  1387.  
  1388. # convert a x-www-urlencoded string int a a list of name/value pairs
  1389.  
  1390. # 1  convert a=b&c=d... to {a} {b} {c} {d}...
  1391. # 2, convert + to  " "
  1392. # 3, convert %xx to char equiv
  1393.  
  1394. proc HMcgiDecode {data} {
  1395.     set data [split $data "&="]
  1396.     foreach i $data {
  1397.         lappend result [cgiMap $i]
  1398.     }
  1399.     return $result
  1400. }
  1401.  
  1402. proc HMcgiMap {data} {
  1403.     regsub -all {\+} $data " " data
  1404.     
  1405.     if {[regexp % $data]} {
  1406.         regsub -all {([][$\\])} $data {\\\1} data
  1407.         regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data  {[format %c 0x\1]} data
  1408.         return [subst $data]
  1409.     } else {
  1410.         return $data
  1411.     }
  1412. }
  1413.  
  1414. # There is a bug in the tcl library focus routines that prevents focus
  1415. # from every reaching an un-viewable window.  Use our *own*
  1416. # version of the library routine, until the bug is fixed, make sure we
  1417. # over-ride the library version, and not the otherway around
  1418.  
  1419. auto_load tkFocusOK
  1420. proc tkFocusOK w {
  1421.     set code [catch {$w cget -takefocus} value]
  1422.     if {($code == 0) && ($value != "")} {
  1423.     if {$value == 0} {
  1424.         return 0
  1425.     } elseif {$value == 1} {
  1426.         return 1
  1427.     } else {
  1428.         set value [uplevel #0 $value $w]
  1429.         if {$value != ""} {
  1430.         return $value
  1431.         }
  1432.     }
  1433.     }
  1434.     set code [catch {$w cget -state} value]
  1435.     if {($code == 0) && ($value == "disabled")} {
  1436.     return 0
  1437.     }
  1438.     regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
  1439. }
  1440.