Index: openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl,v
diff -u -r1.33 -r1.34
--- openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 2 Aug 2003 00:40:01 -0000 1.33
+++ openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 28 Aug 2003 09:41:43 -0000 1.34
@@ -4,15 +4,15 @@
@author Various (acs@arsdigita.com)
@creation-date 13 April 2000
- @cvs-id $Id$
+ @cvs-id utilities-procs.tcl,v 1.19.2.18 2003/06/06 21:40:37 donb Exp
}
# Let's define the nsv arrays out here, so we can call nsv_exists
# on their keys without checking to see if it already exists.
# we create the array by setting a bogus key.
proc proc_source_file_full_path {proc_name} {
- if ![nsv_exists proc_source_file $proc_name] {
+ if { ![nsv_exists proc_source_file $proc_name] } {
return ""
} else {
set tentative_path [nsv_get proc_source_file $proc_name]
@@ -99,7 +99,7 @@
# check to make sure path is to an authorized directory
set tmpdir_list [ad_parameter_all_values_as_list TmpDir]
- if [empty_string_p $tmpdir_list] {
+ if { [empty_string_p $tmpdir_list] } {
set tmpdir_list [list "/var/tmp" "/tmp"]
}
@@ -122,27 +122,27 @@
# see if this is one of the typed variables
global ad_typed_form_variables
- if [info exists ad_typed_form_variables] {
+ if { [info exists ad_typed_form_variables] } {
foreach typed_var_spec $ad_typed_form_variables {
set typed_var_name [lindex $typed_var_spec 0]
- if ![string match $typed_var_name $name] {
+ if { ![string match $typed_var_name $name] } {
# no match. Go to the next variable in the list
continue
}
# the variable matched the pattern
set typed_var_type [lindex $typed_var_spec 1]
- if [string match "" $typed_var_type] {
+ if { [string match "" $typed_var_type] } {
# if they don't specify a type, the default is 'integer'
set typed_var_type integer
}
set variable_safe_p [ad_var_type_check_${typed_var_type}_p $value]
- if !$variable_safe_p {
+ if { !$variable_safe_p } {
ns_returnerror 500 "variable $name failed '$typed_var_type' type check"
ns_log Error "[ad_conn url] called with \$$name = $value"
error "variable $name failed '$typed_var_type' type check"
@@ -361,13 +361,13 @@
return_url. if database insert fails, this procedure will return a
sensible error message to the user.
} {
- if [catch {
+ if { [catch {
if { ![empty_string_p $bind] } {
db_dml $statement_name $insert_dml -bind $bind
} else {
db_dml $statement_name $insert_dml
}
- } errmsg] {
+ } errmsg] } {
# Oracle choked on the insert
# detect double click
@@ -408,7 +408,7 @@
Converts 1998-09-05 to September 5, 1998
} {
set sql_date [string range $sql_date 0 9]
- if ![regexp {(.*)-(.*)-(.*)$} $sql_date match year month day] {
+ if { ![regexp {(.*)-(.*)-(.*)$} $sql_date match year month day] } {
return ""
} else {
set allthemonths {January February March April May June July August September October November December}
@@ -613,6 +613,8 @@
-url:boolean
-quotehtml:boolean
-entire_form:boolean
+ -no_empty:boolean
+ {-base}
{-exclude {}}
{-override {}}
{vars {}}
@@ -746,6 +748,13 @@
@param entire_form Export the entire form from the GET query string or the POST.
+ @option no_empty If specified, variables with an empty string value will be suppressed from being exported.
+ This avoids cluttering up the URLs with lots of unnecessary variables.
+
+ @option base The base URL to make a link to. This will be prepended to the query string
+ along with a question mark (?), if the query is non-empty. so the returned
+ string can be used directly in a link. This is only relevant to URL export.
+
@author Lars Pind (lars@pinds.com)
@creation-date December 7, 2000
} {
@@ -825,18 +834,50 @@
}
if { [llength $var_spec] > 1 } {
- set exp_value($name) [uplevel subst \{[lindex $var_spec 1]\}]
+ set value [uplevel subst \{[lindex $var_spec 1]\}]
+ if { !$no_empty_p || ![empty_string_p $value] } {
+ set exp_value($name) $value
+ }
} else {
upvar 1 $name upvar_variable
if { [info exists upvar_variable] } {
if { [array exists upvar_variable] } {
- set exp_value($name) [array get upvar_variable]
+ if { $no_empty_p } {
+ # If the no_empty_p flag is set, remove empty string values first
+ set exp_value($name) [list]
+ foreach { key value } [array get upvar_variable] {
+ if { ![empty_string_p $value] } {
+ lappend exp_value($name) $key $value
+ }
+ }
+ } else {
+ # If no_empty_p isn't set, just do an array get
+ set exp_value($name) [array get upvar_variable]
+ }
set exp_flag($name:array) 1
} else {
- set exp_value($name) $upvar_variable
if { [info exists exp_flag($name:array)] } {
return -code error "Variable \"$name\" is not an array"
}
+ if { !$no_empty_p } {
+ set exp_value($name) $upvar_variable
+ } else {
+ # no_empty_p flag set, remove empty strings
+ if { [info exists exp_flag($name:multiple)] } {
+ # This is a list, remove empty entries
+ set exp_value($name) [list]
+ foreach elm $upvar_variable {
+ if { ![empty_string_p $elm] } {
+ lappend exp_value($name) $elm
+ }
+ }
+ } else {
+ # Simple value, this is easy
+ if { ![empty_string_p $upvar_variable] } {
+ set exp_value($name) $upvar_variable
+ }
+ }
+ }
}
}
}
@@ -920,6 +961,15 @@
if { $quotehtml_p } {
set export_string [ad_quotehtml $export_string]
}
+
+ # Prepend with the base URL
+ if { [exists_and_not_null base] } {
+ if { ![empty_string_p $export_string] } {
+ set export_string "$base?$export_string"
+ } else {
+ set export_string $base
+ }
+ }
return $export_string
}
@@ -1165,12 +1215,12 @@
@see export_vars
} {
- if [empty_string_p $setid] {
+ if { [empty_string_p $setid] } {
set setid [ns_getform]
}
set return_list [list]
- if ![empty_string_p $setid] {
+ if { ![empty_string_p $setid] } {
set set_size [ns_set size $setid]
set set_counter_i 0
while { $set_counter_i<$set_size } {
@@ -1321,7 +1371,7 @@
proc with_catch {error_var body on_error} {
upvar 1 $error_var $error_var
global errorInfo errorCode
- if [catch { uplevel $body } $error_var] {
+ if { [catch { uplevel $body } $error_var] } {
set code [catch {uplevel $on_error} string]
# Return out of the caller appropriately.
if { $code == 1 } {
@@ -1407,7 +1457,7 @@
@see util_get_http_status
} {
- if [catch { set status [util_get_http_status $url] } errmsg] {
+ if { [catch { set status [util_get_http_status $url] } errmsg] } {
# got an error; definitely not valid
return 0
} else {
@@ -1433,19 +1483,19 @@
Like ns_httpopen but works for POST as well; called by util_httppost
} {
- if ![string match http://* $url] {
+ if { ![string match http://* $url] } {
return -code error "Invalid url \"$url\": _httpopen only supports HTTP"
}
set url [split $url /]
set hp [split [lindex $url 2] :]
set host [lindex $hp 0]
set port [lindex $hp 1]
- if [string match $port ""] {set port 80}
+ if { [string match $port ""] } {set port 80}
set uri /[join [lrange $url 3 end] /]
set fds [ns_sockopen -nonblock $host $port]
set rfd [lindex $fds 0]
set wfd [lindex $fds 1]
- if [catch {
+ if { [catch {
_ns_http_puts $timeout $wfd "$method $uri HTTP/1.0\r"
if {$rqset != ""} {
for {set i 0} {$i < [ns_set size $rqset]} {incr i} {
@@ -1460,11 +1510,11 @@
_ns_http_puts $timeout $wfd "Referer: $http_referer \r"
}
- } errMsg] {
+ } errMsg] } {
global errorInfo
#close $wfd
#close $rfd
- if [info exists rpset] {ns_set free $rpset}
+ if { [info exists rpset] } {ns_set free $rpset}
return -1
}
return [list $rfd $wfd ""]
@@ -1487,7 +1537,7 @@
@see util_http_file_upload
} {
- if [catch {
+ if { [catch {
if {[incr depth] > 10} {
return -code error "util_httppost: Recursive redirection: $url"
}
@@ -1507,7 +1557,7 @@
set rpset [ns_set new [_ns_http_gets $timeout $rfd]]
while 1 {
set line [_ns_http_gets $timeout $rfd]
- if ![string length $line] break
+ if { ![string length $line] } break
ns_parseheader $rpset $line
}
@@ -1523,12 +1573,12 @@
}
}
set length [ns_set iget $headers content-length]
- if [string match "" $length] {set length -1}
+ if { [string match "" $length] } {set length -1}
set err [catch {
while 1 {
set buf [_ns_http_read $timeout $rfd $length]
append page $buf
- if [string match "" $buf] break
+ if { [string match "" $buf] } break
if {$length > 0} {
incr length -[string length $buf]
if {$length <= 0} break
@@ -1541,7 +1591,7 @@
global errorInfo
return -code error -errorinfo $errorInfo $errMsg
}
- } errmgs ] {return -1}
+ } errmgs ] } {return -1}
return $page
}
@@ -1625,13 +1675,13 @@
close $rfd
} else {
set length [ns_set iget $headers content-length]
- if [string match "" $length] {set length -1}
+ if { [string match "" $length] } {set length -1}
set err [catch {
while 1 {
set buf [_ns_http_read $timeout $rfd $length]
append page $buf
- if [string match "" $buf] break
+ if { [string match "" $buf] } break
if {$length > 0} {
incr length -[string length $buf]
if {$length <= 0} break
@@ -2087,7 +2137,7 @@
ns_startcontent -type $content_type
- if ![empty_string_p $first_part_of_page] {
+ if { ![empty_string_p $first_part_of_page] } {
ns_write $first_part_of_page
}
}
@@ -2519,6 +2569,7 @@
if {$use_metarefresh_p != 0} {
util_ReturnMetaRefresh $url
} else {
+ ns_log Notice "Huh? redirecting: $url"
ns_returnredirect $url
}
}
@@ -3061,7 +3112,7 @@
empty_string.
} {
upvar $var_name $var_name
- if [info exists $var_name] {
+ if { [info exists $var_name] } {
return [set $var_name]
}
}
@@ -3115,7 +3166,7 @@
set tag_names [list div font]
# look for a less than sign, zero or more spaces, then the tag
if { ! [empty_string_p $tag_names]} {
- if [regexp "< *([join $tag_names "\[ \n\t\r\f\]|"]\[ \n\t\r\f\])" [string tolower $user_submitted_html]] {
+ if { [regexp "< *([join $tag_names "\[ \n\t\r\f\]|"]\[ \n\t\r\f\])" [string tolower $user_submitted_html]] } {
return "
For security reasons we do not accept the submission of any HTML
containing the following tags:
[join $tag_names " "]"
}
@@ -3406,7 +3457,7 @@
append payload --$boundary-- \r\n
- if [catch {
+ if { [catch {
if {[incr depth -1] <= 0} {
return -code error "util_http_file_upload:\
Recursive redirection: $url"
@@ -3427,20 +3478,20 @@
set rpset [ns_set new [_ns_http_gets $timeout $rfd]]
while 1 {
set line [_ns_http_gets $timeout $rfd]
- if ![string length $line] break
+ if { ![string length $line] } break
ns_parseheader $rpset $line
}
set headers $rpset
set response [ns_set name $headers]
set status [lindex $response 1]
set length [ns_set iget $headers content-length]
- if [string match "" $length] { set length -1 }
+ if { [string match "" $length] } { set length -1 }
set err [catch {
while 1 {
set buf [_ns_http_read $timeout $rfd $length]
append page $buf
- if [string match "" $buf] break
+ if { [string match "" $buf] } break
if {$length > 0} {
incr length -[string length $buf]
if {$length <= 0} break
@@ -3455,7 +3506,7 @@
global errorInfo
return -code error -errorinfo $errorInfo $errMsg
}
- } errmsg] {return -1}
+ } errmsg] } {return -1}
return $page
}
@@ -3471,7 +3522,6 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-
# Version 1.0 implemented Base64_Encode, Bae64_Decode
# Version 2.0 uses the base64 namespace
# Version 2.1 fixes various decode bugs and adds options to encode