# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*- # -- Tcl Module # @@ Meta Begin # Package html 1.4.1 # Meta as::build::date 2014-03-19 # Meta as::origin http://sourceforge.net/projects/tcllib # Meta category HTML Generation # Meta description Procedures to generate HTML structures # Meta license BSD # Meta platform tcl # Meta require {Tcl 8.2} # Meta require ncgi # Meta subject table form html checkbutton radiobutton checkbox # Meta summary html # @@ Meta End # ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS package require Tcl 8.2 package require ncgi # ACTIVESTATE TEAPOT-PKG END REQUIREMENTS # ACTIVESTATE TEAPOT-PKG BEGIN DECLARE package provide html 1.4.1 # ACTIVESTATE TEAPOT-PKG END DECLARE # ACTIVESTATE TEAPOT-PKG END TM # html.tcl -- # # Procedures to make generating HTML easier. # # This module depends on the ncgi module for the procedures # that initialize form elements based on current CGI values. # # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 2006 Michael Schlenker # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Originally by Brent Welch, with help from Dan Kuchler and Melissa Chawla package require Tcl 8.2 package require ncgi package provide html 1.4.1 namespace eval ::html { # State about the current page variable page # A simple set of global defaults for tag parameters is implemented # by storing into elements indexed by "key.param", where key is # often the name of an HTML tag (anything for scoping), and # param must be the name of the HTML tag parameter (e.g., "href" or "size") # input.size # body.bgcolor # body.text # font.face # font.size # font.color variable defaults array set defaults { input.size 45 body.bgcolor white body.text black } # In order to nandle nested calls to redefined control structures, # we need a temporary variable that is known not to exist. We keep this # counter to append to the varname. Each time we need a temporary # variable, we increment this counter. variable randVar 0 # No more export, because this defines things like # foreach and if that do HTML things, not Tcl control # namespace export * # Dictionary mapping from special characters to their entities. variable entities { \xa0   \xa1 ¡ \xa2 ¢ \xa3 £ \xa4 ¤ \xa5 ¥ \xa6 ¦ \xa7 § \xa8 ¨ \xa9 © \xaa ª \xab « \xac ¬ \xad ­ \xae ® \xaf ¯ \xb0 ° \xb1 ± \xb2 ² \xb3 ³ \xb4 ´ \xb5 µ \xb6 ¶ \xb7 · \xb8 ¸ \xb9 ¹ \xba º \xbb » \xbc ¼ \xbd ½ \xbe ¾ \xbf ¿ \xc0 À \xc1 Á \xc2  \xc3 à \xc4 Ä \xc5 Å \xc6 Æ \xc7 Ç \xc8 È \xc9 É \xca Ê \xcb Ë \xcc Ì \xcd Í \xce Î \xcf Ï \xd0 Ð \xd1 Ñ \xd2 Ò \xd3 Ó \xd4 Ô \xd5 Õ \xd6 Ö \xd7 × \xd8 Ø \xd9 Ù \xda Ú \xdb Û \xdc Ü \xdd Ý \xde Þ \xdf ß \xe0 à \xe1 á \xe2 â \xe3 ã \xe4 ä \xe5 å \xe6 æ \xe7 ç \xe8 è \xe9 é \xea ê \xeb ë \xec ì \xed í \xee î \xef ï \xf0 ð \xf1 ñ \xf2 ò \xf3 ó \xf4 ô \xf5 õ \xf6 ö \xf7 ÷ \xf8 ø \xf9 ù \xfa ú \xfb û \xfc ü \xfd ý \xfe þ \xff ÿ \u192 ƒ \u391 Α \u392 Β \u393 Γ \u394 Δ \u395 Ε \u396 Ζ \u397 Η \u398 Θ \u399 Ι \u39A Κ \u39B Λ \u39C Μ \u39D Ν \u39E Ξ \u39F Ο \u3A0 Π \u3A1 Ρ \u3A3 Σ \u3A4 Τ \u3A5 Υ \u3A6 Φ \u3A7 Χ \u3A8 Ψ \u3A9 Ω \u3B1 α \u3B2 β \u3B3 γ \u3B4 δ \u3B5 ε \u3B6 ζ \u3B7 η \u3B8 θ \u3B9 ι \u3BA κ \u3BB λ \u3BC μ \u3BD ν \u3BE ξ \u3BF ο \u3C0 π \u3C1 ρ \u3C2 ς \u3C3 σ \u3C4 τ \u3C5 υ \u3C6 φ \u3C7 χ \u3C8 ψ \u3C9 ω \u3D1 ϑ \u3D2 ϒ \u3D6 ϖ \u2022 • \u2026 … \u2032 ′ \u2033 ″ \u203E ‾ \u2044 ⁄ \u2118 ℘ \u2111 ℑ \u211C ℜ \u2122 ™ \u2135 ℵ \u2190 ← \u2191 ↑ \u2192 → \u2193 ↓ \u2194 ↔ \u21B5 ↵ \u21D0 ⇐ \u21D1 ⇑ \u21D2 ⇒ \u21D3 ⇓ \u21D4 ⇔ \u2200 ∀ \u2202 ∂ \u2203 ∃ \u2205 ∅ \u2207 ∇ \u2208 ∈ \u2209 ∉ \u220B ∋ \u220F ∏ \u2211 ∑ \u2212 − \u2217 ∗ \u221A √ \u221D ∝ \u221E ∞ \u2220 ∠ \u2227 ∧ \u2228 ∨ \u2229 ∩ \u222A ∪ \u222B ∫ \u2234 ∴ \u223C ∼ \u2245 ≅ \u2248 ≈ \u2260 ≠ \u2261 ≡ \u2264 ≤ \u2265 ≥ \u2282 ⊂ \u2283 ⊃ \u2284 ⊄ \u2286 ⊆ \u2287 ⊇ \u2295 ⊕ \u2297 ⊗ \u22A5 ⊥ \u22C5 ⋅ \u2308 ⌈ \u2309 ⌉ \u230A ⌊ \u230B ⌋ \u2329 ⟨ \u232A ⟩ \u25CA ◊ \u2660 ♠ \u2663 ♣ \u2665 ♥ \u2666 ♦ \x22 " \x26 & \x3C < \x3E > \u152 Œ \u153 œ \u160 Š \u161 š \u178 Ÿ \u2C6 ˆ \u2DC ˜ \u2002   \u2003   \u2009   \u200C ‌ \u200D ‍ \u200E ‎ \u200F ‏ \u2013 – \u2014 — \u2018 ‘ \u2019 ’ \u201A ‚ \u201C “ \u201D ” \u201E „ \u2020 † \u2021 ‡ \u2030 ‰ \u2039 ‹ \u203A › \u20AC € } } # ::html::foreach # # Rework the "foreach" command to blend into HTML template files. # Rather than evaluating the body, we return the subst'ed body. Each # iteration of the loop causes another string to be concatenated to # the result value. No error checking is done on any arguments. # # Arguments: # varlist Variables to instantiate with values from the next argument. # list Values to set variables in varlist to. # args ?varlist2 list2 ...? body, where body is the string to subst # during each iteration of the loop. # # Results: # Returns a string composed of multiple concatenations of the # substitued body. # # Side Effects: # None. proc ::html::foreach {vars vals args} { variable randVar # The body of the foreach loop must be run in the stack frame # above this one in order to have access to local variable at that stack # level. # To support nested foreach loops, we use a uniquely named # variable to store incremental results. incr randVar ::set resultVar "result_$randVar" # Extract the body and any varlists and valuelists from the args. ::set body [lindex $args end] ::set varvals [linsert [lreplace $args end end] 0 $vars $vals] # Create the script to eval in the stack frame above this one. ::set script "::foreach" ::foreach {vars vals} $varvals { append script " [list $vars] [list $vals]" } append script " \{\n" append script " append $resultVar \[subst \{$body\}\]\n" append script "\}\n" # Create a temporary variable in the stack frame above this one, # and use it to store the incremental results of the multiple loop # iterations. Remove the temporary variable when we're done so there's # no trace of this loop left in that stack frame. upvar 1 $resultVar tmp ::set tmp "" uplevel 1 $script ::set result $tmp unset tmp return $result } # ::html::for # # Rework the "for" command to blend into HTML template files. # Rather than evaluating the body, we return the subst'ed body. Each # iteration of the loop causes another string to be concatenated to # the result value. No error checking is done on any arguments. # # Arguments: # start A script to evaluate once at the very beginning. # test An expression to eval before each iteration of the loop. # Once the expression is false, the command returns. # next A script to evaluate after each iteration of the loop. # body The string to subst during each iteration of the loop. # # Results: # Returns a string composed of multiple concatenations of the # substitued body. # # Side Effects: # None. proc ::html::for {start test next body} { variable randVar # The body of the for loop must be run in the stack frame # above this one in order to have access to local variable at that stack # level. # To support nested for loops, we use a uniquely named # variable to store incremental results. incr randVar ::set resultVar "result_$randVar" # Create the script to eval in the stack frame above this one. ::set script "::for [list $start] [list $test] [list $next] \{\n" append script " append $resultVar \[subst \{$body\}\]\n" append script "\}\n" # Create a temporary variable in the stack frame above this one, # and use it to store the incremental resutls of the multiple loop # iterations. Remove the temporary variable when we're done so there's # no trace of this loop left in that stack frame. upvar 1 $resultVar tmp ::set tmp "" uplevel 1 $script ::set result $tmp unset tmp return $result } # ::html::while # # Rework the "while" command to blend into HTML template files. # Rather than evaluating the body, we return the subst'ed body. Each # iteration of the loop causes another string to be concatenated to # the result value. No error checking is done on any arguments. # # Arguments: # test An expression to eval before each iteration of the loop. # Once the expression is false, the command returns. # body The string to subst during each iteration of the loop. # # Results: # Returns a string composed of multiple concatenations of the # substitued body. # # Side Effects: # None. proc ::html::while {test body} { variable randVar # The body of the while loop must be run in the stack frame # above this one in order to have access to local variable at that stack # level. # To support nested while loops, we use a uniquely named # variable to store incremental results. incr randVar ::set resultVar "result_$randVar" # Create the script to eval in the stack frame above this one. ::set script "::while [list $test] \{\n" append script " append $resultVar \[subst \{$body\}\]\n" append script "\}\n" # Create a temporary variable in the stack frame above this one, # and use it to store the incremental resutls of the multiple loop # iterations. Remove the temporary variable when we're done so there's # no trace of this loop left in that stack frame. upvar 1 $resultVar tmp ::set tmp "" uplevel 1 $script ::set result $tmp unset tmp return $result } # ::html::if # # Rework the "if" command to blend into HTML template files. # Rather than evaluating a body clause, we return the subst'ed body. # No error checking is done on any arguments. # # Arguments: # test An expression to eval to decide whether to use the then body. # body The string to subst if the test case was true. # args ?elseif test body2 ...? ?else bodyn?, where bodyn is the string # to subst if none of the tests are true. # # Results: # Returns a string composed by substituting a body clause. # # Side Effects: # None. proc ::html::if {test body args} { variable randVar # The body of the then/else clause must be run in the stack frame # above this one in order to have access to local variable at that stack # level. # To support nested if's, we use a uniquely named # variable to store incremental results. incr randVar ::set resultVar "result_$randVar" # Extract the elseif clauses and else clause if they exist. ::set cmd [linsert $args 0 "::if" $test $body] ::foreach {keyword test body} $cmd { ::if {[string equal $keyword "else"]} { append script " else \{\n" ::set body $test } else { append script " $keyword [list $test] \{\n" } append script " append $resultVar \[subst \{$body\}\]\n" append script "\} " } # Create a temporary variable in the stack frame above this one, # and use it to store the incremental resutls of the multiple loop # iterations. Remove the temporary variable when we're done so there's # no trace of this loop left in that stack frame. upvar $resultVar tmp ::set tmp "" uplevel $script ::set result $tmp unset tmp return $result } # ::html::set # # Rework the "set" command to blend into HTML template files. # The return value is always "" so nothing is appended in the # template. No error checking is done on any arguments. # # Arguments: # var The variable to set. # val The new value to give the variable. # # Results: # Returns "". # # Side Effects: # None. proc ::html::set {var val} { # The variable must be set in the stack frame above this one. ::set cmd [list set $var $val] uplevel 1 $cmd return "" } # ::html::eval # # Rework the "eval" command to blend into HTML template files. # The return value is always "" so nothing is appended in the # template. No error checking is done on any arguments. # # Arguments: # args The args to evaluate. At least one must be given. # # Results: # Returns "". # # Side Effects: # Throws an error if no arguments are given. proc ::html::eval {args} { # The args must be evaluated in the stack frame above this one. ::eval [linsert $args 0 uplevel 1] return "" } # ::html::init # # Reset state that gets accumulated for the current page. # # Arguments: # nvlist Name, value list that is used to initialize default namespace # variables that set font, size, etc. # # Side Effects: # Wipes the page state array proc ::html::init {{nvlist {}}} { variable page variable defaults ::if {[info exists page]} { unset page } ::if {[info exists defaults]} { unset defaults } array set defaults $nvlist } # ::html::head # # Generate the section. There are a number of # optional calls you make *before* this to inject # meta tags - see everything between here and the bodyTag proc. # # Arguments: # title The page title # # Results: # HTML for the section proc ::html::head {title} { variable page ::set html "[openTag html][openTag head]\n" append html "\t[title $title]" ::if {[info exists page(author)]} { append html "\t$page(author)" } ::if {[info exists page(meta)]} { ::foreach line $page(meta) { append html "\t$line\n" } } ::if {[info exists page(css)]} { ::foreach style $page(css) { append html "\t$style\n" } } ::if {[info exists page(js)]} { ::foreach script $page(js) { append html "\t$script\n" } } append html "[closeTag]\n" } # ::html::title # # Wrap up the and tuck it away for use in the page later. # # Arguments: # title The page title # # Results: # HTML for the <title> section proc ::html::title {title} { variable page ::set page(title) $title ::set html "<title>$title\n" return $html } # ::html::getTitle # # Return the title of the current page. # # Arguments: # None # # Results: # The title proc ::html::getTitle {} { variable page ::if {[info exists page(title)]} { return $page(title) } else { return "" } } # ::html::meta # # Generate a meta tag. This tag gets bundled into the # section generated by html::head # # Arguments: # args A name-value list of meta tag names and values. # # Side Effects: # Stores HTML for the tag for use later by html::head proc ::html::meta {args} { variable page ::set html "" ::foreach {name value} $args { append html "" } lappend page(meta) $html return "" } # ::html::refresh # # Generate a meta refresh tag. This tag gets bundled into the # section generated by html::head # # Arguments: # content Time period, in seconds, before the refresh # url (option) new page to view. If not specified, then # the current page is reloaded. # # Side Effects: # Stores HTML for the tag for use later by html::head proc ::html::refresh {content {url {}}} { variable page ::set html "\n" lappend page(meta) $html return "" } # ::html::headTag # # Embed a tag into the HEAD section # generated by html::head # # Arguments: # string Everything but the < > for the tag. # # Side Effects: # Stores HTML for the tag for use later by html::head proc ::html::headTag {string} { variable page lappend page(meta) <$string> return "" } # ::html::keywords # # Add META tag keywords to the section. # Call this before you call html::head # # Arguments: # args The keywords # # Side Effects: # See html::meta proc ::html::keywords {args} { html::meta keywords [join $args ", "] } # ::html::description # # Add a description META tag to the section. # Call this before you call html::head # # Arguments: # description The description # # Side Effects: # See html::meta proc ::html::description {description} { html::meta description $description } # ::html::author # # Add an author comment to the section. # Call this before you call html::head # # Arguments: # author Author's name # # Side Effects: # sets page(author) proc ::html::author {author} { variable page ::set page(author) "\n" return "" } # ::html::tagParam # # Return a name, value string for the tag parameters. # The values come from "hard-wired" values in the # param agrument, or from the defaults set with html::init. # # Arguments: # tag Name of the HTML tag (case insensitive). # param pname=value info that overrides any default values # # Results # A string of the form: # pname="keyvalue" name2="2nd value" proc ::html::tagParam {tag {param {}}} { variable defaults ::set def "" ::foreach key [lsort [array names defaults $tag.*]] { append def [default $key $param] } return [string trimleft $param$def] } # ::html::default # # Return a default value, if one has been registered # and an overriding value does not occur in the existing # tag parameters. # # Arguments: # key Index into the defaults array defined by html::init # This is expected to be in the form tag.pname where # the pname part is used in the tag parameter name # param pname=value info that overrides any default values # # Results # pname="keyvalue" proc ::html::default {key {param {}}} { variable defaults ::set pname [string tolower [lindex [split $key .] 1]] ::set key [string tolower $key] ::if {![regexp -nocase "(\[ \]|^)$pname=" $param] && [info exists defaults($key)] && [string length $defaults($key)]} { return " $pname=\"$defaults($key)\"" } else { return "" } } # ::html::bodyTag # # Generate a body tag # # Arguments: # none # # Results # A body tag proc ::html::bodyTag {args} { return [openTag body [join $args]]\n } # The following procedures are all related to generating form elements # that are initialized to store the current value of the form element # based on the CGI state. These functions depend on the ncgi::value # procedure and assume that the caller has called ncgi::parse and/or # ncgi::init appropriately to initialize the ncgi module. # ::html::formValue # # Return a name and value pair, where the value is initialized # from existing form data, if any. # # Arguments: # name The name of the form element # defvalue A default value to use, if not appears in the CGI # inputs. DEPRECATED - use ncgi::defValue instead. # # Retults: # A string like: # name="fred" value="freds value" proc ::html::formValue {name {defvalue {}}} { ::set value [ncgi::value $name] ::if {[string length $value] == 0} { ::set value $defvalue } return "name=\"$name\" value=\"[quoteFormValue $value]\"" } # ::html::quoteFormValue # # Quote a value for use in a value=\"$value\" fragment. # # Arguments: # value The value to quote # # Retults: # A string like: # "Hello, <b>World!" proc ::html::quoteFormValue {value} { return [string map [list "&" "&" "\"" """ \ "'" "'" "<" "<" ">" ">"] $value] } # ::html::textInput -- # # Return an element. This uses the # input.size default falue. # # Arguments: # name The form element name # args Additional attributes for the INPUT tag # # Results: # The html fragment proc ::html::textInput {name {value {}} args} { ::set html "\n" return $html } # ::html::textInputRow -- # # Format a table row containing a text input element and a label. # # Arguments: # label Label to display next to the form element # name The form element name # args Additional attributes for the INPUT tag # # Results: # The html fragment proc ::html::textInputRow {label name {value {}} args} { ::set html [row $label [::eval [linsert $args 0 html::textInput $name $value]]] return $html } # ::html::passwordInputRow -- # # Format a table row containing a password input element and a label. # # Arguments: # label Label to display next to the form element # name The form element name # # Results: # The html fragment proc ::html::passwordInputRow {label {name password}} { ::set html [row $label [passwordInput $name]] return $html } # ::html::passwordInput -- # # Return an element. # # Arguments: # name The form element name. Defaults to "password" # # Results: # The html fragment proc ::html::passwordInput {{name password}} { ::set html "\n" return $html } # ::html::checkbox -- # # Format a checkbox so that it retains its state based on # the current CGI values # # Arguments: # name The form element name # value The value associated with the checkbox # # Results: # The html fragment proc ::html::checkbox {name value} { ::set html "\n" } # ::html::checkValue # # Like html::formalue, but for checkboxes that need CHECKED # # Arguments: # name The name of the form element # defvalue A default value to use, if not appears in the CGI # inputs # # Retults: # A string like: # name="fred" value="freds value" CHECKED proc ::html::checkValue {name {value 1}} { ::foreach v [ncgi::valueList $name] { ::if {[string compare $value $v] == 0} { return "name=\"$name\" value=\"[quoteFormValue $value]\" checked" } } return "name=\"$name\" value=\"[quoteFormValue $value]\"" } # ::html::radioValue # # Like html::formValue, but for radioboxes that need CHECKED # # Arguments: # name The name of the form element # value The value associated with the radio button. # # Retults: # A string like: # name="fred" value="freds value" CHECKED proc ::html::radioValue {name value {defaultSelection {}}} { ::if {[string equal $value [ncgi::value $name $defaultSelection]]} { return "name=\"$name\" value=\"[quoteFormValue $value]\" checked" } else { return "name=\"$name\" value=\"[quoteFormValue $value]\"" } } # ::html::radioSet -- # # Display a set of radio buttons while looking for an existing # value from the query data, if any. proc ::html::radioSet {key sep list {defaultSelection {}}} { ::set html "" ::set s "" ::foreach {label v} $list { append html "$s $label" ::set s $sep } return $html } # ::html::checkSet -- # # Display a set of check buttons while looking for an existing # value from the query data, if any. proc ::html::checkSet {key sep list} { ::set s "" ::foreach {label v} $list { append html "$s $label" ::set s $sep } return $html } # ::html::select -- # # Format a \n" ::foreach {label v} $choices { ::if {[lsearch -exact $def $v] != -1} { ::set SEL " selected" } else { ::set SEL "" } append html "