# ad-aolserver-3.tcl.preload,v 3.1 2000/02/27 19:16:01 jsalz Exp
# File:        ad-aolserver-3.tcl.preload
# Author:      Jon Salz <jsalz@mit.edu>, from code by markd
# Date:        27 Feb 2000
# Description: Contains procedures specific to AOLserver 3 (mostly recreating
#              functionality dropped from AOLserver 2).

#
# If name contains a space, then it is surrounded by double quotes.
# This is useful for names in SQL statements that may contain spaces.

proc ns_dbquotename {name} {
    if [regexp " " $name] {
	return "\"$name\""
    } else {
	return $name
    }   
}

# ns_dbquotevalue:
#
# Prepares a value string for inclusion in an SQL statement.
# "" is translated into NULL.
# All values of any numeric type are left alone.
# All other values are surrounded by single quotes and any
# single quotes included in the value are escaped (ie. translated
# into 2 single quotes). 

proc ns_dbquotevalue {value {type text}} {

    if [string match $value ""] {
	return "NULL"
    }

    if {$type == "decimal" \
	    || $type == "double" \
	    || $type == "integer" \
	    || $type == "int" \
	    || $type == "real" \
	    || $type == "smallint" \
	    || $type == "bigint" \
	    || $type == "bit" \
	    || $type == "float" \
	    || $type == "numeric" \
	    || $type == "tinyint"} {
	return $value
    }
    regsub -all "'" $value "''" value
    return "'$value'"
}



# -1 = Not there or value was ""
#  0 = NULL, set value to NULL.
#  1 = Got value, set value to it.

proc ns_dbformvalue {formdata column type valuebyref} {

    upvar $valuebyref value

    if {[ns_set get $formdata ColValue.[ns_urlencode $column].NULL] == "t"} {
	set value ""
	return 0
    }

    set value [ns_set get $formdata ColValue.[ns_urlencode $column]]

    if [string match $value ""] {
        switch $type {
	    
	    date      {
		set value [ns_buildsqldate \
			[ns_set get $formdata ColValue.[ns_urlencode $column].month] \
			[ns_set get $formdata ColValue.[ns_urlencode $column].day] \
			[ns_set get $formdata ColValue.[ns_urlencode $column].year]]
	    }
	    
	    time      {
		set value [ns_buildsqltime \
			[ns_set get $formdata ColValue.[ns_urlencode $column].time] \
			[ns_set get $formdata ColValue.[ns_urlencode $column].ampm]]
	    }
	    
            datetime  -
	    timestamp {
		set value [ns_buildsqltimestamp \
			[ns_set get $formdata ColValue.[ns_urlencode $column].month] \
			[ns_set get $formdata ColValue.[ns_urlencode $column].day] \
			[ns_set get $formdata ColValue.[ns_urlencode $column].year] \
			[ns_set get $formdata ColValue.[ns_urlencode $column].time] \
			[ns_set get $formdata ColValue.[ns_urlencode $column].ampm]]
	    }
	    
	    default {
	    }
	}
    }
    if [string match $value ""] {
	return -1
    } else {
	return 1
    }
}

proc ns_dbformvalueput {htmlform column type value} {

    switch $type {

	date {
	    set retval [ns_formvalueput $htmlform ColValue.[ns_urlencode $column].NULL f]
	    set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].month \
		    [ns_parsesqldate month $value]]
	    set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].day \
		    [ns_parsesqldate day $value]]
	    set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].year \
		    [ns_parsesqldate year $value]]
	}

	time {
	    set retval [ns_formvalueput $htmlform ColValue.[ns_urlencode $column].NULL f]
	    set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].time \
		    [ns_parsesqltime time $value]]
	    set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].ampm \
		    [ns_parsesqltime ampm $value]]

	}

        datetime  -
	timestamp {
	    set retval [ns_formvalueput $htmlform ColValue.[ns_urlencode $column].NULL f]
	    set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].month \
		    [ns_parsesqltimestamp month $value]]
	    set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].day \
		    [ns_parsesqltimestamp day $value]]
	    set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].year \
		    [ns_parsesqltimestamp year $value]]
	    set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].time \
		    [ns_parsesqltimestamp time $value]]
	    set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].ampm \
		    [ns_parsesqltimestamp ampm $value]]
	    
	}

	default {

	    set retval [ns_formvalueput $htmlform ColValue.[ns_urlencode $column] $value]
	}
    }
    return $retval
}

# Special thanks to Brian Tivol at Hearst New Media Center and MIT
# for providing the core of this code.

proc ns_formvalueput {htmlpiece dataname datavalue} {

    set newhtml ""

    while {$htmlpiece != ""} {
	if {[string index $htmlpiece 0] == "<"} {
	    regexp {<([^>]*)>(.*)} $htmlpiece m tag htmlpiece
	    set tag [string trim $tag]
	    set CAPTAG [string toupper $tag]

	    switch -regexp $CAPTAG {

		{^INPUT} {
		    if {[regexp {TYPE=("IMAGE"|"SUBMIT"|"RESET"|IMAGE|SUBMIT|RESET)} $CAPTAG]} {
			append newhtml <$tag>
			
		    } elseif {[regexp {TYPE=("CHECKBOX"|CHECKBOX|"RADIO"|RADIO)} $CAPTAG]} {
			
			set name [ns_tagelement $tag NAME]

			if {$name == $dataname} {

			    set value [ns_tagelement $tag VALUE]

			    regsub -all -nocase { *CHECKED} $tag {} tag

			    if {$value == $datavalue} {
				append tag " CHECKED"
			    }
			}
			append newhtml <$tag>

		    } else {

			## If it's an INPUT TYPE that hasn't been covered
			#  (text, password, hidden, other (defaults to text))
			## then we add/replace the VALUE tag
			
			set name [ns_tagelement $tag NAME]
			
			if {$name == $dataname} {
			    ns_tagelementset tag VALUE $datavalue
			}
			append newhtml <$tag>
		    }
		}

		{^TEXTAREA} {

		    ###
		    #   Fill in the middle of this tag
		    ###

		    set name [ns_tagelement $tag NAME]
		    
		    if {$name == $dataname} {
			while {![regexp -nocase {^<( *)/TEXTAREA} $htmlpiece]} {
			    regexp {^.[^<]*(.*)} $htmlpiece m htmlpiece
			}
			append newhtml <$tag>$datavalue
		    } else {
			append newhtml <$tag>
		    }
		}
		
		{^SELECT} {

		    ### Set flags so OPTION and /SELECT know what to look for:
		    #   snam is the variable name, sflg is 1 if nothing's
		    ### been added, smul is 1 if it's MULTIPLE selection


		    if {[ns_tagelement $tag NAME] == $dataname} {
			set inkeyselect 1
			set addoption 1
		    } else {
			set inkeyselect 0
			set addoption 0
		    }

		    append newhtml <$tag>
		}

		{^OPTION} {
		    
		    ###
		    #   Find the value for this
		    ###

		    if {$inkeyselect} {

			regsub -all -nocase { *SELECTED} $tag {} tag

			set value [ns_tagelement $tag VALUE]

			regexp {^([^<]*)(.*)} $htmlpiece m txt htmlpiece

			if [string match "" $value] {
			    set value [string trim $txt]
			}

			if {$value == $datavalue} {
			    append tag " SELECTED"
			    set addoption 0
			}
			append newhtml <$tag>$txt
		    } else {
			append newhtml <$tag>
		    }
		}

		{^/SELECT} {
		    
		    ###
		    #   Do we need to add to the end?
		    ###
		    
		    if {$inkeyselect && $addoption} {
			append newhtml "<option selected>$datavalue<$tag>"
		    } else {
			append newhtml <$tag>
		    }
		    set inkeyselect 0
		    set addoption 0
		}
		
		{default} {
		    append newhtml <$tag>
		}
	    }

	} else {
	    regexp {([^<]*)(.*)} $htmlpiece m brandnew htmlpiece
	    append newhtml $brandnew
	}
    }
    return $newhtml
}

proc ns_tagelement {tag key} {
    set qq {"([^"]*)"}                ; # Matches what's in quotes
    set pp {([^ >]*)}                 ; # Matches a word (mind yer pp and qq)
    
    if {[regexp -nocase "$key *= *$qq" $tag m name]} {}\
	    elseif {[regexp -nocase "$key *= *$pp" $tag m name]} {}\
	    else {set name ""}
    return $name
}


# Assumes that the final ">" in the tag has been removed, and
# leaves it removed

proc ns_tagelementset {tagvar key value} {

    upvar $tagvar tag

    set qq {"([^"]*)"}                ; # Matches what's in quotes
    set pp {([^ >]*)}                 ; # Matches a word (mind yer pp and qq)
    
    regsub -all -nocase "$key=$qq" $tag {} tag
    regsub -all -nocase "$key *= *$pp" $tag {} tag
    append tag " value=\"$value\""
}




# sorts a list of pairs based on the first value in each pair

proc _ns_paircmp {pair1 pair2} {
    if {[lindex $pair1 0] > [lindex $pair2 0]} {
	return 1
    } elseif {[lindex $pair1 0] < [lindex $pair2 0]} {
	return -1
    } else {
	return 0
    }
}

# ns_htmlselect ?-multi? ?-sort? ?-labels labels? key values ?selecteddata?

proc ns_htmlselect args {

    set multi 0
    set sort 0
    set labels {}
    while {[string index [lindex $args 0] 0] == "-"} {
	if {[lindex $args 0] == "-multi"} {
	    set multi 1
	    set args [lreplace $args 0 0]
	}
	if {[lindex $args 0] == "-sort"} {
	    set sort 1
	    set args [lreplace $args 0 0]
	}
	if {[lindex $args 0] == "-labels"} {
	    set labels [lindex $args 1]
	    set args [lreplace $args 0 1]
	}
    }
    
    set key [lindex $args 0]
    set values [lindex $args 1]
    
    if {[llength $args] == 3} {
	set selecteddata [lindex $args 2]
    } else {
	set selecteddata ""
    }
    
    set select "<SELECT NAME=$key"
    if {$multi == 1} {
	set size [llength $values]
	if {$size > 5} {
	    set size 5
	}
	append select " MULTIPLE SIZE=$size"
    } else {
	if {[llength $values] > 25} {
	    append select " SIZE=5"
	}
    }
    append select ">\n"
    set len [llength $values]
    set lvpairs {}
    for {set i 0} {$i < $len} {incr i} {
	if [string match "" $labels] {
	    set label [lindex $values $i]
	} else {
	    set label [lindex $labels $i]
	}
	regsub -all "\"" $label "" label
	lappend lvpairs [list  $label [lindex $values $i]]
    }
    if $sort {
	set lvpairs [lsort -command _ns_paircmp -increasing $lvpairs]
    }
    foreach lvpair $lvpairs {
	append select "<OPTION VALUE=\"[lindex $lvpair 1]\""
	if {[lsearch $selecteddata [lindex $lvpair 1]] >= 0} {
	    append select " SELECTED"
	}
	append select ">[lindex $lvpair 0]\n"
    }
    append select "</SELECT>"

    return $select
}

proc ns_setexpires args {
    # skip over the optional connId parameter: just use the last arg
    set secondsarg [expr [llength $args] - 1]

    ns_set update [ns_conn outputheaders] Expires \
	    [ns_httptime [expr [lindex $args $secondsarg] + [ns_time]]]
}

proc ns_browsermatch args {
    # skip over the optional connId parameter: just use the last arg
    set globarg [expr [llength $args] - 1]

    return [string match [lindex $args $globarg]  \
	    [ns_set iget [ns_conn headers] user-agent]]
}

proc ns_set_precision {precision} {
    global tcl_precision
    set tcl_precision $precision
}

proc ns_updateheader {key value} {
    ns_set update [ns_conn outputheaders] $key $value
}

ns_share NS
set NS(months) [list January February March April May June \
	July August September October November December]

proc ns_localsqltimestamp {} {
    set time [ns_localtime]

    return [format "%04d-%02d-%02d %02d:%02d:%02d" \
	    [expr [ns_parsetime year $time] + 1900] \
	    [expr [ns_parsetime mon $time] + 1] \
	    [ns_parsetime mday $time] \
	    [ns_parsetime hour $time] \
	    [ns_parsetime min $time] \
	    [ns_parsetime sec $time]]
}

proc ns_localsqldate {} {
    set time [ns_localtime]

    return [format "%04d-%02d-%02d" \
	    [expr [ns_parsetime year $time] + 1900] \
	    [expr [ns_parsetime mon $time] + 1] \
                [ns_parsetime mday $time]]
}

proc ns_parsesqldate {opt sqldate} {
    ns_share NS
    scan $sqldate "%04d-%02d-%02d" year month day

    switch $opt {
	month {return [lindex $NS(months) [expr $month - 1]]}
	day {return $day}
	year {return $year}
	default {error "Unknown option \"$opt\": should be year, month or day"}
    }
}
    
proc ns_parsesqltime {opt sqltime} {

    if {[scan $sqltime "%02d:%02d:%02d" hours minutes seconds] == 2} {
	set seconds 0
    }

    switch $opt {
	time {
	    if {$hours == 0} {
		set hours 12
	    } elseif {$hours > 12} {
		set hours [incr hours -12]
	    }
	    if {$seconds == 0} {
		return [format "%d:%02d" $hours $minutes]
	    } else {
		return [format "%d:%02d:%02d" $hours $minutes $seconds]
	    }
	}
	ampm {
	    if {$hours < 12} {
		return AM
	    } else {
		return PM
	    }
	}

	default {error "Unknown command \"$opt\": should be time or ampm"}
    }
}

proc ns_parsesqltimestamp {opt sqltimestamp} {

    switch $opt {
	month -
	day -
	year {return [ns_parsesqldate $opt [lindex [split $sqltimestamp " "] 0]]}
	time -
	ampm {return [ns_parsesqltime $opt [lindex [split $sqltimestamp " "] 1]]}
	default {error "Unknown command \"$opt\": should be month, day, year, time or ampm"}
    }
}

proc ns_buildsqltime {time ampm} {

    if {[string match "" $time] && [string match "" $ampm]} {
	return ""
    }

    if {[string match "" $time] || [string match "" $ampm]} {
	error "Invalid time: $time $ampm"
    }
    set seconds 0
    set num [scan $time "%d:%d:%d" hours minutes seconds]

    if {$num < 2 || $num > 3 \
	    || $hours < 1 || $hours > 12 \
	    || $minutes < 0 || $minutes > 59 \
	    || $seconds < 0 || $seconds > 61} {
	error "Invalid time: $time $ampm"
    }

    if {$ampm == "AM"} {
	if {$hours == 12} {
	    set hours 0
	}
    } elseif {$ampm == "PM"} {
	if {$hours != 12} {
	    incr hours 12
	}
    } else {
	error "Invalid time: $time $ampm"
    }

    return [format  "%02d:%02d:%02d" $hours $minutes $seconds]
}

proc ns_buildsqldate {month day year} {
    ns_share NS

    if {[string match "" $month] \
	    && [string match "" $day] \
	    && [string match "" $year]} {
	return ""
    }

    # MAC: Tcl is brain dead and if the user enters 08 or 09 for the 8th
    # or 9th of the month then "08" and "09" being octal, not integer
    # values, would fail the if check below.  month generally won't be
    # a problem since it will normally be a drop down select list, but
    # just in case...
    regsub {^0} $day "" day
    regsub {^0} $month "" month

    if {![ns_issmallint $month]} {
	set month [expr [lsearch $NS(months) $month] + 1]
    }

    if {[string match "" $month] \
	    || [string match "" $day] \
	    || [string match "" $year] \
	    || $month < 1 || $month > 12 \
	    || $day < 1 || $day > 31 \
	    || $year < 1\
            || ($month == 2 && $day > 29)\
            || (($year % 4) != 0 && $month == 2 && $day > 28) \
            || ($month == 4 && $day > 30)\
            || ($month == 6 && $day > 30)\
            || ($month == 9 && $day > 30)\
            || ($month == 11 && $day > 30) } {
	error "Invalid date: $month $day $year"
    }

    return [format "%04d-%02d-%02d" $year $month $day]
}

proc ns_buildsqltimestamp {month day year time ampm} {
    set date [ns_buildsqldate $month $day $year]
    set time [ns_buildsqltime $time $ampm]

    if {[string match "" $date] || [string match "" $time]} {
	return ""
    }

    return "$date $time"
}

# ns_localtime returns a time as a list of elements, and ns_parsetime
# returns one of those elements

proc ns_parsetime {option time} {
    set parts {sec min hour mday mon year wday yday isdst}
    set pos [lsearch $parts $option]
    if {$pos == -1} {
	error "Incorrect option to ns_parsetime: \"$option\" Should be\
               one of \"$parts\""
    }
    return [lindex $time $pos]
}

# ns_findset returns a set with a given name from a list.

proc ns_findset {sets name} {
    foreach set $sets {
	if {[ns_set name $set] == $name} {
	    return $set
	}
    }
    return ""
}

# getformdata - make sure an HTML FORM was sent with the request.
proc getformdata {conn formVar} {
	upvar $formVar form
	set form [ns_conn form $conn]
	if [string match "" $form] {
		ns_returnbadrequest $conn "Missing HTML FORM data"
		return 0
	}
	return 1
}

proc ns_paren {val} {
    if {$val != ""} {
	return "($val)"
    } else {
	return ""
    }
}

proc Paren {val} {
    return [ns_paren $val]
}

proc issmallint {value} {
    return [ns_issmallint $value]
}

proc ns_issmallint {value} {
    return [expr [regexp {^[0-9]+$} $value] && [string length $value] <= 6]
}

proc _ns_updatebutton {db table var} {
    upvar $var updatebutton

    if ![info exists updatebutton] {
	set updatebutton ""
    }
    if [string match "" $updatebutton] {
	set updatebutton [ns_table value $db $table update_button_label]
    }
    if [string match "" $updatebutton] {
	set updatebutton "Update Record"
    }
}

proc ns_findrowbyid {db table rowidset} {

    set sql "select * from [ns_dbquotename $table] where"
    for {set i 0} {$i < [ns_set size $rowidset]} {incr i} {
	if {$i != 0} {
	    append sql " and"
	}
	set column [ns_urldecode [ns_set key $rowidset $i]]
	set value [ns_set value $rowidset $i]
	set type [ns_column type $db $table $column]
	append sql " [ns_dbquotename $column] = [ns_dbquotevalue $value $type]"
    }
    if [catch {
	set row [ns_db 1row $db $sql]
    } errMsg] {
	ns_db setexception $db NSINT "Could not find row"
	error $errMsg
    }
    return $row
}

# open a file with exclusive rights.  This call can fail (if you
# try to open-create-exclusive and the file already exists).  If this
# happens, "" is returned, in which case you need to generate a new
# name and try again
proc ns_openexcl {file} {

    if [catch { set fp [open $file {RDWR CREAT EXCL} ] } err] {

	global errorCode

	if { [lindex $errorCode 1] != "EEXIST"} {
	    return -code error $err
	}

	return ""
    }

    return $fp

}

proc _http_read {timeout sock length} {

    return [_ns_http_read $timeout $sock $length]

} ;# _http_read



# tcl page support

set tcl_pages_enabled [ns_config -bool ns/server/[ns_info server] EnableTclPages]

if {$tcl_pages_enabled == "1" && ![ad_parameter "EnableAbstractURLsP" "" 0]} {
    ns_register_proc GET /*.tcl ns_sourceproc
    ns_register_proc POST /*.tcl ns_sourceproc
    ns_register_proc HEAD /*.tcl ns_sourceproc
    ns_register_proc PUT /*.tcl ns_putscript
}

proc ns_sourceproc {conn ignored} {
	set script [ns_url2file [ns_conn url $conn]]
	if ![file exists $script] {
		ns_returnnotfound $conn
	} else {
		source $script
	}
}

proc ns_putscript {conn ignored} {
	ns_returnbadrequest $conn "Cannot PUT a script file"
}

proc _ns_dateentrywidget {column} {
    ns_share NS

    set output "<SELECT name=ColValue.[ns_urlencode $column].month>\n"
    for {set i 0} {$i < 12} {incr i} {
	append output "<OPTION> [lindex $NS(months) $i]\n"
    }

    append output \
"</SELECT>&nbsp;<INPUT NAME=ColValue.[ns_urlencode $column].day\
TYPE=text SIZE=3 MAXLENGTH=2>&nbsp;<INPUT NAME=ColValue.[ns_urlencode $column].year\
TYPE=text SIZE=5 MAXLENGTH=4>"

    return [ns_dbformvalueput $output $column date [lindex [split [ns_localsqltimestamp] " "] 0]]
}

proc _ns_timeentrywidget {column} {
    
    set output "<INPUT NAME=ColValue.[ns_urlencode $column].time TYPE=text SIZE=9>&nbsp;<SELECT NAME=ColValue.[ns_urlencode $column].ampm>
<OPTION> AM
<OPTION> PM
</SELECT>"

    return [ns_dbformvalueput $output $column time [lindex [split [ns_localsqltimestamp] " "] 1]]
}