tcl/html_library.tcl

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