]> www.wagner.pp.ru Git - oss/fgis.git/blob - tcl/html_library.tcl
The second attempt to automate building :-) A lot of work here should be
[oss/fgis.git] / 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 }