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
5 # See the file "license.terms" for information on usage and redistribution
6 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
8 # To use this package, create a text widget (say, .text)
9 # and set a variable full of html, (say $html), and issue:
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
23 # HMgot_image $handle $image
26 # To return a "used" text widget to its initialized state, call:
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
34 # These are Defined in HTML 2.0
38 blockquote {style i indent 1 Trindent rindent}
39 bq {style i indent 1 Trindent rindent}
46 h1 {size 24 weight bold}
53 kbd {family courier weight bold}
56 pre {fill 0 family courier Tnowrap nowrap}
60 u {Tunderline underline}
65 # These are in common(?) use, but not defined in html2.0
68 center {Tcenter center}
69 strike {Tstrike strike}
70 u {Tunderline underline}
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
81 # html tags that insert white space
83 array set HMinsert_map {
84 blockquote "\n\n" /blockquote "\n"
105 # tags that are list elements, that support "compact" rendering
107 array set HMlist_elements {
108 ol 1 ul 1 menu 1 dl 1 dir 1
110 ############################################
111 # initialize the window and stack state
113 proc HMinit_win {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
129 # configure the text insertion point
130 $win mark set $var(S_insert) 1.0
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
141 # generic link enter callback
143 $win tag bind link <1> "HMlink_hit $win %x %y"
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
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"
160 # reset the state of window - get ready for the next page
161 # remove all but the font tags, and remove all form state
163 proc HMreset_win {win} {
165 regsub -all { +[^L ][^ ]*} " [$win tag names] " {} tags
166 catch "$win tag delete $tags"
167 eval $win mark unset [$win mark names]
169 $win tag configure hr -tabs [winfo width $win]
171 # configure the text insertion point
172 $win mark set $var(S_insert) 1.0
174 # remove form state. If any check/radio buttons still exists,
175 # their variables will be magically re-created, and never get
177 catch unset [info globals HM$win.form*]
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
193 proc HMinit_state {win} {
195 array set tmp [array get var S_*]
206 S_symbols O*=+-o\xd7\xb0>:\xb7
209 array set var [array get tmp]
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 ...
216 array set HMparam_map {
226 proc HMset_state {win args} {
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)}]
234 return [expr $bad == 0]
237 ############################################
238 # manage the display of html
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
247 proc HMrender {win tag not param text} {
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]
254 # manage compact rendering of lists
255 if {[info exists HMlist_elements($tag)]} {
256 set list "list [expr {[HMextract_param $param compact] ? "compact" : "list"}]"
261 # Allow text to be diverted to a different window (for tables)
262 # this is not currently used
263 if {[info exists var(divert)]} {
268 # adjust (push or pop) tag state
269 catch {HMstack $win $not "$HMtag_map($tag) $list"}
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]
278 # to fill or not to fill
279 if {[lindex $var(fill) end]} {
280 set text [HMzap_white $text]
284 catch {HMmark $not$tag $win $param text} err
286 # do any special tag processing
287 catch {HMtag_$not$tag $win $param text} msg
290 # add the text with proper tags
292 set tags [HMcurrent_tags $win]
293 $win insert $var(S_insert) $text $tags
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))} {
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
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.
319 proc HMtag_hmstart {win param text} {
321 $win mark gravity $var(S_insert) left
322 $win insert end "\n " last
323 $win mark gravity $var(S_insert) right
326 proc HMtag_/hmstart {win param text} {
327 $win delete last.first end
330 # put the document title in the window banner, and remove the title text
333 proc HMtag_title {win param text} {
335 wm title [winfo toplevel $win] $data
339 proc HMtag_hr {win param text} {
341 $win insert $var(S_insert) "\n" space "\n" thin "\t" "thin hr" "\n" thin
346 proc HMtag_ol {win param text} {
348 set var(count$var(level)) 0
351 proc HMtag_ul {win param text} {
353 catch {unset var(count$var(level))}
356 proc HMtag_menu {win param text} {
362 proc HMtag_/menu {win param text} {
364 catch {unset var(menu)}
365 catch {unset var(compact)}
368 proc HMtag_dt {win param text} {
371 set level $var(level)
373 $win insert $var(S_insert) "$data" \
374 "hi [lindex $var(list) end] indent$level $var(font)"
378 proc HMtag_li {win param text} {
380 set level $var(level)
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)"
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
395 proc HMtag_a {win param text} {
400 if {[HMextract_param $param href]} {
401 set var(Tref) [list L:$href]
402 HMstack $win "" "Tlink link"
403 HMlink_setup $win $href
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} {
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.
425 proc HMgoto {win where {callback HMwent_to}} {
427 if {[regexp N:$where [$win mark names]]} {
430 eval $callback $win [list $where]
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.
442 proc HMwent_to {win where {count 0} {color orange}} {
444 if {$count > 5} return
445 catch {$win tag configure N:$where -foreground $color}
447 after 200 [list HMwent_to $win $where [incr count] \
448 [expr {$color=="orange" ? "" : "orange"}]]
451 proc HMtag_/a {win param text} {
453 if {[info exists var(Tref)]} {
455 HMstack $win / "Tlink link"
458 # goto this link, then invoke the call-back.
460 if {[info exists var(going)]} {
461 $win yview N:$var(going)
463 HMwent_to $win $var(going)
467 if {[info exists var(Tname)]} {
469 HMstack $win / "Tanchor anchor"
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
478 # Images have the following parameters:
479 # align: top,middle,bottom
480 # alt: alternate text
481 # ismap: A clickable image map
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
488 proc HMtag_img {win param text} {
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])}
499 HMextract_param $param alt
500 set alt [HMmap_esc $alt]
502 # get the border width
504 HMextract_param $param border
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
516 pack $label -expand 1 -fill both
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
526 # add in all the current tags (this is overkill)
527 set tags [HMcurrent_tags $win]
529 $win tag add $tag $item
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
538 regsub -all {%} $link {%%} link2
539 foreach i [array names HMevents] {
540 bind $label <$i> "catch \{%W configure $HMevents($i)\}"
542 bind $label <1> "+HMlink_callback $win $link2?%x,%y"
545 # now callback to the application
547 HMextract_param $param src
548 HMset_image $win $label $src
549 return $label ;# used by the forms package for input_image types
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"
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
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
567 if {[catch {$win configure -image $image_error}]} {
568 $win configure -image {}
569 $win configure -text $image_error
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.
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}
587 # We need to escape any %'s in the href tag name so the bind command
588 # doesn't try to substitute them.
590 proc HMlink_setup {win href} {
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)\}
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"
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
614 # win: The name of the text widget to render into
615 # href: The HREF link for this <a> tag.
617 proc HMlink_callback {win href} {
618 puts "Got hit on $win, link $href"
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)
628 proc HMextract_param {param key {val ""}} {
637 # look for name=value combinations. Either (') or (") are valid delimeters
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] } {
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
651 if {[regexp -nocase "$bad$key$bad" -$param-]} {
658 # These next two routines manage the display state of the page.
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
665 proc HMstack {win push list} {
669 foreach tag [array names tags] {
670 lappend var($tag) $tags($tag)
673 foreach tag [array names tags] {
674 # set cnt [regsub { *[^ ]+$} $var($tag) {} var($tag)]
675 set var($tag) [lreplace $var($tag) end end]
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
685 proc HMcurrent_tags {win} {
688 foreach i {family size weight style} {
689 set $i [lindex $var($i) end]
690 append font :[set $i]
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)]
696 lappend tags $font indent$indent
697 foreach tag [array names var T*] {
698 lappend tags [lindex $var($tag) end] ;# test
701 set var(xfont) [$win tag cget $font -font]
702 set var(level) $indent
706 # allow the application to do do better font management
707 # by overriding this procedure
709 proc HMset_font {win tag font} {
710 catch {$win tag configure $tag -font $font} msg
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-*-*-*-*-*-*"
719 # Optimize HMrender (hee hee)
720 # This is experimental
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
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
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} / {} {}"
746 proc HMtest_parse {command tag slash text_after_tag} {
747 puts "==> $command $tag $slash $text_after_tag"
750 # Convert multiple white space into a single space
752 proc HMzap_white {data} {
753 regsub -all "\[ \t\r\n\]+" $data " " data
757 # find HTML escape characters of the form &xxx;
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
768 # convert an HTML escape sequence into character
770 proc HMdo_map {text {unknown ?}} {
773 catch {set result $HMesc_map($text)}
777 # table of escape characters (ISO latin-1 esc's are in a different table)
779 array set HMesc_map {
780 lt < gt > amp & quot \" copy \xa9
781 reg \xae ob \x7b cb \x7d nbsp \xa0
783 #############################################################
784 # ISO Latin-1 escape codes
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
809 ##########################################################
810 # html forms management commands
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
821 # This causes line breaks to be preserved in the inital values
823 array set HMtag_map {
827 ##########################################################
828 # html isindex tag. Although not strictly forms, they're close enough
832 # make a frame with a label, entry, and submit button
834 proc HMtag_isindex {win param text} {
837 set item $win.$var(tags)
838 if {[winfo exists $item]} {
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)
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
853 # insert window into text widget
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}
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)
865 proc HMsubmit_index {win param text} {
866 HMlink_callback $win ?$text
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
874 proc HMtag_form {win param text} {
877 # create a global array for the form
878 set id HM$win.form$var(tags)
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 {} {}
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
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!
899 proc HMtag_/form {win param text} {
901 upvar #0 $var(form_id) form
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)]
909 # process the reset button(s)
911 foreach item $form(reset_button) {
912 $item configure -command $form(reset)
915 # no submit button - add one
916 if {$form(submit_button) == ""} {
917 HMinput_submit $win {}
920 # process the "submit" command(s)
921 # each submit button could have its own name,value pair
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) \
931 # unset all unused fields here
932 unset form(reset) form(submit) form(reset_button) form(submit_button)
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
942 # - add the "submit" and "reset" commands onto the proper Q's
943 # "submit" is subst'd
946 proc HMtag_input {win param text} {
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]} {
958 # parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
960 proc HMinput_text {win param {show {}}} {
962 upvar #0 $var(form_id) form
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
971 # set the initial value
972 set value ""; HMextract_param $param value
973 $item insert 0 $value
976 HMwin_install $win $item
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]"]
982 # handle the maximum length (broken - no way to cleanup bindtags state)
984 bindtags $item "[bindtags $item] max$maxlength"
985 bind max$maxlength <KeyPress> "%W delete $maxlength end"
989 # password fields - same as text, only don't show data
990 # parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
992 proc HMinput_password {win param} {
993 HMinput_text $win $param *
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
1000 proc HMinput_checkbox {win param} {
1002 upvar #0 $var(form_id) form
1004 HMextract_param $param name
1005 HMextract_param $param value
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]} {
1014 append form(reset) ";$item select"
1016 append form(reset) ";$item deselect"
1019 HMwin_install $win $item
1020 lappend form(submit) [list $name \$form(check_$var(tags))]
1023 # radio buttons. These are like check buttons, but only one can be selected
1025 proc HMinput_radio {win param} {
1027 upvar #0 $var(form_id) form
1029 HMextract_param $param name
1030 HMextract_param $param value
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 " "
1038 HMwin_install $win $item
1040 if {$first || [HMextract_param $param checked]} {
1042 append form(reset) ";$item select"
1044 append form(reset) ";$item deselect"
1047 # do the "submit" actions in /form so we only end up with 1 per button grouping
1048 # contributing to the submission
1051 # hidden fields, just append to the "submit" data
1052 # params: NAME, VALUE (reqd)
1054 proc HMinput_hidden {win param} {
1056 upvar #0 $var(form_id) form
1057 HMextract_param $param name
1058 HMextract_param $param value
1059 lappend form(submit) [list $name $value]
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
1068 proc HMinput_image {win param} {
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
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
1080 set submit $win.dummy_submit,$var(tags)
1081 if {[winfo exists $submit]} {
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)]
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
1096 bind $item <ButtonRelease-1> "
1097 set $var(form_id)(X) %x
1098 set $var(form_id)(Y) %y
1099 $item configure -relief raised
1104 # Set up the reset button. Wait for the /form to attach
1105 # the -command option. There could be more that 1 reset button
1108 proc HMinput_reset {win param} {
1110 upvar #0 $var(form_id) form
1113 HMextract_param $param value
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
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
1125 proc HMinput_submit {win param} {
1127 upvar #0 $var(form_id) form
1129 HMextract_param $param name
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]}
1141 #########################################################################
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
1148 proc HMtag_select {win param text} {
1150 upvar #0 $var(form_id) form
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]} {
1162 set item $win.select,$var(tags)
1164 set form(select_frame) $item
1165 listbox $item.list -selectmode $mode -width 0 -exportselection 0
1166 HMwin_install $win $item
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
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
1178 proc HMtag_option {win param text} {
1180 upvar #0 $var(form_id) form
1182 set frame $form(select_frame)
1184 # set default option (or options)
1185 if {[HMextract_param $param selected]} {
1186 lappend form(select_default) [$form(select_frame).list size]
1188 set value [string trimright $data " \n"]
1189 $frame.list insert end $value
1190 HMextract_param $param value
1191 lappend form(select_values) $value
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".
1202 proc HMtag_/select {win param text} {
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]
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"
1217 $frame.list selection set 0
1218 append form(reset) ";$frame.list selection set 0"
1221 # set up the submit button. This is the general case. For single
1222 # selections we could be smarter
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]
1230 # show the listbox - no scroll bar
1232 if {$size > 1 && $items <= $size} {
1233 $frame.list configure -height $items
1236 # Listbox with scrollbar
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
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
1257 foreach i [array names form select_*] {
1262 # do a text area (multi-line text)
1263 # params: COLS, NAME, ROWS (all reqd, but default rows and cols anyway)
1265 proc HMtag_textarea {win param text} {
1267 upvar #0 $var(form_id) form
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)
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]"
1287 # procedure to install windows into the text widget
1288 # - win: name of the text widget
1289 # - item: name of widget to install
1291 proc HMwin_install {win item} {
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"
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
1307 proc HMsubmit_button {win form_id param stuff} {
1309 upvar #0 $form_id form
1311 foreach pair $stuff {
1312 set value [subst [lindex $pair 1]]
1314 set item [lindex $pair 0]
1315 lappend query $item $value
1318 # this is the user callback.
1319 HMsubmit_form $win $param $query
1322 # sample user callback for form submission
1323 # should be replaced by the application
1324 # Sample version generates a string suitable for http
1326 proc HMsubmit_form {win param query} {
1330 append result $sep [HMmap_reply $i]
1331 if {$sep != "="} {set sep =} {set sep &}
1336 # do x-www-urlencoded character mapping
1337 # The spec says: "non-alphanumeric characters are replaced by '%HH'"
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]
1347 # These are handled specially
1348 array set HMform_map {
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
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]
1366 # convert a x-www-urlencoded string int a a list of name/value pairs
1368 # 1 convert a=b&c=d... to {a} {b} {c} {d}...
1369 # 2, convert + to " "
1370 # 3, convert %xx to char equiv
1372 proc HMcgiDecode {data} {
1373 set data [split $data "&="]
1375 lappend result [cgiMap $i]
1380 proc HMcgiMap {data} {
1381 regsub -all {\+} $data " " data
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]
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
1399 set code [catch {$w cget -takefocus} value]
1400 if {($code == 0) && ($value != "")} {
1403 } elseif {$value == 1} {
1406 set value [uplevel #0 $value $w]
1412 set code [catch {$w cget -state} value]
1413 if {($code == 0) && ($value == "disabled")} {
1416 regexp Key|Focus "[bind $w] [bind [winfo class $w]]"