1# html.tcl -- 2# 3# Procedures to make generating HTML easier. 4# 5# This module depends on the ncgi module for the procedures 6# that initialize form elements based on current CGI values. 7# 8# Copyright (c) 1998-2000 by Ajuba Solutions. 9# Copyright (c) 2006 Michael Schlenker <mic42@users.sourceforge.net> 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13# 14# Originally by Brent Welch, with help from Dan Kuchler and Melissa Chawla 15 16package require Tcl 8.2 17package require ncgi 18package provide html 1.4 19 20namespace eval ::html { 21 22 # State about the current page 23 24 variable page 25 26 # A simple set of global defaults for tag parameters is implemented 27 # by storing into elements indexed by "key.param", where key is 28 # often the name of an HTML tag (anything for scoping), and 29 # param must be the name of the HTML tag parameter (e.g., "href" or "size") 30 # input.size 31 # body.bgcolor 32 # body.text 33 # font.face 34 # font.size 35 # font.color 36 37 variable defaults 38 array set defaults { 39 input.size 45 40 body.bgcolor white 41 body.text black 42 } 43 44 # In order to nandle nested calls to redefined control structures, 45 # we need a temporary variable that is known not to exist. We keep this 46 # counter to append to the varname. Each time we need a temporary 47 # variable, we increment this counter. 48 49 variable randVar 0 50 51 # No more export, because this defines things like 52 # foreach and if that do HTML things, not Tcl control 53 # namespace export * 54 55 # Dictionary mapping from special characters to their entities. 56 57 variable entities { 58 \xa0 \xa1 ¡ \xa2 ¢ \xa3 £ \xa4 ¤ 59 \xa5 ¥ \xa6 ¦ \xa7 § \xa8 ¨ \xa9 © 60 \xaa ª \xab « \xac ¬ \xad ­ \xae ® 61 \xaf ¯ \xb0 ° \xb1 ± \xb2 ² \xb3 ³ 62 \xb4 ´ \xb5 µ \xb6 ¶ \xb7 · \xb8 ¸ 63 \xb9 ¹ \xba º \xbb » \xbc ¼ \xbd ½ 64 \xbe ¾ \xbf ¿ \xc0 À \xc1 Á \xc2  65 \xc3 à \xc4 Ä \xc5 Å \xc6 Æ \xc7 Ç 66 \xc8 È \xc9 É \xca Ê \xcb Ë \xcc Ì 67 \xcd Í \xce Î \xcf Ï \xd0 Ð \xd1 Ñ 68 \xd2 Ò \xd3 Ó \xd4 Ô \xd5 Õ \xd6 Ö 69 \xd7 × \xd8 Ø \xd9 Ù \xda Ú \xdb Û 70 \xdc Ü \xdd Ý \xde Þ \xdf ß \xe0 à 71 \xe1 á \xe2 â \xe3 ã \xe4 ä \xe5 å 72 \xe6 æ \xe7 ç \xe8 è \xe9 é \xea ê 73 \xeb ë \xec ì \xed í \xee î \xef ï 74 \xf0 ð \xf1 ñ \xf2 ò \xf3 ó \xf4 ô 75 \xf5 õ \xf6 ö \xf7 ÷ \xf8 ø \xf9 ù 76 \xfa ú \xfb û \xfc ü \xfd ý \xfe þ 77 \xff ÿ \u192 ƒ \u391 Α \u392 Β \u393 Γ 78 \u394 Δ \u395 Ε \u396 Ζ \u397 Η \u398 Θ 79 \u399 Ι \u39A Κ \u39B Λ \u39C Μ \u39D Ν 80 \u39E Ξ \u39F Ο \u3A0 Π \u3A1 Ρ \u3A3 Σ 81 \u3A4 Τ \u3A5 Υ \u3A6 Φ \u3A7 Χ \u3A8 Ψ 82 \u3A9 Ω \u3B1 α \u3B2 β \u3B3 γ \u3B4 δ 83 \u3B5 ε \u3B6 ζ \u3B7 η \u3B8 θ \u3B9 ι 84 \u3BA κ \u3BB λ \u3BC μ \u3BD ν \u3BE ξ 85 \u3BF ο \u3C0 π \u3C1 ρ \u3C2 ς \u3C3 σ 86 \u3C4 τ \u3C5 υ \u3C6 φ \u3C7 χ \u3C8 ψ 87 \u3C9 ω \u3D1 ϑ \u3D2 ϒ \u3D6 ϖ 88 \u2022 • \u2026 … \u2032 ′ \u2033 ″ 89 \u203E ‾ \u2044 ⁄ \u2118 ℘ \u2111 ℑ 90 \u211C ℜ \u2122 ™ \u2135 ℵ \u2190 ← 91 \u2191 ↑ \u2192 → \u2193 ↓ \u2194 ↔ \u21B5 ↵ 92 \u21D0 ⇐ \u21D1 ⇑ \u21D2 ⇒ \u21D3 ⇓ \u21D4 ⇔ 93 \u2200 ∀ \u2202 ∂ \u2203 ∃ \u2205 ∅ 94 \u2207 ∇ \u2208 ∈ \u2209 ∉ \u220B ∋ \u220F ∏ 95 \u2211 ∑ \u2212 − \u2217 ∗ \u221A √ 96 \u221D ∝ \u221E ∞ \u2220 ∠ \u2227 ∧ \u2228 ∨ 97 \u2229 ∩ \u222A ∪ \u222B ∫ \u2234 ∴ \u223C ∼ 98 \u2245 ≅ \u2248 ≈ \u2260 ≠ \u2261 ≡ \u2264 ≤ 99 \u2265 ≥ \u2282 ⊂ \u2283 ⊃ \u2284 ⊄ \u2286 ⊆ 100 \u2287 ⊇ \u2295 ⊕ \u2297 ⊗ \u22A5 ⊥ 101 \u22C5 ⋅ \u2308 ⌈ \u2309 ⌉ \u230A ⌊ 102 \u230B ⌋ \u2329 ⟨ \u232A ⟩ \u25CA ◊ 103 \u2660 ♠ \u2663 ♣ \u2665 ♥ \u2666 ♦ 104 \x22 " \x26 & \x3C < \x3E > \u152 Œ 105 \u153 œ \u160 Š \u161 š \u178 Ÿ 106 \u2C6 ˆ \u2DC ˜ \u2002   \u2003   \u2009   107 \u200C ‌ \u200D ‍ \u200E ‎ \u200F ‏ \u2013 – 108 \u2014 — \u2018 ‘ \u2019 ’ \u201A ‚ 109 \u201C “ \u201D ” \u201E „ \u2020 † 110 \u2021 ‡ \u2030 ‰ \u2039 ‹ \u203A › 111 \u20AC € 112 } 113} 114 115# ::html::foreach 116# 117# Rework the "foreach" command to blend into HTML template files. 118# Rather than evaluating the body, we return the subst'ed body. Each 119# iteration of the loop causes another string to be concatenated to 120# the result value. No error checking is done on any arguments. 121# 122# Arguments: 123# varlist Variables to instantiate with values from the next argument. 124# list Values to set variables in varlist to. 125# args ?varlist2 list2 ...? body, where body is the string to subst 126# during each iteration of the loop. 127# 128# Results: 129# Returns a string composed of multiple concatenations of the 130# substitued body. 131# 132# Side Effects: 133# None. 134 135proc ::html::foreach {vars vals args} { 136 variable randVar 137 138 # The body of the foreach loop must be run in the stack frame 139 # above this one in order to have access to local variable at that stack 140 # level. 141 142 # To support nested foreach loops, we use a uniquely named 143 # variable to store incremental results. 144 incr randVar 145 ::set resultVar "result_$randVar" 146 147 # Extract the body and any varlists and valuelists from the args. 148 ::set body [lindex $args end] 149 ::set varvals [linsert [lreplace $args end end] 0 $vars $vals] 150 151 # Create the script to eval in the stack frame above this one. 152 ::set script "::foreach" 153 ::foreach {vars vals} $varvals { 154 append script " [list $vars] [list $vals]" 155 } 156 append script " \{\n" 157 append script " append $resultVar \[subst \{$body\}\]\n" 158 append script "\}\n" 159 160 # Create a temporary variable in the stack frame above this one, 161 # and use it to store the incremental results of the multiple loop 162 # iterations. Remove the temporary variable when we're done so there's 163 # no trace of this loop left in that stack frame. 164 165 upvar 1 $resultVar tmp 166 ::set tmp "" 167 uplevel 1 $script 168 ::set result $tmp 169 unset tmp 170 return $result 171} 172 173# ::html::for 174# 175# Rework the "for" command to blend into HTML template files. 176# Rather than evaluating the body, we return the subst'ed body. Each 177# iteration of the loop causes another string to be concatenated to 178# the result value. No error checking is done on any arguments. 179# 180# Arguments: 181# start A script to evaluate once at the very beginning. 182# test An expression to eval before each iteration of the loop. 183# Once the expression is false, the command returns. 184# next A script to evaluate after each iteration of the loop. 185# body The string to subst during each iteration of the loop. 186# 187# Results: 188# Returns a string composed of multiple concatenations of the 189# substitued body. 190# 191# Side Effects: 192# None. 193 194proc ::html::for {start test next body} { 195 variable randVar 196 197 # The body of the for loop must be run in the stack frame 198 # above this one in order to have access to local variable at that stack 199 # level. 200 201 # To support nested for loops, we use a uniquely named 202 # variable to store incremental results. 203 incr randVar 204 ::set resultVar "result_$randVar" 205 206 # Create the script to eval in the stack frame above this one. 207 ::set script "::for [list $start] [list $test] [list $next] \{\n" 208 append script " append $resultVar \[subst \{$body\}\]\n" 209 append script "\}\n" 210 211 # Create a temporary variable in the stack frame above this one, 212 # and use it to store the incremental resutls of the multiple loop 213 # iterations. Remove the temporary variable when we're done so there's 214 # no trace of this loop left in that stack frame. 215 216 upvar 1 $resultVar tmp 217 ::set tmp "" 218 uplevel 1 $script 219 ::set result $tmp 220 unset tmp 221 return $result 222} 223 224# ::html::while 225# 226# Rework the "while" command to blend into HTML template files. 227# Rather than evaluating the body, we return the subst'ed body. Each 228# iteration of the loop causes another string to be concatenated to 229# the result value. No error checking is done on any arguments. 230# 231# Arguments: 232# test An expression to eval before each iteration of the loop. 233# Once the expression is false, the command returns. 234# body The string to subst during each iteration of the loop. 235# 236# Results: 237# Returns a string composed of multiple concatenations of the 238# substitued body. 239# 240# Side Effects: 241# None. 242 243proc ::html::while {test body} { 244 variable randVar 245 246 # The body of the while loop must be run in the stack frame 247 # above this one in order to have access to local variable at that stack 248 # level. 249 250 # To support nested while loops, we use a uniquely named 251 # variable to store incremental results. 252 incr randVar 253 ::set resultVar "result_$randVar" 254 255 # Create the script to eval in the stack frame above this one. 256 ::set script "::while [list $test] \{\n" 257 append script " append $resultVar \[subst \{$body\}\]\n" 258 append script "\}\n" 259 260 # Create a temporary variable in the stack frame above this one, 261 # and use it to store the incremental resutls of the multiple loop 262 # iterations. Remove the temporary variable when we're done so there's 263 # no trace of this loop left in that stack frame. 264 265 upvar 1 $resultVar tmp 266 ::set tmp "" 267 uplevel 1 $script 268 ::set result $tmp 269 unset tmp 270 return $result 271} 272 273# ::html::if 274# 275# Rework the "if" command to blend into HTML template files. 276# Rather than evaluating a body clause, we return the subst'ed body. 277# No error checking is done on any arguments. 278# 279# Arguments: 280# test An expression to eval to decide whether to use the then body. 281# body The string to subst if the test case was true. 282# args ?elseif test body2 ...? ?else bodyn?, where bodyn is the string 283# to subst if none of the tests are true. 284# 285# Results: 286# Returns a string composed by substituting a body clause. 287# 288# Side Effects: 289# None. 290 291proc ::html::if {test body args} { 292 variable randVar 293 294 # The body of the then/else clause must be run in the stack frame 295 # above this one in order to have access to local variable at that stack 296 # level. 297 298 # To support nested if's, we use a uniquely named 299 # variable to store incremental results. 300 incr randVar 301 ::set resultVar "result_$randVar" 302 303 # Extract the elseif clauses and else clause if they exist. 304 ::set cmd [linsert $args 0 "::if" $test $body] 305 306 ::foreach {keyword test body} $cmd { 307 ::if {[string equal $keyword "else"]} { 308 append script " else \{\n" 309 ::set body $test 310 } else { 311 append script " $keyword [list $test] \{\n" 312 } 313 append script " append $resultVar \[subst \{$body\}\]\n" 314 append script "\} " 315 } 316 317 # Create a temporary variable in the stack frame above this one, 318 # and use it to store the incremental resutls of the multiple loop 319 # iterations. Remove the temporary variable when we're done so there's 320 # no trace of this loop left in that stack frame. 321 322 upvar $resultVar tmp 323 ::set tmp "" 324 uplevel $script 325 ::set result $tmp 326 unset tmp 327 return $result 328} 329 330# ::html::set 331# 332# Rework the "set" command to blend into HTML template files. 333# The return value is always "" so nothing is appended in the 334# template. No error checking is done on any arguments. 335# 336# Arguments: 337# var The variable to set. 338# val The new value to give the variable. 339# 340# Results: 341# Returns "". 342# 343# Side Effects: 344# None. 345 346proc ::html::set {var val} { 347 348 # The variable must be set in the stack frame above this one. 349 350 ::set cmd [list set $var $val] 351 uplevel 1 $cmd 352 return "" 353} 354 355# ::html::eval 356# 357# Rework the "eval" command to blend into HTML template files. 358# The return value is always "" so nothing is appended in the 359# template. No error checking is done on any arguments. 360# 361# Arguments: 362# args The args to evaluate. At least one must be given. 363# 364# Results: 365# Returns "". 366# 367# Side Effects: 368# Throws an error if no arguments are given. 369 370proc ::html::eval {args} { 371 372 # The args must be evaluated in the stack frame above this one. 373 ::eval [linsert $args 0 uplevel 1] 374 return "" 375} 376 377# ::html::init 378# 379# Reset state that gets accumulated for the current page. 380# 381# Arguments: 382# nvlist Name, value list that is used to initialize default namespace 383# variables that set font, size, etc. 384# 385# Side Effects: 386# Wipes the page state array 387 388proc ::html::init {{nvlist {}}} { 389 variable page 390 variable defaults 391 ::if {[info exists page]} { 392 unset page 393 } 394 ::if {[info exists defaults]} { 395 unset defaults 396 } 397 array set defaults $nvlist 398} 399 400# ::html::head 401# 402# Generate the <head> section. There are a number of 403# optional calls you make *before* this to inject 404# meta tags - see everything between here and the bodyTag proc. 405# 406# Arguments: 407# title The page title 408# 409# Results: 410# HTML for the <head> section 411 412proc ::html::head {title} { 413 variable page 414 ::set html "[openTag html][openTag head]\n" 415 append html "\t[title $title]" 416 ::if {[info exists page(author)]} { 417 append html "\t$page(author)" 418 } 419 ::if {[info exists page(meta)]} { 420 ::foreach line $page(meta) { 421 append html "\t$line\n" 422 } 423 } 424 ::if {[info exists page(css)]} { 425 ::foreach style $page(css) { 426 append html "\t$style\n" 427 } 428 } 429 ::if {[info exists page(js)]} { 430 ::foreach script $page(js) { 431 append html "\t$script\n" 432 } 433 } 434 append html "[closeTag]\n" 435} 436 437# ::html::title 438# 439# Wrap up the <title> and tuck it away for use in the page later. 440# 441# Arguments: 442# title The page title 443# 444# Results: 445# HTML for the <title> section 446 447proc ::html::title {title} { 448 variable page 449 ::set page(title) $title 450 ::set html "<title>$title</title>\n" 451 return $html 452} 453 454# ::html::getTitle 455# 456# Return the title of the current page. 457# 458# Arguments: 459# None 460# 461# Results: 462# The title 463 464proc ::html::getTitle {} { 465 variable page 466 ::if {[info exists page(title)]} { 467 return $page(title) 468 } else { 469 return "" 470 } 471} 472 473# ::html::meta 474# 475# Generate a meta tag. This tag gets bundled into the <head> 476# section generated by html::head 477# 478# Arguments: 479# args A name-value list of meta tag names and values. 480# 481# Side Effects: 482# Stores HTML for the <meta> tag for use later by html::head 483 484proc ::html::meta {args} { 485 variable page 486 ::set html "" 487 ::foreach {name value} $args { 488 append html "<meta name=\"$name\" content=\"[quoteFormValue $value]\">" 489 } 490 lappend page(meta) $html 491 return "" 492} 493 494# ::html::refresh 495# 496# Generate a meta refresh tag. This tag gets bundled into the <head> 497# section generated by html::head 498# 499# Arguments: 500# content Time period, in seconds, before the refresh 501# url (option) new page to view. If not specified, then 502# the current page is reloaded. 503# 504# Side Effects: 505# Stores HTML for the <meta> tag for use later by html::head 506 507proc ::html::refresh {content {url {}}} { 508 variable page 509 ::set html "<meta http-equiv=\"Refresh\" content=\"$content" 510 ::if {[string length $url]} { 511 append html "; url=$url" 512 } 513 append html "\">\n" 514 lappend page(meta) $html 515 return "" 516} 517 518# ::html::headTag 519# 520# Embed a tag into the HEAD section 521# generated by html::head 522# 523# Arguments: 524# string Everything but the < > for the tag. 525# 526# Side Effects: 527# Stores HTML for the tag for use later by html::head 528 529proc ::html::headTag {string} { 530 variable page 531 lappend page(meta) <$string> 532 return "" 533} 534 535# ::html::keywords 536# 537# Add META tag keywords to the <head> section. 538# Call this before you call html::head 539# 540# Arguments: 541# args The keywords 542# 543# Side Effects: 544# See html::meta 545 546proc ::html::keywords {args} { 547 html::meta keywords [join $args ", "] 548} 549 550# ::html::description 551# 552# Add a description META tag to the <head> section. 553# Call this before you call html::head 554# 555# Arguments: 556# description The description 557# 558# Side Effects: 559# See html::meta 560 561proc ::html::description {description} { 562 html::meta description $description 563} 564 565# ::html::author 566# 567# Add an author comment to the <head> section. 568# Call this before you call html::head 569# 570# Arguments: 571# author Author's name 572# 573# Side Effects: 574# sets page(author) 575 576proc ::html::author {author} { 577 variable page 578 ::set page(author) "<!-- $author -->\n" 579 return "" 580} 581 582# ::html::tagParam 583# 584# Return a name, value string for the tag parameters. 585# The values come from "hard-wired" values in the 586# param agrument, or from the defaults set with html::init. 587# 588# Arguments: 589# tag Name of the HTML tag (case insensitive). 590# param pname=value info that overrides any default values 591# 592# Results 593# A string of the form: 594# pname="keyvalue" name2="2nd value" 595 596proc ::html::tagParam {tag {param {}}} { 597 variable defaults 598 599 ::set def "" 600 ::foreach key [lsort [array names defaults $tag.*]] { 601 append def [default $key $param] 602 } 603 return [string trimleft $param$def] 604} 605 606# ::html::default 607# 608# Return a default value, if one has been registered 609# and an overriding value does not occur in the existing 610# tag parameters. 611# 612# Arguments: 613# key Index into the defaults array defined by html::init 614# This is expected to be in the form tag.pname where 615# the pname part is used in the tag parameter name 616# param pname=value info that overrides any default values 617# 618# Results 619# pname="keyvalue" 620 621proc ::html::default {key {param {}}} { 622 variable defaults 623 ::set pname [string tolower [lindex [split $key .] 1]] 624 ::set key [string tolower $key] 625 ::if {![regexp -nocase "(\[ \]|^)$pname=" $param] && 626 [info exists defaults($key)] && 627 [string length $defaults($key)]} { 628 return " $pname=\"$defaults($key)\"" 629 } else { 630 return "" 631 } 632} 633 634# ::html::bodyTag 635# 636# Generate a body tag 637# 638# Arguments: 639# none 640# 641# Results 642# A body tag 643 644proc ::html::bodyTag {args} { 645 return [openTag body [join $args]]\n 646} 647 648# The following procedures are all related to generating form elements 649# that are initialized to store the current value of the form element 650# based on the CGI state. These functions depend on the ncgi::value 651# procedure and assume that the caller has called ncgi::parse and/or 652# ncgi::init appropriately to initialize the ncgi module. 653 654# ::html::formValue 655# 656# Return a name and value pair, where the value is initialized 657# from existing form data, if any. 658# 659# Arguments: 660# name The name of the form element 661# defvalue A default value to use, if not appears in the CGI 662# inputs. DEPRECATED - use ncgi::defValue instead. 663# 664# Retults: 665# A string like: 666# name="fred" value="freds value" 667 668proc ::html::formValue {name {defvalue {}}} { 669 ::set value [ncgi::value $name] 670 ::if {[string length $value] == 0} { 671 ::set value $defvalue 672 } 673 return "name=\"$name\" value=\"[quoteFormValue $value]\"" 674} 675 676# ::html::quoteFormValue 677# 678# Quote a value for use in a value=\"$value\" fragment. 679# 680# Arguments: 681# value The value to quote 682# 683# Retults: 684# A string like: 685# "Hello, <b>World!" 686 687proc ::html::quoteFormValue {value} { 688 return [string map [list "&" "&" "\"" """ \ 689 "'" "'" "<" "<" ">" ">"] $value] 690} 691 692# ::html::textInput -- 693# 694# Return an <input type=text> element. This uses the 695# input.size default falue. 696# 697# Arguments: 698# name The form element name 699# args Additional attributes for the INPUT tag 700# 701# Results: 702# The html fragment 703 704proc ::html::textInput {name {value {}} args} { 705 ::set html "<input type=\"text\" " 706 append html [formValue $name $value] 707 append html [default input.size $args] 708 ::if {[llength $args] != 0} then { 709 append html " " [join $args] 710 } 711 append html ">\n" 712 return $html 713} 714 715# ::html::textInputRow -- 716# 717# Format a table row containing a text input element and a label. 718# 719# Arguments: 720# label Label to display next to the form element 721# name The form element name 722# args Additional attributes for the INPUT tag 723# 724# Results: 725# The html fragment 726 727proc ::html::textInputRow {label name {value {}} args} { 728 ::set html [row $label [::eval [linsert $args 0 html::textInput $name $value]]] 729 return $html 730} 731 732# ::html::passwordInputRow -- 733# 734# Format a table row containing a password input element and a label. 735# 736# Arguments: 737# label Label to display next to the form element 738# name The form element name 739# 740# Results: 741# The html fragment 742 743proc ::html::passwordInputRow {label {name password}} { 744 ::set html [row $label [passwordInput $name]] 745 return $html 746} 747 748# ::html::passwordInput -- 749# 750# Return an <input type=password> element. 751# 752# Arguments: 753# name The form element name. Defaults to "password" 754# 755# Results: 756# The html fragment 757 758proc ::html::passwordInput {{name password}} { 759 ::set html "<input type=\"password\" name=\"$name\">\n" 760 return $html 761} 762 763# ::html::checkbox -- 764# 765# Format a checkbox so that it retains its state based on 766# the current CGI values 767# 768# Arguments: 769# name The form element name 770# value The value associated with the checkbox 771# 772# Results: 773# The html fragment 774 775proc ::html::checkbox {name value} { 776 ::set html "<input type=\"checkbox\" [checkValue $name $value]>\n" 777} 778 779# ::html::checkValue 780# 781# Like html::formalue, but for checkboxes that need CHECKED 782# 783# Arguments: 784# name The name of the form element 785# defvalue A default value to use, if not appears in the CGI 786# inputs 787# 788# Retults: 789# A string like: 790# name="fred" value="freds value" CHECKED 791 792 793proc ::html::checkValue {name {value 1}} { 794 ::foreach v [ncgi::valueList $name] { 795 ::if {[string compare $value $v] == 0} { 796 return "name=\"$name\" value=\"[quoteFormValue $value]\" checked" 797 } 798 } 799 return "name=\"$name\" value=\"[quoteFormValue $value]\"" 800} 801 802# ::html::radioValue 803# 804# Like html::formValue, but for radioboxes that need CHECKED 805# 806# Arguments: 807# name The name of the form element 808# value The value associated with the radio button. 809# 810# Retults: 811# A string like: 812# name="fred" value="freds value" CHECKED 813 814proc ::html::radioValue {name value {defaultSelection {}}} { 815 ::if {[string equal $value [ncgi::value $name $defaultSelection]]} { 816 return "name=\"$name\" value=\"[quoteFormValue $value]\" checked" 817 } else { 818 return "name=\"$name\" value=\"[quoteFormValue $value]\"" 819 } 820} 821 822# ::html::radioSet -- 823# 824# Display a set of radio buttons while looking for an existing 825# value from the query data, if any. 826 827proc ::html::radioSet {key sep list {defaultSelection {}}} { 828 ::set html "" 829 ::set s "" 830 ::foreach {label v} $list { 831 append html "$s<input type=\"radio\" [radioValue $key $v $defaultSelection]> $label" 832 ::set s $sep 833 } 834 return $html 835} 836 837# ::html::checkSet -- 838# 839# Display a set of check buttons while looking for an existing 840# value from the query data, if any. 841 842proc ::html::checkSet {key sep list} { 843 ::set s "" 844 ::foreach {label v} $list { 845 append html "$s<input type=\"checkbox\" [checkValue $key $v]> $label" 846 ::set s $sep 847 } 848 return $html 849} 850 851# ::html::select -- 852# 853# Format a <select> element that retains the state of the 854# current CGI values. 855# 856# Arguments: 857# name The form element name 858# param The various size, multiple parameters for the tag 859# choices A simple list of choices 860# current Value to assume if nothing is in CGI state 861# 862# Results: 863# The html fragment 864 865proc ::html::select {name param choices {current {}}} { 866 ::set def [ncgi::valueList $name $current] 867 ::set html "<select name=\"$name\"[string trimright " $param"]>\n" 868 ::foreach {label v} $choices { 869 ::if {[lsearch -exact $def $v] != -1} { 870 ::set SEL " selected" 871 } else { 872 ::set SEL "" 873 } 874 append html "<option value=\"$v\"$SEL>$label\n" 875 } 876 append html "</select>\n" 877 return $html 878} 879 880# ::html::selectPlain -- 881# 882# Format a <select> element where the values are the same 883# as those that are displayed. 884# 885# Arguments: 886# name The form element name 887# param Tag parameters 888# choices A simple list of choices 889# 890# Results: 891# The html fragment 892 893proc ::html::selectPlain {name param choices {current {}}} { 894 ::set namevalue {} 895 ::foreach c $choices { 896 lappend namevalue $c $c 897 } 898 return [select $name $param $namevalue $current] 899} 900 901# ::html::textarea -- 902# 903# Format a <textarea> element that retains the state of the 904# current CGI values. 905# 906# Arguments: 907# name The form element name 908# param The various size, multiple parameters for the tag 909# current Value to assume if nothing is in CGI state 910# 911# Results: 912# The html fragment 913 914proc ::html::textarea {name {param {}} {current {}}} { 915 ::set value [ncgi::value $name $current] 916 return "<[string trimright \ 917 "textarea name=\"$name\"\ 918 [tagParam textarea $param]"]>$value</textarea>\n" 919} 920 921# ::html::submit -- 922# 923# Format a submit button. 924# 925# Arguments: 926# label The string to appear in the submit button. 927# name The name for the submit button element 928# 929# Results: 930# The html fragment 931 932 933proc ::html::submit {label {name submit}} { 934 ::set html "<input type=\"submit\" name=\"$name\" value=\"$label\">\n" 935} 936 937# ::html::varEmpty -- 938# 939# Return true if the variable doesn't exist or is an empty string 940# 941# Arguments: 942# varname Name of the variable 943# 944# Results: 945# 1 if the variable doesn't exist or has the empty value 946 947proc ::html::varEmpty {name} { 948 upvar 1 $name var 949 ::if {[info exists var]} { 950 ::set value $var 951 } else { 952 ::set value "" 953 } 954 return [expr {[string length [string trim $value]] == 0}] 955} 956 957# ::html::getFormInfo -- 958# 959# Generate hidden fields to capture form values. 960# 961# Arguments: 962# args List of elements to save. If this is empty, everything is 963# saved in hidden fields. This is a list of string match 964# patterns. 965# 966# Results: 967# A bunch of <input type=hidden> elements 968 969proc ::html::getFormInfo {args} { 970 ::if {[llength $args] == 0} { 971 ::set args * 972 } 973 ::set html "" 974 ::foreach {n v} [ncgi::nvlist] { 975 ::foreach pat $args { 976 ::if {[string match $pat $n]} { 977 append html "<input type=\"hidden\" name=\"$n\" \ 978 value=\"[quoteFormValue $v]\">\n" 979 } 980 } 981 } 982 return $html 983} 984 985# ::html::h1 986# Generate an H1 tag. 987# 988# Arguments: 989# string 990# param 991# 992# Results: 993# Formats the tag. 994 995proc ::html::h1 {string {param {}}} { 996 html::h 1 $string $param 997} 998proc ::html::h2 {string {param {}}} { 999 html::h 2 $string $param 1000} 1001proc ::html::h3 {string {param {}}} { 1002 html::h 3 $string $param 1003} 1004proc ::html::h4 {string {param {}}} { 1005 html::h 4 $string $param 1006} 1007proc ::html::h5 {string {param {}}} { 1008 html::h 5 $string $param 1009} 1010proc ::html::h6 {string {param {}}} { 1011 html::h 6 $string $param 1012} 1013proc ::html::h {level string {param {}}} { 1014 return "<[string trimright "h$level [tagParam h$level $param]"]>$string</h$level>\n" 1015} 1016 1017# ::html::openTag 1018# Remember that a tag is opened so it can be closed later. 1019# This is used to automatically clean up at the end of a page. 1020# 1021# Arguments: 1022# tag The HTML tag name 1023# param Any parameters for the tag 1024# 1025# Results: 1026# Formats the tag. Also keeps it around in a per-page stack 1027# of open tags. 1028 1029proc ::html::openTag {tag {param {}}} { 1030 variable page 1031 lappend page(stack) $tag 1032 return "<[string trimright "$tag [tagParam $tag $param]"]>" 1033} 1034 1035# ::html::closeTag 1036# Pop a tag from the stack and close it. 1037# 1038# Arguments: 1039# None 1040# 1041# Results: 1042# A close tag. Also pops the stack. 1043 1044proc ::html::closeTag {} { 1045 variable page 1046 ::if {[info exists page(stack)]} { 1047 ::set top [lindex $page(stack) end] 1048 ::set page(stack) [lreplace $page(stack) end end] 1049 } 1050 ::if {[info exists top] && [string length $top]} { 1051 return </$top> 1052 } else { 1053 return "" 1054 } 1055} 1056 1057# ::html::end 1058# 1059# Close out all the open tags. Especially useful for 1060# Tables that do not display at all if they are unclosed. 1061# 1062# Arguments: 1063# None 1064# 1065# Results: 1066# Some number of close HTML tags. 1067 1068proc ::html::end {} { 1069 variable page 1070 ::set html "" 1071 ::while {[llength $page(stack)]} { 1072 append html [closeTag]\n 1073 } 1074 return $html 1075} 1076 1077# ::html::row 1078# 1079# Format a table row. If the default font has been set, this 1080# takes care of wrapping the table cell contents in a font tag. 1081# 1082# Arguments: 1083# args Values to put into the row 1084# 1085# Results: 1086# A <tr><td>...</tr> fragment 1087 1088proc ::html::row {args} { 1089 ::set html <tr>\n 1090 ::foreach x $args { 1091 append html \t[cell "" $x td]\n 1092 } 1093 append html "</tr>\n" 1094 return $html 1095} 1096 1097# ::html::hdrRow 1098# 1099# Format a table row. If the default font has been set, this 1100# takes care of wrapping the table cell contents in a font tag. 1101# 1102# Arguments: 1103# args Values to put into the row 1104# 1105# Results: 1106# A <tr><th>...</tr> fragment 1107 1108proc ::html::hdrRow {args} { 1109 variable defaults 1110 ::set html <tr>\n 1111 ::foreach x $args { 1112 append html \t[cell "" $x th]\n 1113 } 1114 append html "</tr>\n" 1115 return $html 1116} 1117 1118# ::html::paramRow 1119# 1120# Format a table row. If the default font has been set, this 1121# takes care of wrapping the table cell contents in a font tag. 1122# 1123# Based on html::row 1124# 1125# Arguments: 1126# list Values to put into the row 1127# rparam Parameters for row 1128# cparam Parameters for cells 1129# 1130# Results: 1131# A <tr><td>...</tr> fragment 1132 1133proc ::html::paramRow {list {rparam {}} {cparam {}}} { 1134 ::set html "<tr $rparam>\n" 1135 ::foreach x $list { 1136 append html \t[cell $cparam $x td]\n 1137 } 1138 append html "</tr>\n" 1139 return $html 1140} 1141 1142# ::html::cell 1143# 1144# Format a table cell. If the default font has been set, this 1145# takes care of wrapping the table cell contents in a font tag. 1146# 1147# Arguments: 1148# param Td tag parameters 1149# value The value to put into the cell 1150# tag (option) defaults to TD 1151# 1152# Results: 1153# <td>...</td> fragment 1154 1155proc ::html::cell {param value {tag td}} { 1156 ::set font [font] 1157 ::if {[string length $font]} { 1158 ::set value $font$value</font> 1159 } 1160 return "<[string trimright "$tag $param"]>$value</$tag>" 1161} 1162 1163# ::html::tableFromArray 1164# 1165# Format a Tcl array into an HTML table 1166# 1167# Arguments: 1168# arrname The name of the array 1169# param The <table> tag parameters, if any. 1170# pat A string match pattern for the element keys 1171# 1172# Results: 1173# A <table> 1174 1175proc ::html::tableFromArray {arrname {param {}} {pat *}} { 1176 upvar 1 $arrname arr 1177 ::set html "" 1178 ::if {[info exists arr]} { 1179 append html "<table $param>\n" 1180 append html "<tr><th colspan=2>$arrname</th></tr>\n" 1181 ::foreach name [lsort [array names arr $pat]] { 1182 append html [row $name $arr($name)] 1183 } 1184 append html </table>\n 1185 } 1186 return $html 1187} 1188 1189# ::html::tableFromList 1190# 1191# Format a table from a name, value list 1192# 1193# Arguments: 1194# querylist A name, value list 1195# param The <table> tag parameters, if any. 1196# 1197# Results: 1198# A <table> 1199 1200proc ::html::tableFromList {querylist {param {}}} { 1201 ::set html "" 1202 ::if {[llength $querylist]} { 1203 append html "<table $param>" 1204 ::foreach {label value} $querylist { 1205 append html [row $label $value] 1206 } 1207 append html </table> 1208 } 1209 return $html 1210} 1211 1212# ::html::mailto 1213# 1214# Format a mailto: HREF tag 1215# 1216# Arguments: 1217# email The target 1218# subject The subject of the email, if any 1219# 1220# Results: 1221# A <a href=mailto> tag </a> 1222 1223proc ::html::mailto {email {subject {}}} { 1224 ::set html "<a href=\"mailto:$email" 1225 ::if {[string length $subject]} { 1226 append html ?subject=$subject 1227 } 1228 append html "\">$email</a>" 1229 return $html 1230} 1231 1232# ::html::font 1233# 1234# Generate a standard <font> tag. This depends on defaults being 1235# set via html::init 1236# 1237# Arguments: 1238# args Font parameters. 1239# 1240# Results: 1241# HTML 1242 1243proc ::html::font {args} { 1244 1245 # e.g., font.face, font.size, font.color 1246 ::set param [tagParam font [join $args]] 1247 1248 ::if {[string length $param]} { 1249 return "<[string trimright "font $param"]>" 1250 } else { 1251 return "" 1252 } 1253} 1254 1255# ::html::minorMenu 1256# 1257# Create a menu of links given a list of label, URL pairs. 1258# If the URL is the current page, it is not highlighted. 1259# 1260# Arguments: 1261# 1262# list List that alternates label, url, label, url 1263# sep Separator between elements 1264# 1265# Results: 1266# html 1267 1268proc ::html::minorMenu {list {sep { | }}} { 1269 ::set s "" 1270 ::set html "" 1271 regsub -- {index.h?tml$} [ncgi::urlStub] {} this 1272 ::foreach {label url} $list { 1273 regsub -- {index.h?tml$} $url {} that 1274 ::if {[string compare $this $that] == 0} { 1275 append html "$s$label" 1276 } else { 1277 append html "$s<a href=\"$url\">$label</a>" 1278 } 1279 ::set s $sep 1280 } 1281 return $html 1282} 1283 1284# ::html::minorList 1285# 1286# Create a list of links given a list of label, URL pairs. 1287# If the URL is the current page, it is not highlighted. 1288# 1289# Based on html::minorMenu 1290# 1291# Arguments: 1292# 1293# list List that alternates label, url, label, url 1294# ordered Boolean flag to choose between ordered and 1295# unordered lists. Defaults to 0, i.e. unordered. 1296# 1297# Results: 1298# A <ul><li><a...><\li>.....<\ul> fragment 1299# or a <ol><li><a...><\li>.....<\ol> fragment 1300 1301proc ::html::minorList {list {ordered 0}} { 1302 ::set s "" 1303 ::set html "" 1304 ::if { $ordered } { 1305 append html [openTag ol] 1306 } else { 1307 append html [openTag ul] 1308 } 1309 regsub -- {index.h?tml$} [ncgi::urlStub] {} this 1310 ::foreach {label url} $list { 1311 append html [openTag li] 1312 regsub -- {index.h?tml$} $url {} that 1313 ::if {[string compare $this $that] == 0} { 1314 append html "$s$label" 1315 } else { 1316 append html "$s<a href=\"$url\">$label</a>" 1317 } 1318 append html [closeTag] 1319 append html \n 1320 } 1321 append html [closeTag] 1322 return $html 1323} 1324 1325# ::html::extractParam 1326# 1327# Extract a value from parameter list (this needs a re-do) 1328# 1329# Arguments: 1330# param A parameter list. It should alredy have been processed to 1331# remove any entity references 1332# key The parameter name 1333# varName The variable to put the value into (use key as default) 1334# 1335# Results: 1336# returns "1" if the keyword is found, "0" otherwise 1337 1338proc ::html::extractParam {param key {varName ""}} { 1339 ::if {$varName == ""} { 1340 upvar $key result 1341 } else { 1342 upvar $varName result 1343 } 1344 ::set ws " \t\n\r" 1345 1346 # look for name=value combinations. Either (') or (") are valid delimeters 1347 ::if { 1348 [regsub -nocase [format {.*%s[%s]*=[%s]*"([^"]*).*} $key $ws $ws] $param {\1} value] || 1349 [regsub -nocase [format {.*%s[%s]*=[%s]*'([^']*).*} $key $ws $ws] $param {\1} value] || 1350 [regsub -nocase [format {.*%s[%s]*=[%s]*([^%s]+).*} $key $ws $ws $ws] $param {\1} value] } { 1351 ::set result $value 1352 return 1 1353 } 1354 1355 # now look for valueless names 1356 # I should strip out name=value pairs, so we don't end up with "name" 1357 # inside the "value" part of some other key word - some day 1358 1359 ::set bad \[^a-zA-Z\]+ 1360 ::if {[regexp -nocase "$bad$key$bad" -$param-]} { 1361 return 1 1362 } else { 1363 return 0 1364 } 1365} 1366 1367# ::html::urlParent -- 1368# This is like "file dirname", but doesn't screw with the slashes 1369# (file dirname will collapse // into /) 1370# 1371# Arguments: 1372# url The URL 1373# 1374# Results: 1375# The parent directory of the URL. 1376 1377proc ::html::urlParent {url} { 1378 ::set url [string trimright $url /] 1379 regsub -- {[^/]+$} $url {} url 1380 return $url 1381} 1382 1383# ::html::html_entities -- 1384# Replaces all special characters in the text with their 1385# entities. 1386# 1387# Arguments: 1388# s The near-HTML text 1389# 1390# Results: 1391# The text with entities in place of specials characters. 1392 1393proc ::html::html_entities {s} { 1394 variable entities 1395 return [string map $entities $s] 1396} 1397 1398# ::html::nl2br -- 1399# Replaces all line-endings in the text with <br> tags. 1400# 1401# Arguments: 1402# s The near-HTML text 1403# 1404# Results: 1405# The text with <br> in place of line-endings. 1406 1407proc ::html::nl2br {s} { 1408 return [string map [list \n\r <br> \n <br> \r <br>] $s] 1409} 1410 1411# ::html::doctype 1412# Create the DOCTYPE tag and tuck it away for usage 1413# 1414# Arguments: 1415# arg The DOCTYPE you want to declare 1416# 1417# Results: 1418# HTML for the doctype section 1419 1420proc ::html::doctype {arg} { 1421 variable doctypes 1422 set code [string toupper $arg] 1423 if {![info exists doctypes($code)]} { 1424 return -code error "Unknown doctype \"$arg\"" 1425 } 1426 return $doctypes($code) 1427} 1428 1429namespace eval ::html { 1430 variable doctypes 1431 array set doctypes { 1432 HTML32 {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">} 1433 HTML40 {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN" "http://www.w3.org/TR/REC-html40/strict.dtd">} 1434 HTML40T {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">} 1435 HTML40F {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Frameset//EN" "http://www.w3.org/TR/REC-html40/frameset.dtd">} 1436 HTML401 {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">} 1437 HTML401T {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">} 1438 HTML401F {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN" "http://www.w3.org/TR/html4/frameset.dtd">} 1439 XHTML10S {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">} 1440 XHTML10T {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">} 1441 XHTML10F {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">} 1442 XHTML11 {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">} 1443 XHTMLB {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd">} 1444 } 1445} 1446 1447# ::html::css 1448# Create the text/css tag and tuck it away for usage 1449# 1450# Arguments: 1451# href The location of the css file to include the filename and path 1452# 1453# Results: 1454# HTML for the section 1455 1456proc ::html::css {href} { 1457 variable page 1458 set page(css) \ 1459 "<link rel=\"stylesheet\" type=\"text/css\" href=\"[quoteFormValue $href]\">\n" 1460 return 1461} 1462 1463# ::html::js 1464# Create the text/javascript tag and tuck it away for usage 1465# 1466# Arguments: 1467# href The location of the javascript file to include the filename and path 1468# 1469# Results: 1470# HTML for the section 1471 1472proc ::html::js {href} { 1473 variable page 1474 set page(js) \ 1475 "<script language=\"javascript\" type=\"text/javascript\" src=\"[quoteFormValue $href]\"></script>\n" 1476 return 1477} 1478