# rename to utilities.tcl and put where the AOLserver will load 
# on startup ( ~nsadmin/modules/tcl/utilities.tcl ).

# we use this when we want to send out just the headers 
# and then do incremental ns_writes.  This way the user
# doesn't have to wait like if you used a single ns_return

proc ReturnHeaders {conn {content_type text/html}} {

    ns_write $conn "HTTP/1.0 200 OK
MIME-Version: 1.0
Content-Type: $content_type

"

}

proc ReturnHeadersWithCookie {conn cookie_content {content_type text/html}} {

    ns_write $conn "HTTP/1.0 200 OK
MIME-Version: 1.0
Content-Type: $content_type
Set-Cookie:  $cookie_content

"

}

# stuff to process the data that comes 
# back from the users

# if the form looked like
# <input type=text name=yow> and <input type=text name=bar> 
# then after you run this function you'll have Tcl vars 
# $foo and $bar set to whatever the user typed in the form

# this uses the initially nauseating but ultimately delicious
# Tcl system function "uplevel" that lets a subroutine bash
# the environment and local vars of its caller.  It ain't Common Lisp...

proc set_form_variables {{error_if_not_found_p 1}} {
    if { $error_if_not_found_p == 1} {
	uplevel { if { [ns_conn form $conn] == "" } {
	    ns_returnerror $conn 500 "Missing form data"
	    return
	}
       }
     } else {
	 uplevel { if { [ns_conn form $conn] == "" } {
	     # we're not supposed to barf at the user but we want to return
	     # from this subroutine anyway because otherwise we'd get an error
	     return
	 }
     }
  }

    # at this point we know that the form is legal
    
    uplevel {
	set form [ns_conn form $conn] 
	set form_size [ns_set size $form]
	set form_counter_i 0
	while {$form_counter_i<$form_size} {
	    set [ns_set key $form $form_counter_i] [ns_set value $form $form_counter_i]
	    incr form_counter_i
	}
    }
}

proc DoubleApos {string} {
    regsub -all ' "$string" '' result
    return $result
}

# if the user types "O'Malley" and you try to insert that into an SQL
# database, you will lose big time because the single quote is magic
# in SQL and the insert has to look like 'O''Malley'.  This function
# also trims white space off the ends of the user-typed data.

# if the form looked like
# <input type=text name=yow> and <input type=text name=bar> 
# then after you run this function you'll have Tcl vars 
# $QQfoo and $QQbar set to whatever the user typed in the form
# plus an extra single quote in front of the user's single quotes
# and maybe some missing white space

proc set_form_variables_string_trim_DoubleAposQQ {} {
    uplevel {
	set form [ns_conn form $conn] 
	if {$form == ""} {
	    ns_returnerror $conn 500 "Missing form data"
	    return;
	}
	set form_size [ns_set size $form]
	set form_counter_i 0
	while {$form_counter_i<$form_size} {
	    set QQ[ns_set key $form $form_counter_i] [DoubleApos [string trim [ns_set value $form $form_counter_i]]]
	    incr form_counter_i
	}
    }
}

proc set_form_variables_string_trim_DoubleApos {} {
    uplevel {
	set form [ns_conn form $conn] 
	if {$form == ""} {
	    ns_returnerror $conn 500 "Missing form data"
	    return;
	}
	set form_size [ns_set size $form]
	set form_counter_i 0
	while {$form_counter_i<$form_size} {
	    set [ns_set key $form $form_counter_i] [DoubleApos [string trim [ns_set value $form $form_counter_i]]]
	    incr form_counter_i
	}
    }
}


proc set_form_variables_string_trim {} {
    uplevel {
	set form [ns_conn form $conn] 
	if {$form == ""} {
	    ns_returnerror $conn 500 "Missing form data"
	    return;
	}
	set form_size [ns_set size $form]
	set form_counter_i 0
	while {$form_counter_i<$form_size} {
	    set [ns_set key $form $form_counter_i] [string trim [ns_set value $form $form_counter_i]]
	    incr form_counter_i
	}
    }
}


# a philg hack for getting all the values from a set of checkboxes
# returns 0 if none are checked, a Tcl list with the values otherwise 

proc nmc_GetCheckboxValues {form checkbox_name} {

    set i 0
    set size [ns_set size $form]

    while {$i<$size} {

	if { [ns_set key $form $i] == $checkbox_name} {

	    # LIST_TO_RETURN will be created if it doesn't exist

	    lappend list_to_return [ns_set value $form $i]

	}
	incr i
    }

    if { [info exists list_to_return] } { return $list_to_return } else {return 0}

}


##
#  Database-related code
##

proc nmc_GetNewIDNumber {id_name db} {

    ns_db dml $db "begin transaction;"
    ns_db dml $db "update id_numbers set $id_name = $id_name + 1;"
    set id_number [ns_set value\
	    [ns_db 1row $db "select unique $id_name from id_numbers;"] 0]
    ns_db dml $db "end transaction;"

    return $id_number

}


# if you do a 
#   set selection [ns_db 1row $db "select foo,bar from my_table where key=37"]
#   set_variables_after_query
# then you will find that the Tcl vars $foo and $bar are set to whatever
# the database returned.  If you don't like these var names, you can say
#   set selection [ns_db 1row $db "select count(*) as n_rows from my_table"]
#   set_variables_after_query
# and you will find the Tcl var $n_rows set

# You can also use this in a multi-row loop
#   set selection [ns_db select $db "select *,upper(email) from mailing_list order by upper(email)"]
#   while { [ns_db getrow $db $selection] } {
#        set_variables_after_query
#         ... your code here ...
#   }
# then the appropriate vars will be set during your loop

#
# CAVEAT NERDOR:  you MUST use the variable name "selection"
# 

#
# we pick long names for the counter and limit vars
# because we don't want them to conflict with names of
# database columns or in parent programs
#

proc set_variables_after_query {} {
    uplevel {
	    set set_variables_after_query_i 0
	    set set_variables_after_query_limit [ns_set size $selection]
	    while {$set_variables_after_query_i<$set_variables_after_query_limit} {
		set [ns_set key $selection $set_variables_after_query_i] [ns_set value $selection $set_variables_after_query_i]
		incr set_variables_after_query_i
	    }
    }
}

# as above, but you must use sub_selection

proc set_variables_after_subquery {} {
    uplevel {
	    set set_variables_after_query_i 0
	    set set_variables_after_query_limit [ns_set size $sub_selection]
	    while {$set_variables_after_query_i<$set_variables_after_query_limit} {
		set [ns_set key $sub_selection $set_variables_after_query_i] [ns_set value $sub_selection $set_variables_after_query_i]
		incr set_variables_after_query_i
	    }
    }
}

# takes a query like "select unique short_name from products where product_id = 45"
# and returns the result (only works when you are after a single row/column
# intersection)

proc database_to_tcl_string {db sql} {

    set selection [ns_db 1row $db $sql]

    return [ns_set value $selection 0]

}

# takes a query like "select product_id from foobar" and returns all
# the ids as a Tcl list

proc database_to_tcl_list {db sql} {
    
    set selection [ns_db select $db $sql]

    set list_to_return [list]

    while {[ns_db getrow $db $selection]} {

	lappend list_to_return [ns_set value $selection 0]

    }

    return $list_to_return

}

proc nmc_IllustraDatetoPrettyDate {sql_date} {

    regexp {(.*)-(.*)-(.*)$} $sql_date match year month day

    set allthemonths {January February March April May June July August September October November December}

    # we have to trim the leading zero because Tcl has such a 
    # brain damaged model of numbers and decided that "09-1"
    # was "8.0"

    set trimmed_month [string trimleft $month 0]
    set pretty_month [lindex $allthemonths [expr $trimmed_month - 1]]

    return "$pretty_month $day, $year"

}

proc util_IllustraDatetoPrettyDate {sql_date} {

    regexp {(.*)-(.*)-(.*)$} $sql_date match year month day

    set allthemonths {January February March April May June July August September October November December}

    # we have to trim the leading zero because Tcl has such a 
    # brain damaged model of numbers and decided that "09-1"
    # was "8.0"

    set trimmed_month [string trimleft $month 0]
    set pretty_month [lindex $allthemonths [expr $trimmed_month - 1]]

    return "$pretty_month $day, $year"

}

# from the new-utilities.tcl file

proc remove_nulls_from_ns_set {old_set_id} {

    set new_set_id [ns_set new "no_nulls$old_set_id"]

    for {set i 0} {$i<[ns_set size $old_set_id]} {incr i} {
	if { [ns_set value $old_set_id $i] != "" } {

	    ns_set put $new_set_id [ns_set key $old_set_id $i] [ns_set value $old_set_id $i]

	}

    }

    return $new_set_id

}

proc merge_form_with_ns_set {form set_id} {

    for {set i 0} {$i<[ns_set size $set_id]} {incr i} {
	set form [ns_formvalueput $form [ns_set key $set_id $i] [ns_set value $set_id $i]]
    }

    return $form

}

proc merge_form_with_query {form db query} {

    set set_id [ns_db 0or1row $db $query]

    if { $set_id != "" } {

	for {set i 0} {$i<[ns_set size $set_id]} {incr i} {
	    set form [ns_formvalueput $form [ns_set key $set_id $i] [ns_set value $set_id $i]]
	}

    }

    return $form

}

proc bt_mergepiece {htmlpiece values} {
    # HTMLPIECE is a form usually; VALUES is an ns_set

    # NEW VERSION DONE BY BEN ADIDA (ben@mit.edu)
    # This used to count the number of vars already introduced
    # in the form (see remaining num_vars statements), so as 
    # to end early. However, for some unknown reason, this cut off a number 
    # of forms. So now, this processes every tag in the HTML form.

    set newhtml ""
    
    set html_piece_ben $htmlpiece

    set num_vars 0

    for {set i 0} {$i<[ns_set size $values]} {incr i} {
	if {[ns_set key $values $i] != ""} {
	    set database_values([ns_set key $values $i]) [ns_set value $values $i]
	    incr num_vars
	} 
    }

    set vv {[Vv][Aa][Ll][Uu][Ee]}     ; # Sorta obvious
    set nn {[Nn][Aa][Mm][Ee]}         ; # This is too
    set qq {"([^"]*)"}                ; # Matches what's in quotes
    set pp {([^ ]*)}                  ; # Matches a word (mind yer pp and qq)

    set slist {}
    
    set count 0

    while {1} {

	incr count
	set start_point [string first < $html_piece_ben]
	if {$start_point==-1} {
	    append newhtml $html_piece_ben
	    break;
	}
	if {$start_point>0} {
	    append newhtml [string range $html_piece_ben 0 [expr $start_point - 1]]
	}
	set end_point [string first > $html_piece_ben]
	if {$end_point==-1} break
	incr start_point
	incr end_point -1
	set tag [string range $html_piece_ben $start_point $end_point]
	incr end_point 2
	set html_piece_ben [string range $html_piece_ben $end_point end]
	set CAPTAG [string toupper $tag]

	set first_white [string first " " $CAPTAG]
	set first_word [string range $CAPTAG 0 [expr $first_white - 1]]
	
	switch -regexp $CAPTAG {
	    
	    {^INPUT} {
		if {[regexp {TYPE=("IMAGE"|"SUBMIT"|"RESET"|IMAGE|SUBMIT|RESET)} $CAPTAG]} {
		    
		    ###
		    #   Ignore these
		    ###
		    
		    append newhtml <$tag>
		    
		} elseif {[regexp {TYPE=("CHECKBOX"|CHECKBOX)} $CAPTAG]} {
		    
		    ## If it's a CHECKBOX, we cycle through
		    #  all the possible ns_set pair to see if it should
		    ## end up CHECKED or not.
		    
		    if {[regexp "$nn=$qq" $tag m nam]} {}\
			    elseif {[regexp "$nn=$pp" $tag m nam]} {}\
			    else {set nam ""}
		    
		    if {[regexp "$vv=$qq" $tag m val]} {}\
			    elseif {[regexp "$vv=$pp" $tag m val]} {}\
			    else {set val ""}
		    
		    regsub -all {[Cc][Hh][Ee][Cc][Kk][Ee][Dd]} $tag {} tag
		    
		    if {[info exists database_values($nam)]} {
			if {$database_values($nam) == $val} {
			    append tag " checked"
			    incr num_vars -1
			}
		    }
		    
		    append newhtml <$tag>
		    
		} elseif {[regexp {TYPE=("RADIO"|RADIO)} $CAPTAG]} {
		    
		    ## If it's a RADIO, we remove all the other
		    #  choices beyond the first to keep from having
		    ## more than one CHECKED
		    
		    if {[regexp "$nn=$qq" $tag m nam]} {}\
			    elseif {[regexp "$nn=$pp" $tag m nam]} {}\
			    else {set nam ""}
		    
		    if {[regexp "$vv=$qq" $tag m val]} {}\
			    elseif {[regexp "$vv=$pp" $tag m val]} {}\
			    else {set val ""}
		    
		    #Modified by Ben Adida (ben@mit.edu) so that
		    # the checked tags are eliminated only if something
		    # is in the database. 
		    
		    if {[info exists database_values($nam)]} {
			regsub -all {[Cc][Hh][Ee][Cc][Kk][Ee][Dd]} $tag {} tag
			if {$database_values($nam)==$val} {
			    append tag " checked"
			    incr num_vars -1
			}
		    }
		    
		    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
		    
		    if {[regexp "$nn=$qq" $tag m nam]} {}\
			    elseif {[regexp "$nn=$pp" $tag m nam]} {}\
			    else {set nam ""}
		    
		    if {[info exists database_values($nam)]} {
			regsub -all "$vv=$qq" $tag {} tag
			regsub -all "$vv=$pp" $tag {} tag
			append tag " value=\"$database_values($nam)\""
			incr num_vars -1
		    }
		    append newhtml <$tag>
		}
	    }
	    
	    {^TEXTAREA} {
		
		###
		#   Fill in the middle of this tag
		###
		
		if {[regexp "$nn=$qq" $tag m nam]} {}\
			elseif {[regexp "$nn=$pp" $tag m nam]} {}\
			else {set nam ""}
		
		if {[info exists database_values($nam)]} {
		    while {![regexp {^<( *)/[Tt][Ee][Xx][Tt][Aa][Rr][Ee][Aa]} $html_piece_ben]} {
			regexp {^.[^<]*(.*)} $html_piece_ben m html_piece_ben
		    }
		    append newhtml <$tag>$database_values($nam)
		    incr num_vars -1
		} else {
		    append newhtml <$tag>
		}
	    }
	    
	    {^SELECT} {
		
		###
		#   Set the snam flag, and perhaps smul, too
		###
		
		set smul [regexp "MULTIPLE" $CAPTAG]
		
		set sflg 1
		
		if {[regexp "$nn=$qq" $tag m snam]} {}\
			elseif {[regexp "$nn=$pp" $tag m snam]} {}\
			else {set snam ""}
		
		lappend slist $snam
		
		append newhtml <$tag>
	    }
	    
	    {^OPTION} {
		
		###
		#   Find the value for this
		###
		
		if {$snam != ""} {
		    
		    if {[lsearch -exact $slist $snam] != -1} {regsub -all {[Ss][Ee][Ll][Ee][Cc][Tt][Ee][Dd]} $tag {} tag}
		    
		    if {[regexp "$vv=$qq" $tag m opt]} {}\
			    elseif {[regexp "$vv=$pp" $tag m opt]} {}\
			    else {set opt ""}
		    regexp {^([^<]*)(.*)} $html_piece_ben m txt html_piece_ben
		    if {$opt == ""} {set val [string trim $txt]} else {set val $opt}
		    
		    if {[info exists database_values($snam)]} {
			if {
			    ($smul || $sflg) &&
			    $database_values($snam) == $val
			} then {
			    append tag " selected"
			    incr num_vars -1
			    set sflg 0
			} 
		    } 
		}
		append newhtml <$tag>$txt
	    }
	    
	    {^/SELECT} {
		    
		###
		#   Do we need to add to the end?
		###
		
		set txt "<BEN TESTING>"
		
		if {$snam != ""} {
		    if {[info exists database_values($snam)] && $sflg} {
			append txt "<option selected>$database_values($snam)"
			incr num_vars -1
			if {!$smul} {set snam ""}
		    }
		}
		
		append newhtml $txt<$tag>
	    }
	    
	    {default} {
		append newhtml <$tag>
	    }
	}
	
    }
    return $newhtml
}

# database stuff

proc util_GetNewIDNumber {id_name db} {

    ns_db dml $db "begin transaction;"
    ns_db dml $db "update id_numbers set $id_name = $id_name + 1;"
    set id_number [ns_set value\
	    [ns_db 1row $db "select unique $id_name from id_numbers;"] 0]
    ns_db dml $db "end transaction;"

    return $id_number

}

proc util_prepare_update {db table_name primary_key_name primary_key_value form} {

    set form_size [ns_set size $form]
    set form_counter_i 0
    while {$form_counter_i<$form_size} {

	set form_var_name [ns_set key $form $form_counter_i]
	set value [ns_set value $form $form_counter_i]

	if { $form_var_name != $primary_key_name } {

	    set column_type [ns_column type $db $table_name $form_var_name]

	    # we use the NaviServer built-in function quoted_value
	    # which is part of the nsdb tcl module (util.tcl)

	    set quoted_value [ns_dbquotevalue $value $column_type]

	    lappend the_sets "$form_var_name = $quoted_value"


	}

	incr form_counter_i
    }

    set primary_key_type [ns_column type $db $table_name $primary_key_name]

    return "update $table_name\nset [join $the_sets ",\n"] \n where $primary_key_name = [ns_dbquotevalue $primary_key_value $primary_key_type]"
    
}

proc util_prepare_update_multi_key {db table_name primary_key_name_list primary_key_value_list form} {

    set form_size [ns_set size $form]
    set form_counter_i 0
    while {$form_counter_i<$form_size} {

	set form_var_name [ns_set key $form $form_counter_i]
	set value [ns_set value $form $form_counter_i]

	if { [lsearch -exact $primary_key_name_list $form_var_name] == -1 } {

	    # this is not one of the keys

	    set column_type [ns_column type $db $table_name $form_var_name]

	    # we use the NaviServer built-in function quoted_value
	    # which is part of the nsdb tcl module (util.tcl)

	    set quoted_value [ns_dbquotevalue $value $column_type]

	    lappend the_sets "$form_var_name = $quoted_value"


	}

	incr form_counter_i
    }

    for {set i 0} {$i<[llength $primary_key_name_list]} {incr i} {

	set this_key_name [lindex $primary_key_name_list $i]
	set this_key_value [lindex $primary_key_value_list $i]
	set this_key_type [ns_column type $db $table_name $this_key_name]

	lappend key_eqns "$this_key_name = [ns_dbquotevalue $this_key_value $this_key_type]"

    }

    return "update $table_name\nset [join $the_sets ",\n"] \n where [join $key_eqns " AND "]"
    
}

proc util_prepare_insert {db table_name primary_key_name primary_key_value form} {

    set form_size [ns_set size $form]
    set form_counter_i 0
    while {$form_counter_i<$form_size} {

	set form_var_name [ns_set key $form $form_counter_i]
	set value [ns_set value $form $form_counter_i]

	if { $form_var_name != $primary_key_name } {

	    set column_type [ns_column type $db $table_name $form_var_name]

	    # we use the NaviServer built-in function quoted_value
	    # which is part of the nsdb tcl module (util.tcl)

	    set quoted_value [ns_dbquotevalue $value $column_type]

	    lappend the_names $form_var_name
	    lappend the_vals $quoted_value


	}

	incr form_counter_i
    }

    set primary_key_type [ns_column type $db $table_name $primary_key_name]

    return "insert into $table_name\n($primary_key_name,[join $the_names ","]) \n values ([ns_dbquotevalue $primary_key_value $primary_key_type],[join $the_vals ","])"
    
}

proc util_prepare_insert_string_trim {db table_name primary_key_name primary_key_value form} {

    set form_size [ns_set size $form]
    set form_counter_i 0
    while {$form_counter_i<$form_size} {

	set form_var_name [ns_set key $form $form_counter_i]
	set value [string trim [ns_set value $form $form_counter_i]]

	if { $form_var_name != $primary_key_name } {

	    set column_type [ns_column type $db $table_name $form_var_name]

	    # we use the NaviServer built-in function quoted_value
	    # which is part of the nsdb tcl module (util.tcl)

	    set quoted_value [ns_dbquotevalue $value $column_type]

	    lappend the_names $form_var_name
	    lappend the_vals $quoted_value


	}

	incr form_counter_i
    }

    set primary_key_type [ns_column type $db $table_name $primary_key_name]

    return "insert into $table_name\n($primary_key_name,[join $the_names ","]) \n values ([ns_dbquotevalue $primary_key_value $primary_key_type],[join $the_vals ","])"
    
}

proc util_prepare_insert_no_primary_key {db table_name form} {

    set form_size [ns_set size $form]
    set form_counter_i 0
    while {$form_counter_i<$form_size} {

	set form_var_name [ns_set key $form $form_counter_i]
	set value [ns_set value $form $form_counter_i]

	set column_type [ns_column type $db $table_name $form_var_name]

	# we use the NaviServer built-in function quoted_value
	# which is part of the nsdb tcl module (util.tcl)

	set quoted_value [ns_dbquotevalue $value $column_type]

	lappend the_names $form_var_name
	lappend the_vals $quoted_value

	incr form_counter_i
    }


    return "insert into $table_name\n([join $the_names ","]) \n values ([join $the_vals ","])"
    
}

proc util_PrettySex {m_or_f} {

    if { $m_or_f == "M" || $m_or_f == "m" } {

	return "Male"

    } elseif { $m_or_f == "F" || $m_or_f == "f" } {

	return "Female"

    } else {

	return "Unknown (\"$m_or_f\")"

    }

}

proc Memoize {tcl_statement} {

    global generic_cache

    # we look up the statement in the cache to see if it has already
    # been eval'd.  The statement itself is the key

    if { ![info exists generic_cache($tcl_statement)] } {

	# not in the cache already

	set statement_value [eval $tcl_statement]

	set generic_cache($tcl_statement) $statement_value

    }

    return $generic_cache($tcl_statement)

}

# for when you want to make other users of Memoize see an update

proc Memoize_Force {tcl_statement} {

    global generic_cache

    set statement_value [eval $tcl_statement]

    set generic_cache($tcl_statement) $statement_value

    return $generic_cache($tcl_statement)

}

proc current_year {db} {

    Memoize "current_year_internal $db"

}

proc current_year_internal {db} {

    database_to_tcl_string $db "return extract(year from current_date)"

}

proc philg_server_default_pool {} {
    set server_name [ns_info server]
    append config_path "ns\\server\\" $server_name "\\db"
    set default_pool [ns_config $config_path DefaultPool]
    return $default_pool
}

# this is typically called like this...
# philg_urldecode_form_variable [ns_conn form $conn]
# and it is called for effect, not value
# we use it if we've urlencoded something for a hidden
# variable (e.g., to escape the string quotes) in a form

proc philg_urldecode_form_variable {form variable_name} {
    set old_value [ns_set get $form $variable_name]
    set new_value [ns_urldecode $old_value]
    # one has to delete the old value first, otherwise
    # you just get two values for the same key in the ns_set
    ns_set delkey $form $variable_name
    ns_set put $form $variable_name $new_value
}

proc util_convert_plaintext_to_html {raw_string} {
    if { [regexp -nocase {<p>} $raw_string] || [regexp -nocase {<br>} $raw_string] } {
	# user was already trying to do this as HTML
	return $raw_string
    } else {
	regsub -all "\015\012\015\012" $raw_string "\n\n<p>\n\n" plus_para_tags
	return $plus_para_tags
    }

}

# turn " into &quot; before using strings inside hidden vars

proc philg_quote_double_quotes {arg} {
    regsub -all \" $arg \\&quot\; arg
    return $arg
}

proc util_GetUserAgentHeader {conn} {
    set header [ns_conn headers $conn]

    # note that this MUST be case-insensitive search (iget)
    # due to a NaviServer bug -- philg 2/1/96

    set userag [ns_set iget $header "USER-AGENT"]
    return $userag
}

proc msie_p {conn} {
    return [regexp -nocase {msie} [util_GetUserAgentHeader $conn]]
}