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
##################################################################
31
# Include the select dialog code because it defines scroll bindings
32
source $env(GISBASE)/etc/gtcltk/select.tcl
35
############################################
36
# mapping of html tags to text tag properties
37
# properties beginning with "T" map directly to text tags
39
# These are Defined in HTML 2.0
43
blockquote {style i indent 1 Trindent rindent}
44
bq {style i indent 1 Trindent rindent}
51
h1 {size 24 weight bold}
58
kbd {family courier weight bold}
61
pre {fill 0 family courier Tnowrap nowrap}
65
u {Tunderline underline}
70
# These are in common(?) use, but not defined in html2.0
73
center {Tcenter center}
74
strike {Tstrike strike}
75
u {Tunderline underline}
80
set HMtag_map(hmstart) {
81
family times weight medium style r size 14
82
Tcenter "" Tlink "" Tnowrap "" Tunderline "" list list
83
fill 1 indent "" counter 0 adjust 0
86
# html tags that insert white space
88
array set HMinsert_map {
89
blockquote "\n\n" /blockquote "\n"
110
# tags that are list elements, that support "compact" rendering
112
array set HMlist_elements {
113
ol 1 ul 1 menu 1 dl 1 dir 1
115
############################################
116
# initialize the window and stack state
118
proc HMinit_win {win} {
122
$win tag configure underline -underline 1
123
$win tag configure center -justify center
124
$win tag configure nowrap -wrap none
125
$win tag configure rindent -rmargin $var(S_tab)c
126
$win tag configure strike -overstrike 1
127
$win tag configure mark -foreground red ;# list markers
128
$win tag configure list -spacing1 3p -spacing3 3p ;# regular lists
129
$win tag configure compact -spacing1 0p ;# compact lists
130
$win tag configure link -borderwidth 2 -foreground blue ;# hypertext links
131
HMset_indent $win $var(S_tab)
132
$win configure -wrap word
134
# configure the text insertion point
135
$win mark set $var(S_insert) 1.0
137
# for horizontal rules
138
$win tag configure thin -font [HMx_font times 2 medium r]
139
$win tag configure hr -relief sunken -borderwidth 2 -wrap none \
140
-tabs [winfo width $win]
141
bind $win <Configure> {
142
%W tag configure hr -tabs %w
143
%W tag configure last -spacing3 %h
146
# generic link enter callback
148
$win tag bind link <1> "HMlink_hit $win %x %y"
151
# set the indent spacing (in cm) for lists
152
# TK uses a "weird" tabbing model that causes \t to insert a single
153
# space if the current line position is past the tab setting
155
proc HMset_indent {win cm} {
156
set tabs [expr $cm / 2.0]
157
$win configure -tabs ${tabs}c
158
foreach i {1 2 3 4 5 6 7 8 9} {
159
set tab [expr $i * $cm]
160
$win tag configure indent$i -lmargin1 ${tab}c -lmargin2 ${tab}c \
161
-tabs "[expr $tab + $tabs]c [expr $tab + 2*$tabs]c"
165
# reset the state of window - get ready for the next page
166
# remove all but the font tags, and remove all form state
168
proc HMreset_win {win} {
170
regsub -all { +[^L ][^ ]*} " [$win tag names] " {} tags
171
catch "$win tag delete $tags"
172
eval $win mark unset [$win mark names]
174
$win tag configure hr -tabs [winfo width $win]
176
# configure the text insertion point
177
$win mark set $var(S_insert) 1.0
179
# remove form state. If any check/radio buttons still exists,
180
# their variables will be magically re-created, and never get
182
catch unset [info globals HM$win.form*]
188
# initialize the window's state array
189
# Parameters beginning with S_ are NOT reset
190
# adjust_size: global font size adjuster
191
# unknown: character to use for unknown entities
192
# tab: tab stop (in cm)
193
# stop: enabled to stop processing
194
# update: how many tags between update calls
195
# tags: number of tags processed so far
196
# symbols: Symbols to use on un-ordered lists
198
proc HMinit_state {win} {
200
array set tmp [array get var S_*]
211
S_symbols O*=+-o\xd7\xb0>:\xb7
214
array set var [array get tmp]
217
# alter the parameters of the text state
218
# this allows an application to over-ride the default settings
219
# it is called as: HMset_state -param value -param value ...
221
array set HMparam_map {
231
proc HMset_state {win args} {
235
if {[catch {array set params $args}]} {return 0}
236
foreach i [array names params] {
237
incr bad [catch {set var($HMparam_map($i)) $params($i)}]
239
return [expr $bad == 0]
242
############################################
243
# manage the display of html
245
# HMrender gets called for every html tag
246
# win: The name of the text widget to render into
247
# tag: The html tag (in arbitrary case)
248
# not: a "/" or the empty string
249
# param: The un-interpreted parameter list
250
# text: The plain text until the next html tag
252
proc HMrender {win tag not param text} {
254
if {$var(stop)} return
255
global HMtag_map HMinsert_map HMlist_elements
256
set tag [string tolower $tag]
257
set text [HMmap_esc $text]
259
# manage compact rendering of lists
260
if {[info exists HMlist_elements($tag)]} {
261
set list "list [expr {[HMextract_param $param compact] ? "compact" : "list"}]"
266
# Allow text to be diverted to a different window (for tables)
267
# this is not currently used
268
if {[info exists var(divert)]} {
273
# adjust (push or pop) tag state
274
catch {HMstack $win $not "$HMtag_map($tag) $list"}
276
# insert white space (with current font)
277
# adding white space can get a bit tricky. This isn't quite right
278
set bad [catch {$win insert $var(S_insert) $HMinsert_map($not$tag) "space $var(font)"}]
279
if {!$bad && [lindex $var(fill) end]} {
280
set text [string trimleft $text]
283
# to fill or not to fill
284
if {[lindex $var(fill) end]} {
285
set text [HMzap_white $text]
289
catch {HMmark $not$tag $win $param text} err
291
# do any special tag processing
292
catch {HMtag_$not$tag $win $param text} msg
295
# add the text with proper tags
297
set tags [HMcurrent_tags $win]
298
$win insert $var(S_insert) $text $tags
300
# We need to do an update every so often to insure interactive response.
301
# This can cause us to re-enter the event loop, and cause recursive
302
# invocations of HMrender, so we need to be careful.
303
if {!([incr var(tags)] % $var(S_update))} {
308
# html tags requiring special processing
309
# Procs of the form HMtag_<tag> or HMtag_</tag> get called just before
310
# the text for this tag is displayed. These procs are called inside a
311
# "catch" so it is OK to fail.
312
# win: The name of the text widget to render into
313
# param: The un-interpreted parameter list
314
# text: A pass-by-reference name of the plain text until the next html tag
315
# Tag commands may change this to affect what text will be inserted
318
# A pair of pseudo tags are added automatically as the 1st and last html
319
# tags in the document. The default is <HMstart> and </HMstart>.
320
# Append enough blank space at the end of the text widget while
321
# rendering so HMgoto can place the target near the top of the page,
322
# then remove the extra space when done rendering.
324
proc HMtag_hmstart {win param text} {
326
$win mark gravity $var(S_insert) left
327
$win insert end "\n " last
328
$win mark gravity $var(S_insert) right
331
proc HMtag_/hmstart {win param text} {
332
$win delete last.first end
335
# put the document title in the window banner, and remove the title text
338
proc HMtag_title {win param text} {
340
wm title [winfo toplevel $win] $data
344
proc HMtag_hr {win param text} {
346
$win insert $var(S_insert) "\n" space "\n" thin "\t" "thin hr" "\n" thin
351
proc HMtag_ol {win param text} {
353
set var(count$var(level)) 0
356
proc HMtag_ul {win param text} {
358
catch {unset var(count$var(level))}
361
proc HMtag_menu {win param text} {
367
proc HMtag_/menu {win param text} {
369
catch {unset var(menu)}
370
catch {unset var(compact)}
373
proc HMtag_dt {win param text} {
376
set level $var(level)
378
$win insert $var(S_insert) "$data" \
379
"hi [lindex $var(list) end] indent$level $var(font)"
383
proc HMtag_li {win param text} {
385
set level $var(level)
387
set x [string index $var(S_symbols)+-+-+-+-" $level]
388
catch {set x [incr var(count$level)]}
389
catch {set x $var(menu)}
390
$win insert $var(S_insert) \t$x\t "mark [lindex $var(list) end] indent$level $var(font)"
393
# Manage hypertext "anchor" links. A link can be either a source (href)
394
# a destination (name) or both. If its a source, register it via a callback,
395
# and set its default behavior. If its a destination, check to see if we need
396
# to go there now, as a result of a previous HMgoto request. If so, schedule
397
# it to happen with the closing </a> tag, so we can highlight the text up to
400
proc HMtag_a {win param text} {
405
if {[HMextract_param $param href]} {
406
set var(Tref) [list L:$href]
407
HMstack $win "" "Tlink link"
408
HMlink_setup $win $href
413
if {[HMextract_param $param name]} {
414
set var(Tname) [list N:$name]
415
HMstack $win "" "Tanchor anchor"
416
$win mark set N:$name "$var(S_insert) - 1 chars"
417
$win mark gravity N:$name left
418
if {[info exists var(goto)] && $var(goto) == $name} {
425
# The application should call here with the fragment name
426
# to cause the display to go to this spot.
427
# If the target exists, go there (and do the callback),
428
# otherwise schedule the goto to happen when we see the reference.
430
proc HMgoto {win where {callback HMwent_to}} {
432
if {[regexp N:$where [$win mark names]]} {
435
eval $callback $win [list $where]
443
# We actually got to the spot, so highlight it!
444
# This should/could be replaced by the application
445
# We'll flash it orange a couple of times.
447
proc HMwent_to {win where {count 0} {color orange}} {
449
if {$count > 5} return
450
catch {$win tag configure N:$where -foreground $color}
452
after 200 [list HMwent_to $win $where [incr count] \
453
[expr {$color=="orange" ? "" : "orange"}]]
456
proc HMtag_/a {win param text} {
458
if {[info exists var(Tref)]} {
460
HMstack $win / "Tlink link"
463
# goto this link, then invoke the call-back.
465
if {[info exists var(going)]} {
466
$win yview N:$var(going)
468
HMwent_to $win $var(going)
472
if {[info exists var(Tname)]} {
474
HMstack $win / "Tanchor anchor"
479
# This interface is subject to change
480
# Most of the work is getting around a limitation of TK that prevents
481
# setting the size of a label to a widthxheight in pixels
483
# Images have the following parameters:
484
# align: top,middle,bottom
485
# alt: alternate text
486
# ismap: A clickable image map
488
# Netscape supports (and so do we)
489
# width: A width hint (in pixels)
490
# height: A height hint (in pixels)
491
# border: The size of the window border
493
proc HMtag_img {win param text} {
497
array set align_map {top top middle center bottom bottom}
498
set align bottom ;# The spec isn't clear what the default should be
499
HMextract_param $param align
500
catch {set align $align_map([string tolower $align])}
504
HMextract_param $param alt
505
set alt [HMmap_esc $alt]
507
# get the border width
509
HMextract_param $param border
511
# see if we have an image size hint
512
# If so, make a frame the "hint" size to put the label in
513
# otherwise just make the label
514
set item $win.$var(tags)
515
# catch {destroy $item}
516
if {[HMextract_param $param width] && [HMextract_param $param height]} {
517
frame $item -width $width -height $height
518
pack propagate $item 0
519
set label $item.label
521
pack $label -expand 1 -fill both
527
$label configure -relief ridge -fg orange -text $alt
528
catch {$label configure -bd $border}
529
$win window create $var(S_insert) -align $align -window $item -pady 2 -padx 2
531
# add in all the current tags (this is overkill)
532
set tags [HMcurrent_tags $win]
534
$win tag add $tag $item
537
# set imagemap callbacks
538
if {[HMextract_param $param ismap]} {
539
# regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link
540
set link [lindex $tags [lsearch -glob $tags L:*]]
541
regsub L: $link {} link
543
regsub -all {%} $link {%%} link2
544
foreach i [array names HMevents] {
545
bind $label <$i> "catch \{%W configure $HMevents($i)\}"
547
bind $label <1> "+HMlink_callback $win $link2?%x,%y"
550
# now callback to the application
552
HMextract_param $param src
553
HMset_image $win $label $src
554
return $label ;# used by the forms package for input_image types
557
# The app needs to supply one of these
558
proc HMset_image {win handle src} {
559
HMgot_image $handle "can't get\n$src"
562
# When the image is available, the application should call back here.
563
# If we have the image, put it in the label, otherwise display the error
564
# message. If we don't get a callback, the "alt" text remains.
565
# if we have a clickable image, arrange for a callback
567
proc HMgot_image {win image_error} {
568
# if we're in a frame turn on geometry propogation
569
if {[winfo name $win] == "label"} {
570
pack propagate [winfo parent $win] 1
572
if {[catch {$win configure -image $image_error}]} {
573
$win configure -image {}
574
$win configure -text $image_error
578
# Sample hypertext link callback routine - should be replaced by app
579
# This proc is called once for each <A> tag.
580
# Applications can overwrite this procedure, as required, or
581
# replace the HMevents array
582
# win: The name of the text widget to render into
583
# href: The HREF link for this <a> tag.
586
Enter {-borderwidth 2 -relief raised }
587
Leave {-borderwidth 2 -relief flat }
588
1 {-borderwidth 2 -relief sunken}
589
ButtonRelease-1 {-borderwidth 2 -relief raised}
592
# We need to escape any %'s in the href tag name so the bind command
593
# doesn't try to substitute them.
595
proc HMlink_setup {win href} {
597
regsub -all {%} $href {%%} href2
598
foreach i [array names HMevents] {
599
eval {$win tag bind L:$href <$i>} \
600
\{$win tag configure \{L:$href2\} $HMevents($i)\}
604
# generic link-hit callback
605
# This gets called upon button hits on hypertext links
606
# Applications are expected to supply ther own HMlink_callback routine
607
# win: The name of the text widget to render into
608
# x,y: The cursor position at the "click"
610
proc HMlink_hit {win x y} {
611
set tags [$win tag names @$x,$y]
612
set link [lindex $tags [lsearch -glob $tags L:*]]
613
# regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link
614
regsub L: $link {} link
615
HMlink_callback $win $link
619
# win: The name of the text widget to render into
620
# href: The HREF link for this <a> tag.
622
proc HMlink_callback {win href} {
623
puts "Got hit on $win, link $href"
626
# extract a value from parameter list (this needs a re-do)
627
# returns "1" if the keyword is found, "0" otherwise
628
# param: A parameter list. It should alredy have been processed to
629
# remove any entity references
630
# key: The parameter name
631
# val: The variable to put the value into (use key as default)
633
proc HMextract_param {param key {val ""}} {
642
# look for name=value combinations. Either (') or (") are valid delimeters
644
[regsub -nocase [format {.*%s[%s]*=[%s]*"([^"]*).*} $key $ws $ws] $param {\1} value] ||
645
[regsub -nocase [format {.*%s[%s]*=[%s]*'([^']*).*} $key $ws $ws] $param {\1} value] ||
646
[regsub -nocase [format {.*%s[%s]*=[%s]*([^%s]+).*} $key $ws $ws $ws] $param {\1} value] } {
651
# now look for valueless names
652
# I should strip out name=value pairs, so we don't end up with "name"
653
# inside the "value" part of some other key word - some day
656
if {[regexp -nocase "$bad$key$bad" -$param-]} {
663
# These next two routines manage the display state of the page.
665
# Push or pop tags to/from stack.
666
# Each orthogonal text property has its own stack, stored as a list.
667
# The current (most recent) tag is the last item on the list.
668
# Push is {} for pushing and {/} for popping
670
proc HMstack {win push list} {
674
foreach tag [array names tags] {
675
lappend var($tag) $tags($tag)
678
foreach tag [array names tags] {
679
# set cnt [regsub { *[^ ]+$} $var($tag) {} var($tag)]
680
set var($tag) [lreplace $var($tag) end end]
685
# extract set of current text tags
686
# tags starting with T map directly to text tags, all others are
687
# handled specially. There is an application callback, HMset_font
688
# to allow the application to do font error handling
690
proc HMcurrent_tags {win} {
693
foreach i {family size weight style} {
694
set $i [lindex $var($i) end]
695
append font :[set $i]
697
set xfont [HMx_font $family $size $weight $style $var(S_adjust_size)]
698
HMset_font $win $font $xfont
699
set indent [llength $var(indent)]
701
lappend tags $font indent$indent
702
foreach tag [array names var T*] {
703
lappend tags [lindex $var($tag) end] ;# test
706
set var(xfont) [$win tag cget $font -font]
707
set var(level) $indent
711
# allow the application to do do better font management
712
# by overriding this procedure
714
proc HMset_font {win tag font} {
715
catch {$win tag configure $tag -font $font} msg
718
# generate an X font name
719
proc HMx_font {family size weight style {adjust_size 0}} {
720
catch {incr size $adjust_size}
721
return "-*-$family-$weight-$style-normal-*-*-${size}0-*-*-*-*-*-*"
724
# Optimize HMrender (hee hee)
725
# This is experimental
728
regsub -all "\n\[ \]*#\[^\n\]*" [info body HMrender] {} body
729
regsub -all ";\[ \]*#\[^\n]*" $body {} body
730
regsub -all "\n\n+" $body \n body
731
proc HMrender {win tag not param text} $body
733
############################################
734
# Turn HTML into TCL commands
735
# html A string containing an html document
736
# cmd A command to run for each html tag found
737
# start The name of the dummy html start/stop tags
739
proc HMparse_html {html {cmd HMtest_parse} {start hmstart}} {
740
regsub -all \{ $html {\&ob;} html
741
regsub -all \} $html {\&cb;} html
742
set w " \t\r\n" ;# white space
743
proc HMcl x {return "\[$x\]"}
744
set exp <(/?)([HMcl ^$w>]+)[HMcl $w]*([HMcl ^>]*)>
745
set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
746
regsub -all $exp $html $sub html
747
eval "$cmd {$start} {} {} \{ $html \}"
748
eval "$cmd {$start} / {} {}"
751
proc HMtest_parse {command tag slash text_after_tag} {
752
puts "==> $command $tag $slash $text_after_tag"
755
# Convert multiple white space into a single space
757
proc HMzap_white {data} {
758
regsub -all "\[ \t\r\n\]+" $data " " data
762
# find HTML escape characters of the form &xxx;
764
proc HMmap_esc {text} {
765
if {![regexp & $text]} {return $text}
766
regsub -all {([][$\\])} $text {\\\1} new
767
regsub -all {&#([0-9][0-9]?[0-9]?);?} \
768
$new {[format %c [scan \1 %d tmp;set tmp]]} new
769
regsub -all {&([a-zA-Z]+);?} $new {[HMdo_map \1]} new
773
# convert an HTML escape sequence into character
775
proc HMdo_map {text {unknown ?}} {
778
catch {set result $HMesc_map($text)}
782
# table of escape characters (ISO latin-1 esc's are in a different table)
784
array set HMesc_map {
785
lt < gt > amp & quot \" copy \xa9
786
reg \xae ob \x7b cb \x7d nbsp \xa0
788
#############################################################
789
# ISO Latin-1 escape codes
791
array set HMesc_map {
792
nbsp \xa0 iexcl \xa1 cent \xa2 pound \xa3 curren \xa4
793
yen \xa5 brvbar \xa6 sect \xa7 uml \xa8 copy \xa9
794
ordf \xaa laquo \xab not \xac shy \xad reg \xae
795
hibar \xaf deg \xb0 plusmn \xb1 sup2 \xb2 sup3 \xb3
796
acute \xb4 micro \xb5 para \xb6 middot \xb7 cedil \xb8
797
sup1 \xb9 ordm \xba raquo \xbb frac14 \xbc frac12 \xbd
798
frac34 \xbe iquest \xbf Agrave \xc0 Aacute \xc1 Acirc \xc2
799
Atilde \xc3 Auml \xc4 Aring \xc5 AElig \xc6 Ccedil \xc7
800
Egrave \xc8 Eacute \xc9 Ecirc \xca Euml \xcb Igrave \xcc
801
Iacute \xcd Icirc \xce Iuml \xcf ETH \xd0 Ntilde \xd1
802
Ograve \xd2 Oacute \xd3 Ocirc \xd4 Otilde \xd5 Ouml \xd6
803
times \xd7 Oslash \xd8 Ugrave \xd9 Uacute \xda Ucirc \xdb
804
Uuml \xdc Yacute \xdd THORN \xde szlig \xdf agrave \xe0
805
aacute \xe1 acirc \xe2 atilde \xe3 auml \xe4 aring \xe5
806
aelig \xe6 ccedil \xe7 egrave \xe8 eacute \xe9 ecirc \xea
807
euml \xeb igrave \xec iacute \xed icirc \xee iuml \xef
808
eth \xf0 ntilde \xf1 ograve \xf2 oacute \xf3 ocirc \xf4
809
otilde \xf5 ouml \xf6 divide \xf7 oslash \xf8 ugrave \xf9
810
uacute \xfa ucirc \xfb uuml \xfc yacute \xfd thorn \xfe
814
##########################################################
815
# html forms management commands
817
# As each form element is located, it is created and rendered. Additional
818
# state is stored in a form specific global variable to be processed at
819
# the end of the form, including the "reset" and "submit" options.
820
# Remember, there can be multiple forms existing on multiple pages. When
821
# HTML tables are added, a single form could be spread out over multiple
822
# text widgets, which makes it impractical to hang the form state off the
823
# HM$win structure. We don't need to check for the existance of required
824
# parameters, we just "fail" and get caught in HMrender
826
# This causes line breaks to be preserved in the inital values
828
array set HMtag_map {
832
##########################################################
833
# html isindex tag. Although not strictly forms, they're close enough
837
# make a frame with a label, entry, and submit button
839
proc HMtag_isindex {win param text} {
842
set item $win.$var(tags)
843
if {[winfo exists $item]} {
846
frame $item -relief ridge -bd 3
847
set prompt "Enter search keywords here"
848
HMextract_param $param prompt
849
label $item.label -text [HMmap_esc $prompt] -font $var(xfont)
851
bind $item.entry <Return> "$item.submit invoke"
852
button $item.submit -text search -font $var(xfont) -command \
853
[format {HMsubmit_index %s {%s} [HMmap_reply [%s get]]} \
854
$win $param $item.entry]
855
pack $item.label -side top
856
pack $item.entry $item.submit -side left
858
# insert window into text widget
860
$win insert $var(S_insert) \n isindex
861
HMwin_install $win $item
862
$win insert $var(S_insert) \n isindex
863
bind $item <Visibility> {focus %W.entry}
866
# This is called when the isindex form is submitted.
867
# The default version calls HMlink_callback. Isindex tags should either
868
# be deprecated, or fully supported (e.g. they need an href parameter)
870
proc HMsubmit_index {win param text} {
871
HMlink_callback $win ?$text
874
# initialize form state. All of the state for this form is kept
875
# in a global array whose name is stored in the form_id field of
876
# the main window array.
877
# Parameters: ACTION, METHOD, ENCTYPE
879
proc HMtag_form {win param text} {
882
# create a global array for the form
883
set id HM$win.form$var(tags)
886
# missing /form tag, simulate it
887
if {[info exists var(form_id)]} {
888
puts "Missing end-form tag !!!! $var(form_id)"
889
HMtag_/form $win {} {}
894
set form(param) $param ;# form initial parameter list
895
set form(reset) "" ;# command to reset the form
896
set form(reset_button) "" ;# list of all reset buttons
897
set form(submit) "" ;# command to submit the form
898
set form(submit_button) "" ;# list of all submit buttons
901
# Where we're done try to get all of the state into the widgets so
902
# we can free up the form structure here. Unfortunately, we can't!
904
proc HMtag_/form {win param text} {
906
upvar #0 $var(form_id) form
908
# make submit button entries for all radio buttons
909
foreach name [array names form radio_*] {
910
regsub radio_ $name {} name
911
lappend form(submit) [list $name \$form(radio_$name)]
914
# no submit button - add one
915
if {$form(submit_button) == ""} {
916
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
# process the reset button(s)
932
HMinput_reset $win {}
933
foreach item $form(reset_button) {
934
$item configure -command $form(reset)
937
# unset all unused fields here
938
unset form(reset) form(submit) form(reset_button) form(submit_button)
942
###################################################################
943
# handle form input items
944
# each item type is handled in a separate procedure
945
# Each "type" procedure needs to:
946
# - create the window
948
# - add the "submit" and "reset" commands onto the proper Q's
949
# "submit" is subst'd
952
proc HMtag_input {win param text} {
955
set type text ;# the default
956
HMextract_param $param type
957
set type [string tolower $type]
958
if {[catch {HMinput_$type $win $param} err]} {
964
# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
966
proc HMinput_text {win param {show {}}} {
968
upvar #0 $var(form_id) form
971
HMextract_param $param name ;# required
972
set item $win.input_text,$var(tags)
973
set size 20; HMextract_param $param size
974
set maxlength 0; HMextract_param $param maxlength
975
entry $item -width $size -show $show
977
# set the initial value
978
set value ""; HMextract_param $param value
979
$item insert 0 $value
982
HMwin_install $win $item
984
# set the "reset" and "submit" commands
985
append form(reset) ";$item delete 0 end;$item insert 0 [list $value]"
986
lappend form(submit) [list $name "\[$item get]"]
988
# handle the maximum length (broken - no way to cleanup bindtags state)
990
bindtags $item "[bindtags $item] max$maxlength"
991
bind max$maxlength <KeyPress> "%W delete $maxlength end"
995
# password fields - same as text, only don't show data
996
# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
998
proc HMinput_password {win param} {
999
HMinput_text $win $param *
1002
# checkbuttons are missing a "get" option, so we must use a global
1003
# variable to store the value.
1004
# Parameters NAME, VALUE, (reqd), CHECKED
1006
proc HMinput_checkbox {win param} {
1008
upvar #0 $var(form_id) form
1010
HMextract_param $param name
1011
HMextract_param $param value
1013
# Set the global variable, don't use the "form" alias as it is not
1014
# defined in the global scope of the button
1015
set variable $var(form_id)(check_$var(tags))
1016
set item $win.input_checkbutton,$var(tags)
1017
checkbutton $item -variable $variable -off {} -on $value -text " "
1018
if {[HMextract_param $param checked]} {
1020
append form(reset) ";$item select"
1022
append form(reset) ";$item deselect"
1025
HMwin_install $win $item
1026
lappend form(submit) [list $name \$form(check_$var(tags))]
1029
# radio buttons. These are like check buttons, but only one can be selected
1031
proc HMinput_radio {win param} {
1033
upvar #0 $var(form_id) form
1035
HMextract_param $param name
1036
HMextract_param $param value
1038
set first [expr ![info exists form(radio_$name)]]
1039
set variable $var(form_id)(radio_$name)
1040
set variable $var(form_id)(radio_$name)
1041
set item $win.input_radiobutton,$var(tags)
1042
radiobutton $item -variable $variable -value $value -text " "
1044
HMwin_install $win $item
1046
if {$first || [HMextract_param $param checked]} {
1048
append form(reset) ";$item select"
1050
append form(reset) ";$item deselect"
1053
# do the "submit" actions in /form so we only end up with 1 per button grouping
1054
# contributing to the submission
1057
# hidden fields, just append to the "submit" data
1058
# params: NAME, VALUE (reqd)
1060
proc HMinput_hidden {win param} {
1062
upvar #0 $var(form_id) form
1063
HMextract_param $param name
1064
HMextract_param $param value
1065
lappend form(submit) [list $name $value]
1068
# handle input images. The spec isn't very clear on these, so I'm not
1069
# sure its quite right
1070
# Use std image tag, only set up our own callbacks
1071
# (e.g. make sure ismap isn't set)
1072
# params: NAME, SRC (reqd) ALIGN
1074
proc HMinput_image {win param} {
1076
upvar #0 $var(form_id) form
1077
HMextract_param $param name
1078
set name ;# barf if no name is specified
1079
set item [HMtag_img $win $param {}]
1080
$item configure -relief raised -bd 2 -bg blue
1082
# make a dummy "submit" button, and invoke it to send the form.
1083
# We have to get the %x,%y in the value somehow, so calculate it during
1084
# binding, and save it in the form array for later processing
1086
set submit $win.dummy_submit,$var(tags)
1087
if {[winfo exists $submit]} {
1090
button $submit -takefocus 0;# this never gets mapped!
1091
lappend form(submit_button) $submit
1092
set form(submit_$submit) [list $name $name.\$form(X).\$form(Y)]
1094
$item configure -takefocus 1
1095
bind $item <FocusIn> "catch \{$win see $item\}"
1096
bind $item <1> "$item configure -relief sunken"
1097
bind $item <Return> "
1098
set $var(form_id)(X) 0
1099
set $var(form_id)(Y) 0
1102
bind $item <ButtonRelease-1> "
1103
set $var(form_id)(X) %x
1104
set $var(form_id)(Y) %y
1105
$item configure -relief raised
1110
# Set up the reset button. Wait for the /form to attach
1111
# the -command option. There could be more that 1 reset button
1114
proc HMinput_reset {win param} {
1116
upvar #0 $var(form_id) form
1119
HMextract_param $param value
1121
set item $win.input_reset,$var(tags)
1122
button $item -text [HMmap_esc $value] -cursor left_ptr
1123
HMwin_install $win $item
1124
lappend form(reset_button) $item
1127
# Set up the submit button. Wait for the /form to attach
1128
# the -command option. There could be more that 1 submit button
1129
# params: NAME, VALUE
1131
proc HMinput_submit {win param} {
1133
upvar #0 $var(form_id) form
1135
HMextract_param $param name
1137
HMextract_param $param value
1138
set item $win.input_submit,$var(tags)
1139
button $item -text [HMmap_esc $value] -fg blue -cursor left_ptr
1140
HMwin_install $win $item
1141
lappend form(submit_button) $item
1142
# need to tie the "name=value" to this button
1143
# save the pair and do it when we finish the submit button
1144
catch {set form(submit_$item) [list $name $value]}
1147
#########################################################################
1149
# They all go into a list box. We don't what to do with the listbox until
1150
# we know how many items end up in it. Gather up the data for the "options"
1151
# and finish up in the /select tag
1152
# params: NAME (reqd), MULTIPLE, SIZE
1154
proc HMtag_select {win param text} {
1156
upvar #0 $var(form_id) form
1158
HMextract_param $param name
1159
set size 5; HMextract_param $param size
1160
set form(select_size) $size
1161
set form(select_name) $name
1162
set form(select_values) "" ;# list of values to submit
1163
if {[HMextract_param $param multiple]} {
1168
set item $win.select,$var(tags)
1170
set form(select_frame) $item
1171
listbox $item.list -selectmode $mode -width 0 -exportselection 0 -cursor left_ptr
1172
HMwin_install $win $item
1176
# The values returned in the query may be different from those
1177
# displayed in the listbox, so we need to keep a separate list of
1179
# form(select_default) - contains the default query value
1180
# form(select_frame) - name of the listbox's containing frame
1181
# form(select_values) - list of query values
1182
# params: VALUE, SELECTED
1184
proc HMtag_option {win param text} {
1186
upvar #0 $var(form_id) form
1188
set frame $form(select_frame)
1190
# set default option (or options)
1191
if {[HMextract_param $param selected]} {
1192
lappend form(select_default) [$form(select_frame).list size]
1194
set value [string trimright $data " \n"]
1195
$frame.list insert end $value
1196
HMextract_param $param value
1197
lappend form(select_values) $value
1201
# do most of the work here!
1202
# if SIZE>1, make the listbox. Otherwise make a "drop-down"
1203
# listbox with a label in it
1204
# If the # of items > size, add a scroll bar
1205
# This should probably be broken up into callbacks to make it
1206
# easier to override the "look".
1208
proc HMtag_/select {win param text} {
1210
upvar #0 $var(form_id) form
1211
set frame $form(select_frame)
1212
set size $form(select_size)
1213
set items [$frame.list size]
1215
# set the defaults and reset button
1216
append form(reset) ";$frame.list selection clear 0 $items"
1217
if {[info exists form(select_default)]} {
1218
foreach i $form(select_default) {
1219
$frame.list selection set $i
1220
append form(reset) ";$frame.list selection set $i"
1223
$frame.list selection set 0
1224
append form(reset) ";$frame.list selection set 0"
1227
# set up the submit button. This is the general case. For single
1228
# selections we could be smarter
1230
for {set i 0} {$i < $size} {incr i} {
1231
set value [format {[expr {[%s selection includes %s] ? {%s} : {}}]} \
1232
$frame.list $i [lindex $form(select_values) $i]]
1233
lappend form(submit) [list $form(select_name) $value]
1236
# show the listbox - no scroll bar
1238
if {$size > 1 && $items <= $size} {
1239
$frame.list configure -height $items
1242
# Listbox with scrollbar
1244
} elseif {$size > 1} {
1245
scrollbar $frame.scroll -command "$frame.list yview" \
1246
-orient v -takefocus 0
1247
$frame.list configure -height $size \
1248
-yscrollcommand "$frame.scroll set"
1249
pack $frame.list $frame.scroll -side right -fill y
1254
scrollbar $frame.scroll -command "$frame.list yview" \
1255
-orient h -takefocus 0
1256
$frame.list configure -height 1 \
1257
-yscrollcommand "$frame.scroll set"
1258
pack $frame.list $frame.scroll -side top -fill x
1263
foreach i [array names form select_*] {
1268
# do a text area (multi-line text)
1269
# params: COLS, NAME, ROWS (all reqd, but default rows and cols anyway)
1271
proc HMtag_textarea {win param text} {
1273
upvar #0 $var(form_id) form
1276
set rows 5; HMextract_param $param rows
1277
set cols 30; HMextract_param $param cols
1278
HMextract_param $param name
1279
set item $win.textarea,$var(tags)
1281
text $item.text -width $cols -height $rows -wrap none \
1282
-yscrollcommand "$item.scroll set" -padx 3 -pady 3
1283
scrollbar $item.scroll -command "$item.text yview" -orient v
1284
$item.text insert 1.0 $data
1285
HMwin_install $win $item
1286
pack $item.text $item.scroll -side right -fill y
1287
lappend form(submit) [list $name "\[$item.text get 0.0 end]"]
1288
append form(reset) ";$item.text delete 1.0 end; \
1289
$item.text insert 1.0 [list $data]"
1293
# procedure to install windows into the text widget
1294
# - win: name of the text widget
1295
# - item: name of widget to install
1297
proc HMwin_install {win item} {
1299
$win window create $var(S_insert) -window $item -align bottom
1300
$win tag add indent$var(level) $item
1301
set focus [expr {[winfo class $item] != "Frame"}]
1302
$item configure -takefocus $focus
1303
bind $item <FocusIn> "$win see $item"
1306
#####################################################################
1307
# Assemble and submit the query
1308
# each list element in "stuff" is a name/value pair
1309
# - The names are the NAME parameters of the various fields
1310
# - The values get run through "subst" to extract the values
1311
# - We do the user callback with the list of name value pairs
1313
proc HMsubmit_button {win form_id param stuff} {
1315
upvar #0 $form_id form
1317
foreach pair $stuff {
1318
set value [subst [lindex $pair 1]]
1319
#if {$value != ""} {
1320
set item [lindex $pair 0]
1321
lappend query $item $value
1324
# this is the user callback.
1325
HMsubmit_form $win $param $query
1328
# sample user callback for form submission
1329
# should be replaced by the application
1330
# Sample version generates a string suitable for http
1332
proc HMsubmit_form {win param query} {
1336
append result $sep [HMmap_reply $i]
1337
if {$sep != "="} {set sep =} {set sep &}
1342
# do x-www-urlencoded character mapping
1343
# The spec says: "non-alphanumeric characters are replaced by '%HH'"
1345
set HMalphanumeric a-zA-Z0-9 ;# definition of alphanumeric character class
1346
for {set i 1} {$i <= 256} {incr i} {
1347
set c [format %c $i]
1348
if {![string match \[$HMalphanumeric\] $c]} {
1349
set HMform_map($c) %[format %.2x $i]
1353
# These are handled specially
1354
array set HMform_map {
1358
# 1 leave alphanumerics characters alone
1359
# 2 Convert every other character to an array lookup
1360
# 3 Escape constructs that are "special" to the tcl parser
1361
# 4 "subst" the result, doing all the array substitutions
1363
proc HMmap_reply {string} {
1364
global HMform_map HMalphanumeric
1365
regsub -all \[^$HMalphanumeric\] $string {$HMform_map(&)} string
1366
regsub -all \n $string {\\n} string
1367
regsub -all \t $string {\\t} string
1368
regsub -all {[][{})\\]\)} $string {\\&} string
1369
return [subst $string]
1372
# convert a x-www-urlencoded string int a a list of name/value pairs
1374
# 1 convert a=b&c=d... to {a} {b} {c} {d}...
1375
# 2, convert + to " "
1376
# 3, convert %xx to char equiv
1378
proc HMcgiDecode {data} {
1379
set data [split $data "&="]
1381
lappend result [cgiMap $i]
1386
proc HMcgiMap {data} {
1387
regsub -all {\+} $data " " data
1389
if {[regexp % $data]} {
1390
regsub -all {([][$\\])} $data {\\\1} data
1391
regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
1392
return [subst $data]
1398
# There is a bug in the tcl library focus routines that prevents focus
1399
# from every reaching an un-viewable window. Use our *own*
1400
# version of the library routine, until the bug is fixed, make sure we
1401
# over-ride the library version, and not the otherway around
1405
set code [catch {$w cget -takefocus} value]
1406
if {($code == 0) && ($value != "")} {
1409
} elseif {$value == 1} {
1412
set value [uplevel #0 $value $w]
1418
set code [catch {$w cget -state} value]
1419
if {($code == 0) && ($value == "disabled")} {
1422
regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
added
removed
vector/v.digit/html_library.tcl
