# $Id: html.itcl,v 1.28.2.9 2002/10/15 05:04:28 lightn Exp $ # Modified to remove boxes at the top of the page and replaced # Heading with TiVo logo. # A. O'Connell v1.5 2003/12/06 proc print_html_header_200 { chan contenttype lastmodified } { puts $chan "HTTP/1.0 200 OK" puts $chan [format "Date: %s GMT" [clock format [clock seconds] -format "%a, %d %b %Y %T" -gmt true]] if { $lastmodified != "" } { puts $chan [format "Last-Modified: %s GMT" [clock format $lastmodified -format "%a, %d %b %Y %T" -gmt true]] } puts $chan "Connection: close" puts $chan "Content-Type: $contenttype" puts $chan "" } proc print_html_header_304 { chan } { puts $chan "HTTP/1.0 304 Not Modified" puts $chan "Connection: close" puts $chan "" } proc print_html_header_401 { chan } { puts $chan "HTTP/1.0 401 Authorization Required" puts $chan "WWW-Authenticate: Basic realm=\"TiVo-web\"" puts $chan "Connection: close" puts $chan "" } proc print_html_header_404 { chan } { puts $chan "HTTP/1.0 404 Not Found" puts $chan "Connection: close" puts $chan "Content-Type: text/html; charset=iso-8859-1" puts $chan " 404 Not Found

Not Found

The requested URL was not found on this server. " } proc print_html_error { chan action error } { puts $chan "
INTERNAL SERVER ERROR"
    puts $chan "--cut here--"
    puts $chan $action
    puts $chan $error
    puts $chan "--cut here--"
    puts $chan "
" } proc html_start {args} { global url_prefix set title [lindex $args 0] set submenu "" if { [llength $args] > 1 } { set submenu [lindex $args 1] } set ret "\n" append ret "\n" if {$title != ""} { append ret "$title\n" } if {[info exists ::theme_list]} { foreach theme $::theme_list { if {$theme == $TT_HTTPD::STYLE} { set type stylesheet } else { set type "alternate stylesheet" } append ret "\n" } } else { append ret "\n" } append ret " " if { $submenu != "" } { append ret "" } append ret "
\"TiVoWeb
 
$TT_HTTPD::OPTIONS_MENU
$submenu
" } # added nomenu - boody proc html_start_nomenu {title bodyargs} { set ret "\n" append ret "\n" if {$title != ""} { append ret "$title\n" } append ret "\n" append ret "\n" return $ret } proc html_end {} { return "" } proc html_link {link anchor args} { global url_prefix if { [string index $link 0] == "/" } { set link "/$url_prefix[string range $link 1 end]" } if { [llength $args] > 0 && [lindex $args 0] != ""} { return "$anchor" } return "$anchor" } proc img {attr img} { global url_prefix return "" } proc td {args} { if { [llength $args] > 1 } { return "[strim [lindex $args 1]]" } else { set str [strim $args] if { $str == "" } { return " " } else { return "$str" } } } proc h1 {str} { if { $str == "" } { return "

 

" } else { return "

$str

" } } proc h2 {str} { if { $str == "" } { return "

 

" } else { return "

$str

" } } proc tr {attrs args} { set str "" foreach arg $args { append str $arg } if { $str == "" } { set str " " } return "$str" } proc th {args} { if { [llength $args] > 1 } { return "[strim [lindex $args 1]]" } else { return "[strim $args]" } } proc html_table_start {tattr cap capattr} { set ret "" if {$cap != ""} { append ret "" } return $ret } proc html_table_end {} { return "
$cap
" } proc html_form_select {name values labels defaultval args} { set str "" append str "" return $str } # added by boody proc html_form_checkbox {name chkd} { set str "" append str "" return $str } proc html_form_hidden {name value} { return "" } proc html_form_start {method action args} { global url_prefix if { [string index $action 0] == "/" } { set action "/$url_prefix[string range $action 1 end]" } set str "
" return $str } proc html_form_end {} { return "
" } proc html_form_input {type name value} { return "" } proc html_form_text {lines cols name value} { if {$lines == 1} { return "" } else { return "" } } proc add_slashes {str} { regsub -all {([\[\"\;\$])} $str {\\\1} str return $str } proc url_decode {str} { regsub -all {\+} $str " " str set str [add_slashes $str] regsub -all {%([a-fA-F0-9][a-fA-F0-9])} $str {[format "%c" 0x\1]} str set str "return \"$str\"" eval $str } proc parse_post {data} { set env "" while { [set j [string first "=" $data]] != -1 } { if { [set i [string first "&" $data]] == -1 } { set i [string length $data] } set key [add_slashes [string range $data 0 [expr $j - 1]]] set value [add_slashes [url_decode [string range $data [expr $j + 1] [expr $i - 1]]]] append env "set \"$key\" \"$value\";" set data [string range $data [expr $i + 1] end] } return $env } if {$reload == 0} { set altcss [base64dec "I3RoZW1lOmFmdGVyIHsKICBjb250ZW50OiAiSGFsbG93ZWVuIjsKICBjb2xvcjogIzAwMDAwMDsKICBmb250LXNpemU6IC41ZW07CiAgZm9udC13ZWlnaHQ6IDEwMDsKICBsZXR0ZXItc3BhY2luZzogMS4yZW07Cn0KYm9keSB7CiBiYWNrZ3JvdW5kOiAjMDAwMDAwOwogIGZvbnQtZmFtaWx5OiBhcmlhbCwgaGVsdmV0aWNhLCBzYW5zLXNlcmlmOwogIHRleHQtYWxpZ246IGNlbnRlcjsKICBtYXJnaW46IDBweDsKIGNvbG9yOiAjRkY1QzAwOwp9CnRhYmxlIHsKIGJvcmRlci1zcGFjaW5nOiAwcHg7CiAgbWFyZ2luOiBhdXRvOwogIG1hcmdpbi1ib3R0b206IDFlbTsKICBlbXB0eS1jZWxsczogc2hvdzsKfQp0aCB7CiBiYWNrZ3JvdW5kOiAjRkY1QzAwOwogY29sb3I6ICMwMDAwMDA7CiBmb250LXNpemU6IC45NWVtOwogZm9udC13ZWlnaHQ6IGJvbGQ7CiB0ZXh0LXRyYW5zZm9ybTogdXBwZXJjYXNlOwogbGV0dGVyLXNwYWNpbmc6IDAuMjVlbTsKIHBhZGRpbmctbGVmdDogMC41ZW07CiBwYWRkaW5nLXJpZ2h0OiAwLjVlbTsKfQp0ZCB7CiBib3JkZXItYm90dG9tOiAxcHggc29saWQgI0ZGNUMwMDsKIHBhZGRpbmctbGVmdDogMC41ZW07CiBwYWRkaW5nLXJpZ2h0OiAwLjVlbTsKfQppbWcgewogIGJvcmRlcjogbm9uZTsKfQphIHsKIHRleHQtZGVjb3JhdGlvbjogbm9uZTsKIGZvbnQtc2l6ZTogMWVtOwogZm9udC13ZWlnaHQ6IDEwMDsKIHRleHQtdHJhbnNmb3JtOiBub25lOwogbGV0dGVyLXNwYWNpbmc6IDBlbTsKIGNvbG9yOiAjRkZCQjAwOwp9CmE6aG92ZXIgewogdGV4dC1kZWNvcmF0aW9uOiB1bmRlcmxpbmU7Cn0KLmhlYWRlciBhIHsKIGNvbG9yOiAjMDAwMDAwOwp9CnNlbGVjdFtuYW1lXSB7CiAgd2lkdGg6IDEwMCU7Cn0KaW5wdXQsIHNlbGVjdCB7CiAgYm9yZGVyOiAxcHggc29saWQgI0ZGNEMwMDsKICBiYWNrZ3JvdW5kOiAjMDAwMDAwOwogIGNvbG9yOiAjRkY0QzAwOwogIHBhZGRpbmctbGVmdDogMnB4OwogIHBhZGRpbmctcmlnaHQ6IDJweDsKICBtYXJnaW46IDFweDsKfQoKZGl2IHsKICAgICAgbWFyZ2luLWxlZnQ6IDJlbTsKICAgICAgbWFyZ2luLXJpZ2h0OiAyZW07Cn0KcHJlIHsKICAgICAgICB3aGl0ZS1zcGFjZTogcHJlOwogICAgICAgIG1hcmdpbjogYXV0bzsKICAgICAgICB0ZXh0LWFsaWduOiBsZWZ0Owp9Ci50YWJsZSB7CiAgZGlzcGxheTogdGFibGU7Cn0K"] } proc get_kvalue {keys values key} { set i [lsearch $keys $key] if { $i != -1 } { return [lindex $values $i] } else { return "" } } # For debugging purposes proc action_dumppost {chan path data} { puts $chan [html_start "Dump Post"] puts $chan "$data
" set parseddata [parse_post $data] set keys [lindex $parseddata 0] set values [lindex $parseddata 1] set numkeys [llength $keys] for {set i 0} {$i < $numkeys} {incr i} { set key [lindex $keys $i] set value [lindex $values $i] puts $chan "$key = $value
" } puts $chan [html_end] } # httpMapReply taken from http.tcl (part of TCL library.) # check sourceforge at http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/*checkout*/tcl/tcl/library/http1.0/http.tcl?rev=1.4&content-type=text/plain # do x-www-urlencoded character mapping # The spec says: "non-alphanumeric characters are replaced by '%HH'" # 1 leave alphanumerics characters alone # 2 Convert every other character to an array lookup # 3 Escape constructs that are "special" to the tcl parser # 4 "subst" the result, doing all the array substitutions proc httpMapReply {string} { global httpFormMap set alphanumeric a-zA-Z0-9 if {![info exists httpFormMap]} { for {set i 1} {$i <= 256} {incr i} { set c [format %c $i] if {![string match \[$alphanumeric\] $c]} { set httpFormMap($c) %[format %.2x $i] } } # These are handled specially array set httpFormMap { " " + \n %0a } } regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string regsub -all \n $string {\\n} string regsub -all \t $string {\\t} string regsub -all {[][{})\\]\)} $string {\\&} string return [subst $string] } proc htmlEncode { text } { set ret "$text" regsub -all "\&" $ret {\&} ret regsub -all "<" $ret {\<} ret regsub -all ">" $ret {\>} ret regsub -all "\n" $ret {
} ret return "$ret" }