# 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
# and
# 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
# and
# 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 ""
if {$snam != ""} {
if {[info exists database_values($snam)] && $sflg} {
append txt "