# 
# htmlutils.tcl
#	Basic building blocks for HTML pages
#
# SCCS: @(#) htmlutils.tcl 1.2 98/04/17 10:55:03

package provide htmlutils 1.0

# OpenTag
# Remember that a tag  is opened so it can be closed later.
# This is used to automatically clean up at the end of a page.

proc OpenTag {tag args} {
    global page
    lappend page(stack) $tag
    return <[string trimright "$tag [join $args]"]>
}

# CloseTag
# Close the tag on the top of the tag stack

proc CloseTag {} {
    global page
    set top [lindex $page(stack) end]
    set page(stack) [lreplace $page(stack) end end]
    return </$top>
}

# Head
# No arguments.   Start a <Head> block with a comment
# about the file being autogenerated.

proc Head {} {
    global page
    set page(head) 1
    set html ""
    append html [OpenTag HTML]\n
    append html [OpenTag HEAD]\n
    append html "<!-- This document has been generated - Don't edit this file,-->\n<!-- your changes would be LOST, edit the .tml file instead. -->\n"
    return $html
}

# Body
# Optional arguments: parameters to the <Body> tag
# Start the body section, closing the Head block if necessary

proc Body {args} {
    global page
    set html ""
    if {[info exists page(head)]} {
	append html "[CloseTag]\n" ;# Should be HEAD
    }
    append html [eval {OpenTag body} $args]\n
    return $html
}


# End
# Close out all the open tags.  Especially useful for
# Tables that do not display at all if they are unclosed.

proc End {} {
    global page
    set html ""
    while {[llength $page(stack)]} {
	append html [CloseTag]\n
    }
    return $html
}

# Title
# arguments:
# 	str	The title string
# Generate and remember the page title

proc Title {str} {
    global page
    set page(title) $str
    return "<TITLE>$str</TITLE>\n"
}

# Author
# arguments:
#	who	The page author
# Generates a comment with the author

proc Author {who} {
    global page
    set page(author) $who
    return "<!-- Author: $who -->\n"
}

# Keywords
# arguments:
#	args	List of keywords
# Generates a meta tag with the keywords.

proc Keywords {args} {
    return "<META NAME=\"keywords\" CONTENT=\"[join $args]\">\n"
}

# ShowArray
# arguments:
#	arrname	The name of the array
#	pat	A string match pattern for the element keys
# Formats an array in a table

proc ShowArray {arrname {pat *}} {
    upvar 1 $arrname arr
    set html ""
    if {[info exists arr]} {
	set html "<H2>$arrname array</H2>"
	append html <TABLE>
	foreach name [lsort [array names arr $pat]] {
	    append html "<TR><TD>$name</TD><TD>$arr($name)</TD></TR>\n"
	}
	append html </TABLE>
    }
    return $html
}

# ShowQuery
# arguments:
#	querylist	Typically the page(query) value
# Format the query into an array

proc ShowQuery {querylist} {
    set html ""
    if {[llength $querylist]} {
	set html "<H2>Query Data</H2>"
	append html <TABLE>
	foreach {label value} $querylist {
	    append html "<TR><TD>$label</TD><TD>$value</TD></TR>\n"
	}
	append html </TABLE>
    }
    return $html
}

# DynamicOnly
# no arguments
# Set the page(dynamic) bit so the result is never cached.

proc DynamicOnly {} {
    global page
    set page(dynamic) 1		;# Turns off caching into the .html file
    if {[info exist page(url)]} {
	Count cachehit,$page(url)	;# Not a cache hit, but used
					;# in the status counters
    }
    return ""
}

# Mailto - create a mailto: href
#	email	The email address
#	name	Optional, the link text.  If not present, the email is used.

proc Mailto {email {name {}}} {
    set html "<a href=\"mailto:$email\">"
    if {[string length $name]} {
	append html $name</a>
    } else {
	append html $email</a>
    }
    return $html
}
proc Email {addr} {
    return "<A HREF=\"mailto:$addr\">$addr</A>"
}

# PersonP - Start a paragraph about a person
#	name	Their name
#	url	Optional, home page link

proc PersonP {name {url {}}} {
    set html "<p><b>"
    if {[string length $url]} {
	append html "<a href=\"$url\">$name</a>"
    } else {
	append html "$name"
    }
    append html </b><br>
    return $html
}

# Date -- the current date

proc Date {} {
	set html "<p>[clock format [clock seconds]]</p>"
}

# Link -- Format an <a> tag

proc Link {text {url {}} {name {}}} {
    if {[string length $url] == 0} {
	set url $text
    }
    if {[string length $name] != 0} {
	set n name="$name"
    } else {
	set n {}
    }

    return "<a href=\"$url\" $n>$text</a>"
}

# Row - add a row to a table
proc Row {args} {
    set html "<tr>"
    foreach i $args {
	append html "<td>$i</td>"
    }
    append html </tr>
}

# RelativeUrl - make a URL relative
#	url	A URL is either:
#		relative to the root (e,g, "a/b")
#		or absolute (e.g., "/a/b"), or off-site
#		(e.g., "http://..." or "mailto:...")
# In the first case, the value of $page(root) is prepended to the
# URL so you can get their via a relative URL.  page(root) is
# set by the server when processing templates to be the path back to the root.

proc RelativeUrl {url} {
    global page
    if {! [regexp {^(/|\.|[^:/]+:)} $url]} {
	set url $page(root)$url
    }
    return $url
}

# Capitalize - make the first letter a cap

proc Capitalize {string} {
    return [string toupper [string index $string 0]][string range $string 1 end]
}

# Font - standard font tag
proc Font {args} {
    global scriptics
    return "<font face=\"$scriptics(fonts)\" size=2 [join $args]>"
}

# Code - code font tag
proc code {args} {
    global scriptics
    return "<code><font face=\"courier\" [join $args]>"
}
proc /code {args} {
    return "</font></code>"
}

proc Space {width height} {
set html "<!-- space $width $height -->"
append html "<img src=/images/Space.gif width=$width height=$height border=0>"
}

proc VSpace {height} {
set html "<!-- Vspace $height -->"
    append html "\n<tr><td valign=top>[Space 1 $height]</td></tr>\n\n"
}

proc FtpSize {file} {
    set dirs [list ~ftp/pub/tcl \
		/home/build/LATEST/IMAGE/web \
		~ftp/pub/tclpro/download]
    foreach dir $dirs {
	set dir [glob -nocomplain $dir]
	if {[string length $dir] == 0} {
	    continue
	}
	set path [file join $dir $file]
	if {[file exists $path]} {
	    return "<font size=-1>([format %.2f [expr {[file size $path]/(1024.0 * 1024.)}]] Mbytes)</font>"
	}
    }
    return "<!-- $dirs -->"
}

# To quote
proc Raw {string} {
    return $string
}

# To output Tcl code samples
proc Code {code} {
    regsub -all {&} $code {\&amp;} code
    regsub -all {<} $code {\&lt;} code
    regsub -all {>} $code {\&gt;} code
    return "<p><dl><dd><PRE>$code</PRE></dl><p>"
}

# returns and does nothing, useful for [set foo bar; Noop] or
# [Noop [set foo bar]] to avoid returning something into the .html

proc Noop {args} {
}

# LastModified -- put last modified time of current page

proc LastModified {{file {}}} {
	# Should get source file mtime
	set html "<p align=right><font size=1>Last modified: [clock format [clock seconds] -format {%B %d, %Y}]</font></p>"
}

proc LastChange {{path ""}} {
    global page
    if {[string compare $path ""] == 0} {
	set path $page(template)
    } else {
	set path [Path $path]
    }
    return [clock format [file mtime $path] -format "%a %b %d %Y, %H:%M"]
}

proc Path {name} {
    global page
    set dir [file dirname $page(filename)]
    return [file join $dir $name]
}


# User Agent checking
proc GetUserAgent {} {
    global env
    if {[info exists env(HTTP_USER_AGENT)]} {
	return $env(HTTP_USER_AGENT)
    } else {
	return {}
    }
}

proc UserAgentMatch {pattern} {
    string match $pattern [GetUserAgent]
}


proc InsertFile {file {tag {}}} {
    global page
    set path [file join [file dirname $page(filename)] $file]
    if {[catch {open $path} in]} {
	return "<br><font sizez=-1>Cannot open $file</font><br>"
    } else {
	set X [read $in]
	close $in
	if {[string length $tag]} {
	    regexp {^([^ ]+)} $tag x closetag
	    return "<$tag>$X</$closetag>"
	} else {
	    return $X
	}
    }
}

proc InsertTemplate {file} {
    global page
    set path [file join [file dirname $page(filename)] $file]
    if {[catch {open $path} in]} {
	return "<br><font sizez=-1>Cannot open $file</font><br>"
    } else {
	set X [read $in]
	close $in
	return [uplevel #0 [list subst $X]]
    }
}

# MinorMenu
#
#	Create a menu of links given a list of label, URL pairs.
#	If the URL is the current page, it is not highlighted.
#
# Arguments:
#
#	list	List that alternates label, url, label, url
#
# Results:
#	html

proc MinorMenu {list} {
    global page
    set sep ""
    set html ""
    regsub {index.h?tml$} $page(url) {} this
    append html "<!-- page $page(url) -->\n"
    foreach {label url} $list {
	regsub {index.h?tml$} $url {} that
	if {[string compare $this $that] == 0} {
	    append html "$sep$label"
	} else {
	    append html "$sep<a href=\"$url\">$label</a>"
	}
	set sep " | "
    }
    return $html
}

proc TclPower {{size 150} {align left}} {
    switch $size {
        75 {set flags "width=48 height=75"}
        100 {set flags "width=64 height=100"}
        150 {set flags "width=97 height=150"}
        175 {set flags "width=113 height=175"}
        200 {set flags "width=130 height=200"}
        default {set flags ""}
    }

    set html "<img src=/images/pwrdLogo$size.gif align=$align $flags>\n"
}


