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 -N -r1.141 -r1.142
--- openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 21 Apr 2016 10:02:09 -0000 1.141
+++ openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 7 Aug 2017 23:48:00 -0000 1.142
@@ -23,19 +23,19 @@
} {
set zip [util::which zip]
if {$zip eq ""} {
- error "zip command not found on the system."
+ error "zip command not found on the system."
}
set cmd [list exec]
switch $::tcl_platform(platform) {
- windows {lappend cmd cmd.exe /c}
- default {lappend cmd bash -c}
+ windows {lappend cmd cmd.exe /c}
+ default {lappend cmd bash -c}
}
if {[file isfile $source]} {
- set filename [file tail $source]
- set in_path [file dirname $source]
+ set filename [file tail $source]
+ set in_path [file dirname $source]
} else {
- set filename "."
- set in_path $source
+ set filename "."
+ set in_path $source
}
# To avoid having the full path of the file included in the archive,
# we must first cd to the source directory. zip doesn't have an option
@@ -76,11 +76,11 @@
proc proc_source_file_full_path {proc_name} {
if { ![nsv_exists proc_source_file $proc_name] } {
- return ""
+ return ""
} else {
- set tentative_path [nsv_get proc_source_file $proc_name]
- regsub -all {/\./} $tentative_path {/} result
- return $result
+ set tentative_path [nsv_get proc_source_file $proc_name]
+ regsub -all {/\./} $tentative_path {/} result
+ return $result
}
}
@@ -94,9 +94,9 @@
set tentative_path [info script]
regsub -all {/\./} $tentative_path {/} scrubbed_path
if { $extra_message eq "" } {
- set message "Loading $scrubbed_path"
+ set message "Loading $scrubbed_path"
} else {
- set message "Loading $scrubbed_path; $extra_message"
+ set message "Loading $scrubbed_path; $extra_message"
}
ns_log Notice $message
}
@@ -167,9 +167,9 @@
set passed_check_p 0
# check to make sure path is to an authorized directory
- set tmpdir_list [ad_parameter_all_values_as_list TmpDir]
+ set tmpdir_list [ad_parameter_all_values_as_list -package_id [ad_conn subsite_id] TmpDir]
if { $tmpdir_list eq "" } {
- set tmpdir_list [list "/var/tmp" "/tmp"]
+ set tmpdir_list [list [ns_config ns/parameters tmpdir] "/var/tmp" "/tmp"]
}
foreach tmpdir $tmpdir_list {
@@ -182,7 +182,7 @@
if { !$passed_check_p } {
error "You specified a path to a file that is not allowed on the system!"
}
-
+
}
# integrates with the ad_set_typed_form_variable_filter system
@@ -195,22 +195,22 @@
foreach typed_var_spec $ad_typed_form_variables {
set typed_var_name [lindex $typed_var_spec 0]
-
+
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 { "" eq $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 } {
ns_returnerror 500 "variable $name failed '$typed_var_type' type check"
ns_log Error "check_for_form_variable_naughtiness: [ad_conn url] called with \$$name = $value"
@@ -249,15 +249,21 @@
} {
set result ""
for {set i 0} {$i<[ns_set size $set_id]} {incr i} {
- append result "[ns_set key $set_id $i] : [ns_set value $set_id $i]\n"
+ append result "[ns_set key $set_id $i] : [ns_set value $set_id $i]\n"
}
return $result
}
-ad_proc -public get_referrer {} {
- gets the Referer for the headers
-} {
- return [ns_set get [ns_conn headers] Referer]
+ad_proc -public get_referrer {-relative:boolean} {
+ @return referer from the request headers.
+ @param relative return the refer without protocol and host
+} {
+ set url [ns_set get [ns_conn headers] Referer]
+ if {$relative_p} {
+ # In case the referrer URL has a protocol and host remove it
+ regexp {^[a-z]+://[^/]+(/.*)$} $url . url
+ }
+ return $url
}
##
@@ -270,7 +276,7 @@
} {
This proc is used for pages using double click protection. table_name
is table_name for which we are checking whether the double click
- occured. id_column_name is the name of the id table
+ occurred. id_column_name is the name of the id table
column. generated_id is the generated id, which is supposed to have
been generated on the previous page. return_url is url to which this
procedure will return redirect in the case of successful insertion in
@@ -281,41 +287,41 @@
sensible error message to the user.
} {
if { [catch {
- if { $bind ne "" } {
- db_dml $statement_name $insert_dml -bind $bind
- } else {
- db_dml $statement_name $insert_dml
- }
+ if { $bind ne "" } {
+ db_dml $statement_name $insert_dml -bind $bind
+ } else {
+ db_dml $statement_name $insert_dml
+ }
} errmsg] } {
- # Oracle choked on the insert
-
- # detect double click
+ # Oracle choked on the insert
+
+ # detect double click
if {
- [db_0or1row double_click_check "
-
- select 1 as one
- from $table_name
- where $id_column_name = :generated_id
-
- " -bind [ad_tcl_vars_to_ns_set generated_id]]
- } {
- ad_returnredirect $return_url
- return
- }
-
- ns_log Error "[info script] choked. Oracle returned error: $errmsg"
+ [db_0or1row double_click_check "
+
+ select 1 as one
+ from $table_name
+ where $id_column_name = :generated_id
+
+ " -bind [ad_tcl_vars_to_ns_set generated_id]]
+ } {
+ ad_returnredirect $return_url
+ return
+ }
+
+ ns_log Error "[info script] choked. Oracle returned error: $errmsg"
- ad_return_error "Error in insert" "
- We were unable to do your insert in the database.
- Here is the error that was returned:
-
-
-
- $errmsg
-
-
+ ad_return_error "Error in insert" "
+ We were unable to do your insert in the database.
+ Here is the error that was returned:
+
+
+
+ $errmsg
+
+
"
- return
+ return
}
ad_returnredirect $return_url
@@ -330,20 +336,20 @@
} {
set sql_date [string range $sql_date 0 9]
if { ![regexp {(.*)-(.*)-(.*)$} $sql_date match year month day] } {
- return ""
+ return ""
} else {
- set allthemonths {January February March April May June July August September October November December}
+ 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"
+ # 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 $trimmed_month-1]
+ set trimmed_month [string trimleft $month 0]
+ set pretty_month [lindex $allthemonths $trimmed_month-1]
- set trimmed_day [string trimleft $day 0]
+ set trimmed_day [string trimleft $day 0]
- return "$pretty_month $trimmed_day, $year"
+ return "$pretty_month $trimmed_day, $year"
}
}
@@ -357,11 +363,11 @@
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] ne "" } {
+ if { [ns_set value $old_set_id $i] ne "" } {
- ns_set put $new_set_id [ns_set key $old_set_id $i] [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]
- }
+ }
}
@@ -389,11 +395,11 @@
db_0or1row $statement_name $sql_qry -bind $bind -column_set set_id
if { $set_id ne "" } {
-
- 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]]
- }
-
+
+ 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
}
@@ -404,18 +410,18 @@
ad_proc -deprecated util_PrettyBoolean {t_or_f { default "default" } } {
} {
if { $t_or_f == "t" || $t_or_f eq "T" } {
- return "Yes"
+ return "Yes"
} elseif { $t_or_f == "f" || $t_or_f eq "F" } {
- return "No"
+ return "No"
} else {
- # Note that we can't compare default to the empty string as in
- # many cases, we are going want the default to be the empty
- # string
- if { $default eq "default" } {
- return "Unknown (\"$t_or_f\")"
- } else {
- return $default
- }
+ # Note that we can't compare default to the empty string as in
+ # many cases, we are going want the default to be the empty
+ # string
+ if { $default eq "default" } {
+ return "Unknown (\"$t_or_f\")"
+ } else {
+ return $default
+ }
}
}
@@ -424,10 +430,10 @@
} {
Turns a 1 (or anything else that makes a Tcl IF happy) into Yes; anything else into No
} {
- if {$zero_or_one} {
- return "Yes"
+ if {$zero_or_one} {
+ return "Yes"
} else {
- return "No"
+ return "No"
}
}
@@ -453,7 +459,8 @@
@return integer
} {
- return [expr {int([random] * $range)}]
+ incr range
+ return [expr {int([random] * $range) % $range}]
}
ad_proc -public db_html_select_options {
@@ -473,25 +480,25 @@
set select_options ""
if { $bind ne "" } {
- set options [db_list $stmt_name $sql -bind $bind]
+ set options [db_list $stmt_name $sql -bind $bind]
} else {
- set options [db_list $stmt_name $sql]
+ set options [db_list $stmt_name $sql]
}
foreach option $options {
- if { $option eq $select_option } {
- append select_options "\n"
- } else {
- append select_options "\n"
- }
+ if { $option eq $select_option } {
+ append select_options "\n"
+ } else {
+ append select_options "\n"
+ }
}
return $select_options
}
ad_proc -public db_html_select_value_options {
{ -bind "" }
- { -select_option [list] }
+ { -select_option "" }
{ -value_index 0 }
{ -option_index 1 }
stmt_name
@@ -510,17 +517,17 @@
set select_options ""
if { $bind ne "" } {
- set options [db_list_of_lists $stmt_name $sql -bind $bind]
+ set options [db_list_of_lists $stmt_name $sql -bind $bind]
} else {
- set options [uplevel [list db_list_of_lists $stmt_name $sql]]
+ set options [uplevel [list db_list_of_lists $stmt_name $sql]]
}
foreach option $options {
- if { [lindex $option $value_index] in $select_option } {
- append select_options "\n"
- } else {
- append select_options "\n"
- }
+ if { [lindex $option $value_index] in $select_option } {
+ append select_options "\n"
+ } else {
+ append select_options "\n"
+ }
}
return $select_options
@@ -543,6 +550,7 @@
-entire_form:boolean
-no_empty:boolean
{-base}
+ -no_base_encode:boolean
{-anchor}
{-exclude {}}
{-override {}}
@@ -635,6 +643,9 @@
makes sure that the value isn't tampered with on the client side. The -sign
switch to export_vars, is a short-hand for specifying the :sign switch
on every variable.
+
+ For example, one can use now "user_id:sign(max_age=60)" in
+ export_vars to let the exported variable after 60 seconds.
@@ -662,7 +673,7 @@
the new value of column.
-
+
If the variable name contains a colon (:), that colon must be escaped with a backslash,
so for example "form:id" becomes "form\:id". Sorry.
@@ -678,25 +689,39 @@
@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.
+ 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.
+ 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.
+ @option no_base_encode Decides whether argument passed as base option will be
+ encoded by ad_urlencode_url proc
+
@author Lars Pind (lars@pinds.com)
@creation-date December 7, 2000
} {
if { $form_p && $url_p } {
- return -code error "You must select either form format or url format, not both."
+ return -code error "You must select either form format or url format, not both."
}
# default to URL format
if { !$form_p && !$url_p } {
- set url_p 1
+ set url_p 1
}
+ #
+ # TODO: At least the parsing of the options should be transformed
+ # to produce a single dict, containing the properties of all form
+ # vars (probably optionally) and specified arguments. The dict
+ # should be the straightforeward source for the genertion of the
+ # output set. One should be able to speed the code significantly
+ # up (at least for the standard cases).
+ #
+ # -Gustaf Neumann
+ #
+
# 'noprocessing_vars' is yet another container of variables,
# only this one doesn't have the values subst'ed
# and we don't try to find :multiple and :array flags in the namespec
@@ -733,10 +758,10 @@
array set exp_value [list]
foreach precedence_type { override exclude vars noprocessing_vars } {
- foreach var_spec [set $precedence_type] {
- if { [llength $var_spec] > 2 } {
- return -code error "A varspec must have either one or two elements."
- }
+ foreach var_spec [set $precedence_type] {
+ if { [llength $var_spec] > 2 } {
+ return -code error "A varspec must have either one or two elements."
+ }
if { $precedence_type ne "noprocessing_vars" } {
# Hide escaped colons for below split
@@ -754,34 +779,36 @@
set name_spec [list $name {}]
}
- # If we've already encountered this varname, ignore it
- if { ![info exists exp_precedence_type($name)] } {
+ # If we've already encountered this varname, ignore it
+ if { ![info exists exp_precedence_type($name)] } {
- set exp_precedence_type($name) $precedence_type
+ set exp_precedence_type($name) $precedence_type
- if { $precedence_type ne "exclude" } {
+ if { $precedence_type ne "exclude" } {
- set flags [split [lindex $name_spec 1] ","]
- foreach flag $flags {
- set exp_flag($name:$flag) 1
- }
-
- if { $sign_p } {
- set exp_flag($name:sign) 1
- }
-
- if { [llength $var_spec] > 1 } {
+ foreach flag [split [lindex $name_spec 1] ","] {
+ set exp_flag($name:$flag) 0
+ if {[regexp {^(\w+)[\(](.+)[\)]$} $flag . flag value]} {
+ set exp_flag($name:$flag) $value
+ }
+ }
+
+ if { $sign_p } {
+ set exp_flag($name:sign) 0
+ }
+
+ if { [llength $var_spec] > 1 } {
if { $precedence_type ne "noprocessing_vars" } {
set value [uplevel subst \{[lindex $var_spec 1]\}]
} else {
set value [lindex $var_spec 1]
}
set exp_value($name) $value
# If the value is specified explicitly, we include it even if the value is empty
- } else {
- upvar 1 $name upvar_variable
- if { [info exists upvar_variable] } {
- if { [array exists upvar_variable] } {
+ } else {
+ upvar 1 $name upvar_variable
+ if { [info exists upvar_variable] } {
+ if { [array exists upvar_variable] } {
if { $no_empty_p } {
# If the no_empty_p flag is set, remove empty string values first
set exp_value($name) [list]
@@ -794,11 +821,11 @@
# 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 {
- if { [info exists exp_flag($name:array)] } {
- return -code error "Variable \"$name\" is not an array"
- }
+ set exp_flag($name:array) 0
+ } else {
+ 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 {
@@ -818,12 +845,12 @@
}
}
}
- }
- }
- }
- }
- }
- }
+ }
+ }
+ }
+ }
+ }
+ }
}
#####
@@ -836,45 +863,46 @@
set export_set [ns_set create]
foreach name [array names exp_precedence_type] {
- if { $exp_precedence_type($name) ne "exclude" } {
- if { [info exists exp_value($name)] } {
- if { [info exists exp_flag($name:array)] } {
- if { [info exists exp_flag($name:multiple)] } {
- foreach { key value } $exp_value($name) {
- foreach item $value {
- ns_set put $export_set "${name}.${key}" $item
- }
- }
- } else {
- foreach { key value } $exp_value($name) {
- ns_set put $export_set "${name}.${key}" $value
- }
- }
- if { [info exists exp_flag($name:sign)] } {
+ if { $exp_precedence_type($name) ne "exclude" } {
+ if { [info exists exp_value($name)] } {
+ if { [info exists exp_flag($name:array)] } {
+ if { [info exists exp_flag($name:multiple)] } {
+ foreach { key value } $exp_value($name) {
+ foreach item $value {
+ ns_set put $export_set "${name}.${key}" $item
+ }
+ }
+ } else {
+ foreach { key value } $exp_value($name) {
+ ns_set put $export_set "${name}.${key}" $value
+ }
+ }
+ if { [info exists exp_flag($name:sign)] } {
# DRB: array get does not define the order in which elements are returned,
# meaning that arrays constructed in different ways can have different
# signatures unless we sort the returned list. I ran into this the
# very first time I tried to sign an array passed to a page that used
# ad_page_contract to verify the veracity of the parameter.
- ns_set put $export_set "$name:sig" [ad_sign [lsort $exp_value($name)]]
-
- }
- } else {
- if { [info exists exp_flag($name:multiple)] } {
- foreach item $exp_value($name) {
- ns_set put $export_set $name $item
- }
- } else {
- ns_set put $export_set $name "$exp_value($name)"
- }
- if { [info exists exp_flag($name:sign)] } {
- ns_set put $export_set "$name:sig" [ad_sign $exp_value($name)]
- }
- }
- }
- }
+ ns_set put $export_set "$name:sig" \
+ [export_vars_sign -params $exp_flag($name:sign) [lsort $exp_value($name)]]
+ }
+ } else {
+ if { [info exists exp_flag($name:multiple)] } {
+ foreach item $exp_value($name) {
+ ns_set put $export_set $name $item
+ }
+ } else {
+ ns_set put $export_set $name "$exp_value($name)"
+ }
+ if { [info exists exp_flag($name:sign)] } {
+ ns_set put $export_set "$name:sig" \
+ [export_vars_sign -params $exp_flag($name:sign) $exp_value($name)]
+ }
+ }
+ }
+ }
}
#####
@@ -887,46 +915,69 @@
set export_string {}
if { $url_p } {
- set export_list [list]
- for { set i 0 } { $i < $export_size } { incr i } {
- lappend export_list "[ad_urlencode_path [ns_set key $export_set $i]]=[ad_urlencode_query [ns_set value $export_set $i]]"
- }
- set export_string [join $export_list "&"]
+ set export_list [list]
+ for { set i 0 } { $i < $export_size } { incr i } {
+ lappend export_list [ad_urlencode_query [ns_set key $export_set $i]]=[ad_urlencode_query [ns_set value $export_set $i]]
+ }
+ set export_string [join $export_list "&"]
} else {
- for { set i 0 } { $i < $export_size } { incr i } {
- append export_string "
\n"
- }
+ for { set i 0 } { $i < $export_size } { incr i } {
+ append export_string [subst {
+ }]
+ }
}
if { $quotehtml_p } {
- set export_string [ad_quotehtml $export_string]
+ set export_string [ns_quotehtml $export_string]
}
# Prepend with the base URL
if { [info exists base] && $base ne "" } {
- if { $export_string ne "" } {
- if { [string first ? $base] > -1 } {
- # The base already has query vars
- set export_string "${base}&${export_string}"
- } else {
- # The base has no query vars
- set export_string "$base?$export_string"
- }
+ if { [string first ? $base] > -1 } {
+ # The base already has query vars; assume that the
+ # path up to this point is already correctly encoded.
+ set export_string $base[expr {$export_string ne "" ? "&$export_string" : ""}]
} else {
- set export_string $base
+ # The base has no query vars: encode url part if not
+ # explicitly said otherwise. Include also as exception
+ # trivial case of the base being the dummy url '#'.
+ if {!$no_base_encode_p && $base ne "#"} {
+ set base [ad_urlencode_url $base]
+ }
+ set export_string $base[expr {$export_string ne "" ? "?$export_string" : ""}]
}
}
-
+
# Append anchor
- if { ([info exists anchor] && $anchor ne "") } {
+ if { [info exists anchor] && $anchor ne "" } {
append export_string "\#$anchor"
}
return $export_string
}
+ad_proc -private export_vars_sign {
+ {-params ""}
+ value
+} {
+ Call ad_sign parameterized via max_age and secret specified in urlencoding
+} {
+ set max_age ""
+ set secret [ns_config "ns/server/[ns_info server]/acs" parametersecret ""]
+ foreach def [split $params &] {
+ lassign [split $def =] key val
+ switch $key {
+ max_age -
+ secret {set $key [ad_urldecode_query $val]}
+ }
+ }
+ return [ad_sign -max_age $max_age -secret $secret $value]
+}
+
ad_proc -deprecated ad_export_vars {
-form:boolean
{-exclude {}}
@@ -979,7 +1030,7 @@
A more involved example:
+ doc_body_append [export_vars -override { order_by $new_order_by } $my_vars]
@param form set this parameter if you want the variables exported as hidden form variables,
as opposed to URL variables, which is the default.
@@ -1006,76 +1057,76 @@
set override_p 0
foreach argument { include override } {
- foreach arg [set $argument] {
- if { [llength $arg] == 1 } {
- if { $override_p || $arg ni $exclude } {
- upvar $arg var
- if { [array exists var] } {
- # export the entire array
- foreach name [array names var] {
- if { $override_p || "${arg}($name)" ni $exclude } {
- set export($arg.$name) $var($name)
- }
- }
- } elseif { [info exists var] } {
- if { $override_p || $arg ni $exclude } {
- # if the var is part of an array, we'll translate the () into a dot.
- set left_paren [string first ( $arg]
- if { $left_paren == -1 } {
- set export($arg) $var
- } else {
- # convert the parenthesis into a dot before setting
- set export([string range $arg 0 $left_paren-1].[string range $arg $left_paren+1 end-1]) $var
- }
- }
- }
- }
- } elseif { [llength $arg] %2 == 0 } {
- foreach { name value } $arg {
- if { $override_p || $name ni $exclude } {
- set left_paren [string first ( $name]
- if { $left_paren == -1 } {
- set export($name) [lindex [uplevel list \[subst [list $value]\]] 0]
- } else {
- # convert the parenthesis into a dot before setting
- set export([string range $arg 0 $left_paren-1].[string range $arg $left_paren+1 end-1]) \
- [lindex [uplevel list \[subst [list $value]\]] 0]
- }
- }
- }
- } else {
- return -code error "All the exported values must have either one or an even number of elements"
- }
- }
- incr override_p
+ foreach arg [set $argument] {
+ if { [llength $arg] == 1 } {
+ if { $override_p || $arg ni $exclude } {
+ upvar $arg var
+ if { [array exists var] } {
+ # export the entire array
+ foreach name [array names var] {
+ if { $override_p || "${arg}($name)" ni $exclude } {
+ set export($arg.$name) $var($name)
+ }
+ }
+ } elseif { [info exists var] } {
+ if { $override_p || $arg ni $exclude } {
+ # if the var is part of an array, we'll translate the () into a dot.
+ set left_paren [string first "(" $arg]
+ if { $left_paren == -1 } {
+ set export($arg) $var
+ } else {
+ # convert the parenthesis into a dot before setting
+ set export([string range $arg 0 $left_paren-1].[string range $arg $left_paren+1 end-1]) $var
+ }
+ }
+ }
+ }
+ } elseif { [llength $arg] %2 == 0 } {
+ foreach { name value } $arg {
+ if { $override_p || $name ni $exclude } {
+ set left_paren [string first "(" $name]
+ if { $left_paren == -1 } {
+ set export($name) [lindex [uplevel list \[subst [list $value]\]] 0]
+ } else {
+ # convert the parenthesis into a dot before setting
+ set export([string range $arg 0 $left_paren-1].[string range $arg $left_paren+1 end-1]) \
+ [lindex [uplevel list \[subst [list $value]\]] 0]
+ }
+ }
+ }
+ } else {
+ return -code error "All the exported values must have either one or an even number of elements"
+ }
+ }
+ incr override_p
}
####################
#
# Translate this into the desired output form
#
####################
-
+
if { !$form_p } {
- set export_list [list]
- foreach varname [array names export] {
- lappend export_list "[ns_urlencode $varname]=[ns_urlencode $export($varname)]"
- }
- return [join $export_list &]
+ set export_list [list]
+ foreach varname [array names export] {
+ lappend export_list "[ns_urlencode $varname]=[ns_urlencode $export($varname)]"
+ }
+ return [join $export_list &]
} else {
- set export_list [list]
- foreach varname [array names export] {
- lappend export_list ""
- }
- return [join $export_list \n]
+ set export_list [list]
+ foreach varname [array names export] {
+ lappend export_list ""
+ }
+ return [join $export_list \n]
}
}
+
-
ad_proc -deprecated export_form_vars {
-sign:boolean
args
@@ -1086,7 +1137,7 @@
You can append :multiple to the name of a variable. In this case, the value will be treated as a list,
and each of the elements output separately.
- export_vars is now the prefered interface.
+ export_vars is now the preferred interface.
Example usage: [export_vars -form -sign {foo bar:multiple baz}]
@@ -1104,23 +1155,23 @@
} {
set hidden ""
foreach var_spec $args {
- lassign [split $var_spec ":"] var type
- upvar 1 $var value
- if { [info exists value] } {
- switch $type {
- multiple {
- foreach item $value {
- append hidden "\n"
- }
- }
- default {
- append hidden "\n"
- }
- }
- if { $sign_p } {
- append hidden "\n"
- }
- }
+ lassign [split $var_spec ":"] var type
+ upvar 1 $var value
+ if { [info exists value] } {
+ switch $type {
+ multiple {
+ foreach item $value {
+ append hidden "\n"
+ }
+ }
+ default {
+ append hidden "\n"
+ }
+ }
+ if { $sign_p } {
+ append hidden "\n"
+ }
+ }
}
return $hidden
}
@@ -1131,18 +1182,18 @@
generally not be used. It's much better to explicitly name
the variables you want to export.
- export_vars is now the prefered interface.
+ export_vars is now the preferred interface.
@see export_vars
} {
set hidden ""
set the_form [ns_getform]
if { $the_form ne "" } {
- for {set i 0} {$i<[ns_set size $the_form]} {incr i} {
- set varname [ns_set key $the_form $i]
- set varvalue [ns_set value $the_form $i]
- append hidden "\n"
- }
+ for {set i 0} {$i<[ns_set size $the_form]} {incr i} {
+ set varname [ns_set key $the_form $i]
+ set varvalue [ns_set value $the_form $i]
+ append hidden "\n"
+ }
}
return $hidden
}
@@ -1157,7 +1208,7 @@
format = url, a url parameter string will be returned. If format = form, a
block of hidden form fragments will be returned.
- export_vars is now the prefered interface.
+ export_vars is now the preferred interface.
@param format either url or form
@param exclusion_list list of fields to exclude
@@ -1167,7 +1218,7 @@
} {
if { $setid eq "" } {
- set setid [ns_getform]
+ set setid [ns_getform]
}
set return_list [list]
@@ -1179,7 +1230,7 @@
set value [ns_set value $setid $set_counter_i]
if {$name ni $exclusion_list && $name ne ""} {
if {$format eq "url"} {
- lappend return_list "[ad_urlencode_path $name]=[ad_urlencode_query $value]"
+ lappend return_list "[ad_urlencode_query $name]=[ad_urlencode_query $value]"
} else {
lappend return_list " name=\"[ns_quotehtml $name]\" value=\"[ns_quotehtml $value]\""
}
@@ -1198,7 +1249,7 @@
-sign:boolean
args
} {
- export_vars is now the prefered interface.
+ export_vars is now the preferred interface.
Returns a string of key=value pairs suitable for inclusion in a
URL; you can pass it any number of variables as arguments. If any are
@@ -1235,41 +1286,41 @@
} {
set params {}
foreach var_spec $args {
- if { [string first "=" $var_spec] != -1 } {
- # There shouldn't be more than one equal sign, since the value should already be url-encoded.
- lassign [split $var_spec "="] var value
- lappend params "$var=$value"
- if { $sign_p } {
- lappend params "[ns_urlencode [ns_urldecode $var]:sig]=[ns_urlencode [ad_sign [ns_urldecode $value]]]"
- }
- } else {
- lassign [split $var_spec ":"] var type
- upvar 1 $var upvar_value
- if { [info exists upvar_value] } {
- switch $type {
- multiple {
- foreach item $upvar_value {
- lappend params "[ns_urlencode $var]=[ns_urlencode $item]"
- }
- }
- default {
- lappend params "[ns_urlencode $var]=[ns_urlencode $upvar_value]"
- }
- }
- if { $sign_p } {
- lappend params "[ns_urlencode "$var:sig"]=[ns_urlencode [ad_sign $upvar_value]]"
- }
- }
- }
+ if { [string first "=" $var_spec] != -1 } {
+ # There shouldn't be more than one equal sign, since the value should already be url-encoded.
+ lassign [split $var_spec "="] var value
+ lappend params "$var=$value"
+ if { $sign_p } {
+ lappend params "[ns_urlencode [ns_urldecode $var]:sig]=[ns_urlencode [ad_sign [ns_urldecode $value]]]"
+ }
+ } else {
+ lassign [split $var_spec ":"] var type
+ upvar 1 $var upvar_value
+ if { [info exists upvar_value] } {
+ switch $type {
+ multiple {
+ foreach item $upvar_value {
+ lappend params "[ns_urlencode $var]=[ns_urlencode $item]"
+ }
+ }
+ default {
+ lappend params "[ns_urlencode $var]=[ns_urlencode $upvar_value]"
+ }
+ }
+ if { $sign_p } {
+ lappend params "[ns_urlencode "$var:sig"]=[ns_urlencode [ad_sign $upvar_value]]"
+ }
+ }
+ }
}
- return [join $params "&"]
+ return [join $params "&"]
}
ad_proc -public export_entire_form_as_url_vars {
{vars_to_passthrough ""}
} {
- export_vars is now the prefered interface.
+ export_vars is now the preferred interface.
Returns a URL parameter string of name-value pairs of all the form
parameters passed to this page. If vars_to_passthrough is given, it
@@ -1281,17 +1332,17 @@
set params [list]
set the_form [ns_getform]
if { $the_form ne "" } {
- for {set i 0} {$i<[ns_set size $the_form]} {incr i} {
- set varname [ns_set key $the_form $i]
- set varvalue [ns_set value $the_form $i]
- if {
- $vars_to_passthrough eq ""
- || ($varname in $vars_to_passthrough)
- } {
- lappend params "[ad_urlencode_path $varname]=[ad_urlencode_query $varvalue]"
- }
- }
- return [join $params "&"]
+ for {set i 0} {$i<[ns_set size $the_form]} {incr i} {
+ set varname [ns_set key $the_form $i]
+ set varvalue [ns_set value $the_form $i]
+ if {
+ $vars_to_passthrough eq ""
+ || ($varname in $vars_to_passthrough)
+ } {
+ lappend params "[ad_urlencode_query $varname]=[ad_urlencode_query $varvalue]"
+ }
+ }
+ return [join $params "&"]
}
}
@@ -1320,18 +1371,17 @@
execute the on_error block.
} {
upvar 1 $error_var $error_var
- global errorInfo errorCode
if { [catch { uplevel $body } $error_var] } {
set code [catch {uplevel $on_error} string]
# Return out of the caller appropriately.
if { $code == 1 } {
- return -code error -errorinfo $errorInfo -errorcode $errorCode $string
+ return -code error -errorinfo $::errorInfo -errorcode $::errorCode $string
} elseif { $code == 2 } {
return -code return $string
} elseif { $code == 3 } {
return -code break
- } elseif { $code == 4 } {
- return -code continue
+ } elseif { $code == 4 } {
+ return -code continue
} elseif { $code > 4 } {
return -code $code $string
}
@@ -1348,12 +1398,12 @@
e.g. -1465.98 => -1,465.98
} {
while { 1 } {
- # Regular Expression taken from Mastering Regular Expressions (Jeff Friedl)
- # matches optional leading negative sign plus any
- # other 3 digits, starting from end
- if { ![regsub -- {^(-?[0-9]+)([0-9][0-9][0-9])} $num {\1,\2} num] } {
- break
- }
+ # Regular Expression taken from Mastering Regular Expressions (Jeff Friedl)
+ # matches optional leading negative sign plus any
+ # other 3 digits, starting from end
+ if { ![regsub -- {^(-?[0-9]+)([0-9][0-9][0-9])} $num {\1,\2} num] } {
+ break
+ }
}
return $num
}
@@ -1363,11 +1413,11 @@
} {
set sublist_index 0
foreach sublist $list_of_lists {
- set comparison_element [lindex $sublist $sublist_element_pos]
- if { $query_string eq $comparison_element } {
- return $sublist_index
- }
- incr sublist_index
+ set comparison_element [lindex $sublist $sublist_element_pos]
+ if { $query_string eq $comparison_element } {
+ return $sublist_index
+ }
+ incr sublist_index
}
# didn't find it
return -1
@@ -1383,9 +1433,9 @@
set tentative_path [info script]
regsub -all {/\./} $tentative_path {/} scrubbed_path
if { $extra_message eq "" } {
- set message "Done... $scrubbed_path"
+ set message "Done... $scrubbed_path"
} else {
- set message "Done... $scrubbed_path; $extra_message"
+ set message "Done... $scrubbed_path; $extra_message"
}
ns_log Notice $message
}
@@ -1425,89 +1475,89 @@
}
ad_proc -deprecated -private set_encoding {
- {-text_translation {auto binary}}
- content_type
- channel
+ {-text_translation {auto binary}}
+ content_type
+ channel
} {
-
The ad_http* and util_http* machineries depend on the
- AOLserver/NaviServer socket I/O layer provided by [ns_sockopen].
- This proc allows you to request Tcl encoding filtering for
- ns_sockopen channels (i.e., the read and write channels return by
- [ns_sockopen]), to be applied right before performing socket I/O
- operations (i.e., reads).
+
The ad_http* and util_http* machineries depend on the
+ AOLserver/NaviServer socket I/O layer provided by [ns_sockopen].
+ This proc allows you to request Tcl encoding filtering for
+ ns_sockopen channels (i.e., the read and write channels return by
+ [ns_sockopen]), to be applied right before performing socket I/O
+ operations (i.e., reads).
-
The major task is to resolve the corresponding Tcl encoding
- (e.g.: ascii) for a given IANA/MIME charset name (or alias; e.g.:
- US-ASCII); the main resolution scheme is implemented by
- [ns_encodingfortype] which is available bother under AOLserver and
- NaviServer (see tcl/charsets.tcl). The mappings between Tcl encoding
- names (as shown by [encoding names]) and IANA/MIME charset names
- (i.e., names and aliases in the sense of IANA's
- charater sets registry) is provided by:
-
-
-
A static, built-in correspondence map: see nsd/encoding.c
-
An extensible correspondence map (i.e., the ns/charsets
- section in config.tcl).
-
+
The major task is to resolve the corresponding Tcl encoding
+ (e.g.: ascii) for a given IANA/MIME charset name (or alias; e.g.:
+ US-ASCII); the main resolution scheme is implemented by
+ [ns_encodingfortype] which is available bother under AOLserver and
+ NaviServer (see tcl/charsets.tcl). The mappings between Tcl encoding
+ names (as shown by [encoding names]) and IANA/MIME charset names
+ (i.e., names and aliases in the sense of IANA's
+ charater sets registry) is provided by:
-
[ns_encodingfortype] introduces several levels of precedence
- when resolving the actual IANA/MIME charset and the corresponding
- Tcl encoding to use:
-
-
-
The "content_type" string contains a charset specification,
- e.g.: "text/xml; charset=UTF-8". This spec fragment takes the
- highest precedence.
-
-
The "content_type" string points to a "text/*" media subtype,
- but does not specify a charset (e.g., "text/xml"). In this case, the
- charset defined by ns/parameters/OutputCharset (see config.tcl)
- applies. If this parameter is missing, the default is
- "iso-8859-1" (see tcl/charsets.tcl; this follows from RFC 2616 (HTTP 1.1);
- Section 3.7.1).
+
+
A static, built-in correspondence map: see nsd/encoding.c
+
An extensible correspondence map (i.e., the ns/charsets
+ section in config.tcl).
+
-
If neither case 1 or case 2 become effective, the encoding is
- resolved to "binary".
-
-
If [ns_encodingfortype] fails to resolve any Tcl encoding name
- (i.e., returns an empty string), the general fallback is "iso8859-1"
- for text/* media subtypes and "binary" for any other. This is the
- case in two situations:
-
-
-
Invalid IANA/MIME charsets: The name in the "charset" parameter
- of the content type spec is not a valid name or alias in IANA's
- charater sets registry (a special variant would be an empty
- charset value, e.g. "text/plain; charset=")
-
-
Unknown IANA/MIME charsets: The name in the "charset" parameter
- of the content type spec does not match any known (= registered)
- IANA/MIME charset in the MIME/Tcl mappings.
-
-
-
-
+
[ns_encodingfortype] introduces several levels of precedence
+ when resolving the actual IANA/MIME charset and the corresponding
+ Tcl encoding to use:
+
+
+
The "content_type" string contains a charset specification,
+ e.g.: "text/xml; charset=UTF-8". This spec fragment takes the
+ highest precedence.
+
+
The "content_type" string points to a "text/*" media subtype,
+ but does not specify a charset (e.g., "text/xml"). In this case, the
+ charset defined by ns/parameters/OutputCharset (see config.tcl)
+ applies. If this parameter is missing, the default is
+ "iso-8859-1" (see tcl/charsets.tcl; this follows from RFC 2616 (HTTP 1.1);
+ Section 3.7.1).
+
+
If neither case 1 or case 2 become effective, the encoding is
+ resolved to "binary".
+
+
If [ns_encodingfortype] fails to resolve any Tcl encoding name
+ (i.e., returns an empty string), the general fallback is "iso8859-1"
+ for text/* media subtypes and "binary" for any other. This is the
+ case in two situations:
+
+
+
Invalid IANA/MIME charsets: The name in the "charset" parameter
+ of the content type spec is not a valid name or alias in IANA's
+ charater sets registry (a special variant would be an empty
+ charset value, e.g. "text/plain; charset=")
+
+
Unknown IANA/MIME charsets: The name in the "charset" parameter
+ of the content type spec does not match any known (= registered)
+ IANA/MIME charset in the MIME/Tcl mappings.
+
+ @author stefan.sobernig@wu.ac.at
} {
- set trl [expr {[string match "text/*" $content_type] ? $text_translation : "binary"}]
- set enc [ns_encodingfortype $content_type]
- if {$enc eq ""} {
- set enc [expr {[string match "text/*" $content_type] ? "iso8859-1" : "binary"}]
- ns_log debug "--- Resolving a Tcl encoding for the CONTENT-TYPE '$content_type' failed; falling back to '$enc'."
- }
- fconfigure $channel -translation $trl -encoding $enc
+ set trl [expr {[string match "text/*" $content_type] ? $text_translation : "binary"}]
+ set enc [ns_encodingfortype $content_type]
+ if {$enc eq ""} {
+ set enc [expr {[string match "text/*" $content_type] ? "iso8859-1" : "binary"}]
+ ns_log debug "--- Resolving a Tcl encoding for the CONTENT-TYPE '$content_type' failed; falling back to '$enc'."
+ }
+ fconfigure $channel -translation $trl -encoding $enc
}
# some procs to make it easier to deal with CSV files (reading and writing)
@@ -1532,13 +1582,13 @@
@see ad_page_contract
} {
if { ![regexp {^[0-9]+$} $string] } {
- error "$field_name is not an integer"
+ error "$field_name is not an integer"
}
# trim leading zeros, so as not to confuse Tcl
set string [string trimleft $string "0"]
if { $string eq "" } {
- # but not all of the zeros
- return "0"
+ # but not all of the zeros
+ return "0"
}
return $string
}
@@ -1552,26 +1602,26 @@
} {
if { $country_code eq "" || [string toupper $country_code] eq "US" } {
- if { [regexp {^[0-9][0-9][0-9][0-9][0-9](-[0-9][0-9][0-9][0-9])?$} $zip_string] } {
- set zip_5 [string range $zip_string 0 4]
- if {
- ![db_0or1row zip_code_exists {
- select 1
- from dual
- where exists (select 1
- from zip_codes
- where zip_code like :zip_5)
- }]
- } {
- error "The entry for $field_name, \"$zip_string\" is not a recognized zip code"
- }
- } else {
- error "The entry for $field_name, \"$zip_string\" does not look like a zip code"
- }
+ if { [regexp {^[0-9][0-9][0-9][0-9][0-9](-[0-9][0-9][0-9][0-9])?$} $zip_string] } {
+ set zip_5 [string range $zip_string 0 4]
+ if {
+ ![db_0or1row zip_code_exists {
+ select 1
+ from dual
+ where exists (select 1
+ from zip_codes
+ where zip_code like :zip_5)
+ }]
+ } {
+ error "The entry for $field_name, \"$zip_string\" is not a recognized zip code"
+ }
+ } else {
+ error "The entry for $field_name, \"$zip_string\" does not look like a zip code"
+ }
} else {
- if { $zip_string ne "" } {
- error "Zip code is not needed outside the US"
- }
+ if { $zip_string ne "" } {
+ error "Zip code is not needed outside the US"
+ }
}
return $zip_string
}
@@ -1591,15 +1641,15 @@
# check that either all elements are blank
# date value is formated correctly for ns_dbformvalue
if { "$day$month$year" eq "" } {
- if { $allow_null == 0 } {
- error "$field_name must be supplied"
- } else {
- return ""
- }
+ if { $allow_null == 0 } {
+ error "$field_name must be supplied"
+ } else {
+ return ""
+ }
} elseif { $year ne "" && [string length $year] != 4 } {
- error "The year must contain 4 digits."
+ error "The year must contain 4 digits."
} elseif { [catch { ns_dbformvalue $form $column date date } errmsg ] } {
- error "The entry for $field_name had a problem: $errmsg."
+ error "The entry for $field_name had a problem: $errmsg."
}
return $date
@@ -1619,42 +1669,44 @@
set set_headers_i 0
set set_headers_limit [ns_set size [ad_conn outputheaders]]
while {$set_headers_i < $set_headers_limit} {
- append headers_so_far "[ns_set key [ad_conn outputheaders] $set_headers_i]: [ns_set value [ad_conn outputheaders] $set_headers_i]\r\n"
- incr set_headers_i
+ append headers_so_far "[ns_set key [ad_conn outputheaders] $set_headers_i]: [ns_set value [ad_conn outputheaders] $set_headers_i]\r\n"
+ incr set_headers_i
}
append entire_string_to_write $headers_so_far "\r\n" $first_part_of_page
ns_write $entire_string_to_write
}
ad_proc -private ReturnHeaders {
{content_type text/html}
+ {content_length ""}
} {
- We use this when we want to send out just the headers
- and then do incremental writes with ns_write. This way the user
- doesn't have to wait for streamed output (useful when doing
- bulk uploads, installs, etc.).
+ We use this when we want to send out just the headers
+ and then do incremental writes with ns_write. This way the user
+ doesn't have to wait for streamed output (useful when doing
+ bulk uploads, installs, etc.).
- It returns status 200 and all headers including
- any added to outputheaders.
+ It returns status 200 and all headers including
+ any added to outputheaders.
} {
+ set text_p [string match "text/*" $content_type]
+ if {$text_p && ![string match "*charset=*" $content_type]} {
+ append content_type "; charset=[ns_config ns/parameters OutputCharset iso-8859-1]"
+ }
- if {[string match "text/*" $content_type] && ![string match "*charset=*" $content_type]} {
- append content_type "; charset=[ns_config ns/parameters OutputCharset iso-8859-1]"
- }
-
- if {[ns_info name] eq "NaviServer"} {
- ns_headers 200 $content_type
- } else {
- set all_the_headers "HTTP/1.0 200 OK
+ if {[ns_info name] eq "NaviServer"} {
+ set binary [expr {$text_p ? "" : "-binary"}]
+ ns_headers {*}$binary 200 $content_type {*}$content_length
+ } else {
+ set all_the_headers "HTTP/1.0 200 OK
MIME-Version: 1.0
Content-Type: $content_type\r\n"
- util_WriteWithExtraOutputHeaders $all_the_headers
- if {[string match "text/*" $content_type]} {
- ns_startcontent -type $content_type
- } else {
- ns_startcontent
- }
- }
+ util_WriteWithExtraOutputHeaders $all_the_headers
+ if {[string match "text/*" $content_type]} {
+ ns_startcontent -type $content_type
+ } else {
+ ns_startcontent
+ }
+ }
}
ad_proc -public ad_return_top_of_page {
@@ -1666,7 +1718,7 @@
} {
ReturnHeaders $content_type
if { $first_part_of_page ne "" } {
- ns_write $first_part_of_page
+ ns_write $first_part_of_page
}
}
@@ -1683,24 +1735,13 @@
that may be used to execute unsafe code.
} {
foreach arg $args {
- if { [string match {*[\[;]*} $arg] } {
- return -code error "Unsafe argument to safe_eval: $arg"
- }
+ if { [string match {*[\[;]*} $arg] } {
+ return -code error "Unsafe argument to safe_eval: $arg"
+ }
}
return [ad_apply uplevel $args]
}
-ad_proc -public -deprecated lmap {list proc_name} {
- Applies proc_name to each item of the list, appending the result of
- each call to a new list that is the return value.
-} {
- set lmap [list]
- foreach item $list {
- lappend lmap [safe_eval $proc_name $item]
- }
- return $lmap
-}
-
ad_proc -public ad_decode { args } {
this procedure is analogus to sql decode procedure. first parameter is
the value we want to decode. this parameter is followed by a list of
@@ -1715,24 +1756,24 @@
set counter 1
while { $counter < $num_args - 2 } {
- lappend from_list [lindex $args $counter]
- incr counter
- lappend to_list [lindex $args $counter]
- incr counter
+ lappend from_list [lindex $args $counter]
+ incr counter
+ lappend to_list [lindex $args $counter]
+ incr counter
}
set default_value [lindex $args $counter]
if { $counter < 2 } {
- return $default_value
+ return $default_value
}
set index [lsearch -exact $from_list $input_value]
if { $index < 0 } {
- return $default_value
+ return $default_value
} else {
- return [lindex $to_list $index]
+ return [lindex $to_list $index]
}
}
@@ -1746,357 +1787,408 @@
}
if {[ns_info name] eq "NaviServer"} {
+ #
+ # NaviServer
+ #
+ ad_proc -public ad_urlencode_folder_path {path} {
+ Perform an urlencode operation on the segments of the provided
+ folder (for a full folder path rather than path segments as in
+ ad_urlencode_path).
+ @see ad_urlencode_path
+ } {
+ return [ns_urlencode -part path -- {*}[split $path /]]
+ }
+
ad_proc -public ad_urlencode_path { string } {
- encode provided string with url-encoding for paths (instead of queries) as defined in RFC 3986
+ Encode provided string with url-encoding for paths segments
+ (instead of query segments) as defined in RFC 3986
} {
- return [ns_urlencode -part path -- $string]
+ return [ns_urlencode -part path -- $string]
}
ad_proc -public ad_urldecode_path { string } {
- decode provided string with url-encoding for paths (instead of queries) as defined in RFC 3986
+ Decode provided string with url-encoding for paths segments
+ (instead of query segments) as defined in RFC 3986
} {
- return [ns_urldecode -part path -- $string]
+ return [ns_urldecode -part path -- $string]
}
ad_proc -public ad_urlencode_query { string } {
- encode provided string with url-encoding for query (instead of paths) as defined in RFC 3986
+ Encode provided string with url-encoding for query segments
+ (instead of paths) as defined in RFC 3986
} {
- return [ns_urlencode -part query -- $string]
+ return [ns_urlencode -part query -- $string]
}
ad_proc -public ad_urldecode_query { string } {
- decode provided string with url-encoding for query (instead of paths) as defined in RFC 3986
+ Decode provided string with url-encoding for query segments
+ (instead of path segments) as defined in RFC 3986
} {
- return [ns_urldecode -part query -- $string]
+ return [ns_urldecode -part query -- $string]
}
} else {
+ #
+ # AOLserver
+ #
+
+ ad_proc -public ad_urlencode_folder_path {path} {
+ Perform an urlencode operation on the segments of the provided
+ folder (for a full folder path rather than path segments as in
+ ad_urlencode_path).
+ @see ad_urlencode_path
+ } {
+ set segments {}
+ foreach segment [split $path /] {
+ lappend segments [ns_urlencode $segment]
+ }
+ return [join $segments /]
+ }
+
ad_proc -public ad_urlencode_path { string } {
- encode provided string with url-encodingfor paths;
- same as ad_urlencode, since aolserver does not support this difference
+ Encode provided string with url-encoding for path segments;
+ same as ad_urlencode, since AOLserver does not support this difference
} {
- return [ad_urlencode $string]
+ return [ad_urlencode $string]
}
ad_proc -public ad_urldecode_path { string } {
- decode provided string with url-encoding for paths;
- same as ns_urldecode, since aolserver does not support this difference
+ Decode provided string with url-encoding for path segments;
+ same as ns_urldecode, since AOLserver does not support this difference
} {
- return [ns_urldecode $string]
+ return [ns_urldecode $string]
}
ad_proc -public ad_urlencode_query { string } {
- encode provided string with url-encodingfor paths;
- same as ad_urlencode, since aolserver does not support this difference
+ Encode provided string with url-encodingfor path segments;
+ same as ad_urlencode, since AOLserver does not support this difference
} {
- return [ad_urlencode $string]
+ return [ad_urlencode $string]
}
ad_proc -public ad_urldecode_query { string } {
- decode provided string with url-encoding for paths;
- same as ns_urldecode, since aolserver does not support this difference
+ Decode provided string with url-encoding for path segments;
+ same as ns_urldecode, since AOLserver does not support this difference
} {
- return [ns_urldecode $string]
+ return [ns_urldecode $string]
}
}
+ad_proc -public ad_urlencode_url {url} {
+ Perform an urlencode operation on a potentially full url
+ (containing a location, but without query part).
+ @see ad_urlencode_folder_path
+} {
+ if {[util_complete_url_p $url]} {
+ set components [ns_parseurl $url]
+ set result [util::join_location \
+ -proto [dict get $components proto] \
+ -hostname [dict get $components host] \
+ -port [expr {[dict exists $components port] ? [dict get $components port] : ""}] \
+ ]
+ set fullpath [dict get $components path]/[dict get $components tail]
+ append result / [ad_urlencode_folder_path $fullpath]
+ } else {
+ set result [ad_urlencode_folder_path $url]
+ }
+ return $result
+}
-
if {[ns_info name] eq "NaviServer"} {
#
# Use NaviServer primitives
#
ad_proc -public ad_unset_cookie {
- {-secure f}
- {-domain ""}
- {-path "/"}
- name
+ {-secure f}
+ {-domain ""}
+ {-path "/"}
+ name
} {
- Un-sets a cookie.
-
- @see ad_get_cookie
- @see ad_set_cookie
+ Un-sets a cookie.
+
+ @see ad_get_cookie
+ @see ad_set_cookie
} {
- ns_deletecookie -domain $domain -path $path -replace t -secure $secure -- $name
+ ns_deletecookie -domain $domain -path $path -replace t -secure $secure -- $name
}
#
# Get Cookie
#
ad_proc -public ad_get_cookie {
- { -include_set_cookies t }
- name
- { default "" }
+ { -include_set_cookies t }
+ name
+ { default "" }
} {
- Returns the value of a cookie, or $default if none exists.
+ Returns the value of a cookie, or $default if none exists.
- @see ad_set_cookie
- @see ad_unset_cookie
+ @see ad_set_cookie
+ @see ad_unset_cookie
} {
- ns_getcookie -include_set_cookies $include_set_cookies -- $name $default
+ ns_getcookie -include_set_cookies $include_set_cookies -- $name $default
}
#
# Set Cookie
#
ad_proc -public ad_set_cookie {
- {-replace f}
- {-secure f}
- {-expire f}
- {-max_age ""}
- {-domain ""}
- {-path "/"}
- {-discard f}
- {-scriptable t}
- name
- {value ""}
+ {-replace f}
+ {-secure f}
+ {-expire f}
+ {-max_age ""}
+ {-domain ""}
+ {-path "/"}
+ {-discard f}
+ {-scriptable t}
+ name
+ {value ""}
} {
- Sets a cookie. Cookies are name/value pairs stored in a client's
- browser and are typically sent back to the server of origin with
- each request.
+ Sets a cookie. Cookies are name/value pairs stored in a client's
+ browser and are typically sent back to the server of origin with
+ each request.
- @param max_age specifies the maximum age of the cookies in
- seconds (consistent with RFC 2109). max_age "inf" specifies cookies
- that never expire. The default behavior is to issue session
- cookies.
-
- @param expire specifies whether we should expire (clear) the cookie.
- Setting Max-Age to zero ought to do this, but it doesn't in some browsers
- (tested on IE 6).
+ @param max_age specifies the maximum age of the cookies in
+ seconds (consistent with RFC 2109). max_age "inf" specifies cookies
+ that never expire. The default behavior is to issue session
+ cookies.
+
+ @param expire specifies whether we should expire (clear) the cookie.
+ Setting Max-Age to zero ought to do this, but it doesn't in some browsers
+ (tested on IE 6).
- @param path specifies a subset of URLs to which this cookie
- applies. It must be a prefix of the URL being accessed.
+ @param path specifies a subset of URLs to which this cookie
+ applies. It must be a prefix of the URL being accessed.
- @param domain specifies the domain(s) to which this cookie
- applies. See RFC2109 for the semantics of this cookie attribute.
+ @param domain specifies the domain(s) to which this cookie
+ applies. See RFC2109 for the semantics of this cookie attribute.
- @param secure specifies to the user agent that the cookie should
- only be transmitted back to the server of secure transport.
-
- @param replace forces the current output headers to be checked for
- the same cookie. If the same cookie is set for a second time
- without the replace option being specified, the client will
- receive both copies of the cookie.
+ @param secure specifies to the user agent that the cookie should
+ only be transmitted back to the server of secure transport.
+
+ @param replace forces the current output headers to be checked for
+ the same cookie. If the same cookie is set for a second time
+ without the replace option being specified, the client will
+ receive both copies of the cookie.
- @param discard instructs the user agent to discard the
- cookie when when the user agent terminates.
+ @param discard instructs the user agent to discard the
+ cookie when when the user agent terminates.
- @param scriptable If the scriptable option is false or not
- given the cookie is unavailable to javascript on the
- client. This can prevent cross site scripting attacks (XSS) on
- clients which support the HttpOnly option. Set -scriptable to
- true if you need to access the cookie via javascript. For
- compatibility reasons with earlier versions, OpenACS 5.8 has
- the default set to "true". OpenACS 5.9 will have the flag per
- default set to "false".
+ @param scriptable If the scriptable option is false or not
+ given the cookie is unavailable to javascript on the
+ client. This can prevent cross site scripting attacks (XSS) on
+ clients which support the HttpOnly option. Set -scriptable to
+ true if you need to access the cookie via javascript. For
+ compatibility reasons with earlier versions, OpenACS 5.8 has
+ the default set to "true". OpenACS 5.9 will have the flag per
+ default set to "false".
- @param value is autmatically URL encoded.
+ @param value is autmatically URL encoded.
- @see ad_get_cookie
- @see ad_unset_cookie
+ @see ad_get_cookie
+ @see ad_unset_cookie
} {
- if { $expire == "f"} {
- set expire -1
- } elseif {$max_age ne ""} {
- if {$max_age eq "inf"} {
- set expire -1
- } else {
- set expire [expr {[ns_time] + $max_age}]
- }
- }
+ if { $expire == "f"} {
+ set expire -1
+ } elseif {$max_age ne ""} {
+ if {$max_age eq "inf"} {
+ set expire -1
+ } else {
+ set expire [expr {[ns_time] + $max_age}]
+ }
+ }
- ns_setcookie -discard $discard -domain $domain -expires $expire -path $path \
- -replace $replace -scriptable $scriptable -secure $secure -- \
- $name $value
+ ns_setcookie -discard $discard -domain $domain -expires $expire -path $path \
+ -replace $replace -scriptable $scriptable -secure $secure -- \
+ $name $value
}
} else {
#
# Use plain AOLserver
#
-
+
#
# Unset Cookie
#
ad_proc -public ad_unset_cookie {
- {-secure f}
- {-domain ""}
- {-path "/"}
- name
+ {-secure f}
+ {-domain ""}
+ {-path "/"}
+ name
} {
- Un-sets a cookie.
-
- @see ad_get_cookie
- @see ad_set_cookie
+ Un-sets a cookie.
+
+ @see ad_get_cookie
+ @see ad_set_cookie
} {
- ad_set_cookie -replace t -expire t -max_age 0 \
- -secure $secure -domain $domain -path $path \
- $name ""
+ ad_set_cookie -replace t -expire t -max_age 0 \
+ -secure $secure -domain $domain -path $path \
+ $name ""
}
#
# Get Cookie
#
ad_proc -public ad_get_cookie {
- { -include_set_cookies t }
- name
- { default "" }
+ { -include_set_cookies t }
+ name
+ { default "" }
} {
- Returns the value of a cookie, or $default if none exists.
+ Returns the value of a cookie, or $default if none exists.
- @see ad_set_cookie
- @see ad_unset_cookie
+ @see ad_set_cookie
+ @see ad_unset_cookie
} {
- if { $include_set_cookies == "t" } {
- set headers [ns_conn outputheaders]
- set nr_headers [ns_set size $headers]
- for { set i 0 } { $i < $nr_headers } { incr i } {
- if { [string tolower [ns_set key $headers $i]] eq "set-cookie"
- && [regexp "^$name=(\[^;\]*)" [ns_set value $headers $i] match value]
- } {
- return $value
- }
- }
- }
+ if { $include_set_cookies == "t" } {
+ set headers [ns_conn outputheaders]
+ set nr_headers [ns_set size $headers]
+ for { set i 0 } { $i < $nr_headers } { incr i } {
+ if { [string tolower [ns_set key $headers $i]] eq "set-cookie"
+ && [regexp "^$name=(\[^;\]*)" [ns_set value $headers $i] match value]
+ } {
+ return [ns_urldecode $value]
+ }
+ }
+ }
- set headers [ns_conn headers]
- set cookie [ns_set iget $headers Cookie]
+ set headers [ns_conn headers]
+ set cookie [ns_set iget $headers Cookie]
- if { [regexp " $name=(\[^;\]*)" " $cookie" match value] } {
+ if { [regexp " $name=(\[^;\]*)" " $cookie" match value] } {
- # If the cookie was set to a blank value we actually stored two quotes. We need
- # to undo the kludge on the way out.
+ # If the cookie was set to a blank value we actually stored two quotes. We need
+ # to undo the kludge on the way out.
- if { $value eq "\"\"" } {
- set value ""
- }
- return $value
- }
+ if { $value eq "\"\"" } {
+ set value ""
+ }
+ return [ns_urldecode $value]
+ }
- return $default
+ return $default
}
#
# Set Cookie
#
ad_proc -public ad_set_cookie {
- {-replace f}
- {-secure f}
- {-expire f}
- {-max_age ""}
- {-domain ""}
- {-path "/"}
- {-discard f}
- {-scriptable t}
- name
- {value ""}
+ {-replace f}
+ {-secure f}
+ {-expire f}
+ {-max_age ""}
+ {-domain ""}
+ {-path "/"}
+ {-discard f}
+ {-scriptable t}
+ name
+ {value ""}
} {
- Sets a cookie. Cookies are name/value pairs stored in a client's
- browser and are typically sent back to the server of origin with
- each request.
+ Sets a cookie. Cookies are name/value pairs stored in a client's
+ browser and are typically sent back to the server of origin with
+ each request.
- @param max_age specifies the maximum age of the cookies in
- seconds (consistent with RFC 2109). max_age "inf" specifies cookies
- that never expire. The default behavior is to issue session
- cookies.
-
- @param expire specifies whether we should expire (clear) the cookie.
- Setting Max-Age to zero ought to do this, but it doesn't in some browsers
- (tested on IE 6).
+ @param max_age specifies the maximum age of the cookies in
+ seconds (consistent with RFC 2109). max_age "inf" specifies cookies
+ that never expire. The default behavior is to issue session
+ cookies.
+
+ @param expire specifies whether we should expire (clear) the cookie.
+ Setting Max-Age to zero ought to do this, but it doesn't in some browsers
+ (tested on IE 6).
- @param path specifies a subset of URLs to which this cookie
- applies. It must be a prefix of the URL being accessed.
+ @param path specifies a subset of URLs to which this cookie
+ applies. It must be a prefix of the URL being accessed.
- @param domain specifies the domain(s) to which this cookie
- applies. See RFC2109 for the semantics of this cookie attribute.
+ @param domain specifies the domain(s) to which this cookie
+ applies. See RFC2109 for the semantics of this cookie attribute.
- @param secure specifies to the user agent that the cookie should
- only be transmitted back to the server of secure transport.
-
- @param replace forces the current output headers to be checked for
- the same cookie. If the same cookie is set for a second time
- without the replace option being specified, the client will
- receive both copies of the cookie.
+ @param secure specifies to the user agent that the cookie should
+ only be transmitted back to the server of secure transport.
+
+ @param replace forces the current output headers to be checked for
+ the same cookie. If the same cookie is set for a second time
+ without the replace option being specified, the client will
+ receive both copies of the cookie.
- @param discard instructs the user agent to discard the
- cookie when when the user agent terminates.
+ @param discard instructs the user agent to discard the
+ cookie when when the user agent terminates.
- @param scriptable If the scriptable option is false or not
- given the cookie is unavailable to javascript on the
- client. This can prevent cross site scripting attacks (XSS) on
- clients which support the HttpOnly option. Set -scriptable to
- true if you need to access the cookie via javascript. For
- compatibility reasons with earlier versions, OpenACS 5.8 has
- the default set to "true". OpenACS 5.9 will have the flag per
- default set to "false".
+ @param scriptable If the scriptable option is false or not
+ given the cookie is unavailable to javascript on the
+ client. This can prevent cross site scripting attacks (XSS) on
+ clients which support the HttpOnly option. Set -scriptable to
+ true if you need to access the cookie via javascript. For
+ compatibility reasons with earlier versions, OpenACS 5.8 has
+ the default set to "true". OpenACS 5.9 will have the flag per
+ default set to "false".
- @param value is autmatically URL encoded.
+ @param value is autmatically URL encoded.
- @see ad_get_cookie
- @see ad_unset_cookie
+ @see ad_get_cookie
+ @see ad_unset_cookie
} {
- set headers [ad_conn outputheaders]
- if { $replace } {
- # Try to find an already-set cookie named $name.
- for { set i 0 } { $i < [ns_set size $headers] } { incr i } {
- if { [string tolower [ns_set key $headers $i]] eq "set-cookie"
- && [string match "$name=*" [ns_set value $headers $i]]
- } {
- ns_set delete $headers $i
- }
- }
- }
+ set headers [ad_conn outputheaders]
+ if { $replace } {
+ # Try to find an already-set cookie named $name.
+ for { set i 0 } { $i < [ns_set size $headers] } { incr i } {
+ if { [string tolower [ns_set key $headers $i]] eq "set-cookie"
+ && [string match "$name=*" [ns_set value $headers $i]]
+ } {
+ ns_set delete $headers $i
+ }
+ }
+ }
- # need to set some value, so we put "" as the cookie value
- if { $value eq "" } {
- set cookie "$name=\"\""
- } else {
- set cookie "$name=$value"
- }
+ # need to set some value, so we put "" as the cookie value
+ if { $value eq "" } {
+ set cookie "$name=\"\""
+ } else {
+ set cookie "$name=[ns_urlencode $value]"
+ }
- if { $path ne "" } {
- append cookie "; Path=$path"
- }
+ if { $path ne "" } {
+ append cookie "; Path=$path"
+ }
- if { $discard != "f" } {
- append cookie "; Discard"
- } elseif { $max_age eq "inf" } {
- if { $expire == "f"} {
- #
- # netscape seemed unhappy with huge max-age, so we use
- # expires which seems to work on both netscape and IE
- #
- append cookie "; Expires=Mon, 01-Jan-2035 01:00:00 GMT"
- }
- } elseif { $max_age ne "" } {
- #
- # We know $max_age is also not "inf"
- #
- append cookie "; Max-Age=$max_age"
- if {$expire == "f"} {
- # Reinforce Max-Age via "Expires", unless user required
- # immediate expiration
- set expire_time [util::cookietime [expr {[ns_time] + $max_age}]]
- append cookie "; Expires=$expire_time"
- }
- }
+ if { $discard != "f" } {
+ append cookie "; Discard"
+ } elseif { $max_age eq "inf" } {
+ if { $expire == "f"} {
+ #
+ # netscape seemed unhappy with huge max-age, so we use
+ # expires which seems to work on both netscape and IE
+ #
+ append cookie "; Expires=Mon, 01-Jan-2035 01:00:00 GMT"
+ }
+ } elseif { $max_age ne "" } {
+ #
+ # We know $max_age is also not "inf"
+ #
+ append cookie "; Max-Age=$max_age"
+ if {$expire == "f"} {
+ # Reinforce Max-Age via "Expires", unless user required
+ # immediate expiration
+ set expire_time [util::cookietime [expr {[ns_time] + $max_age}]]
+ append cookie "; Expires=$expire_time"
+ }
+ }
- if {$expire != "f"} {
- append cookie "; Expires=Tue, 01-Jan-1980 01:00:00 GMT"
- }
+ if {$expire != "f"} {
+ append cookie "; Expires=Tue, 01-Jan-1980 01:00:00 GMT"
+ }
- if { $domain ne "" } {
- append cookie "; Domain=$domain"
- }
+ if { $domain ne "" } {
+ append cookie "; Domain=$domain"
+ }
- if { $secure == "t" } {
- append cookie "; Secure"
- }
+ if { $secure == "t" } {
+ append cookie "; Secure"
+ }
- if { $scriptable == "f" } {
- # Prevent access to this cookie via JavaScript
- append cookie "; HttpOnly"
- }
+ if { $scriptable == "f" } {
+ # Prevent access to this cookie via JavaScript
+ append cookie "; HttpOnly"
+ }
- ns_log Debug "OACS Set-Cookie: $cookie"
- ns_set put $headers "Set-Cookie" $cookie
+ ns_log Debug "OACS Set-Cookie: $cookie"
+ ns_set put $headers "Set-Cookie" $cookie
}
@@ -2110,7 +2202,7 @@
Runs a scheduled procedure and updates monitoring information in the shared variables.
} {
if {[ns_info name] eq "NaviServer"} {
- set proc_info [lindex $proc_info 0]
+ set proc_info [lindex $proc_info 0]
}
# Grab information about the scheduled procedure.
@@ -2122,23 +2214,23 @@
# Find the entry in the shared variable. Splice it out.
for { set i 0 } { $i < [llength $procs] } { incr i } {
- set other_proc_info [lindex $procs $i]
- for { set j 0 } { $j < 5 } { incr j } {
- if { [lindex $proc_info $j] != [lindex $other_proc_info $j] } {
- break
- }
- }
- if { $j == 5 } {
- set count [lindex $other_proc_info 6]
- set procs [lreplace $procs $i $i]
- break
- }
+ set other_proc_info [lindex $procs $i]
+ for { set j 0 } { $j < 5 } { incr j } {
+ if { [lindex $proc_info $j] != [lindex $other_proc_info $j] } {
+ break
+ }
+ }
+ if { $j == 5 } {
+ set count [lindex $other_proc_info 6]
+ set procs [lreplace $procs $i $i]
+ break
+ }
}
if { $once == "f" } {
- # The proc will run again - readd it to the shared variable (updating ns_time and
- # incrementing the count).
- lappend procs [list $thread $once $interval $proc $args [ns_time] [expr { $count + 1 }] $debug]
+ # The proc will run again - readd it to the shared variable (updating ns_time and
+ # incrementing the count).
+ lappend procs [list $thread $once $interval $proc $args [ns_time] [expr { $count + 1 }] $debug]
}
nsv_set ad_procs . $procs
@@ -2179,8 +2271,8 @@
@param all_servers If true run on all servers in a cluster
@param schedule_proc ns_schedule_daily, ns_schedule_weekly or blank
@param interval If schedule_proc is empty, the interval to run the proc
- in seconds, otherwise a list of interval arguments to pass to
- ns_schedule_daily or ns_schedule_weekly
+ in seconds, otherwise a list of interval arguments to pass to
+ ns_schedule_daily or ns_schedule_weekly
@param proc The proc to schedule
@param args And the args to pass it
@@ -2204,10 +2296,10 @@
set my_args [list]
if { $thread == "t" } {
- lappend my_args "-thread"
+ lappend my_args "-thread"
}
if { $once == "t" } {
- lappend my_args "-once"
+ lappend my_args "-once"
}
# Schedule the wrapper procedure (ad_run_scheduled_proc).
@@ -2229,16 +2321,16 @@
} {
ad_return_top_of_page [subst {
-
-
-
-
-
-
Loading...
- If your browser does not automatically redirect you, please click here.
- }]
+
+
+
+
+
+
Loading...
+ If your browser does not automatically redirect you, please click here.
+ }]
}
# Brad Duell (bduell@ncacasi.org) 07/10/2003
@@ -2262,44 +2354,44 @@
set excluded_vars_url ""
for { set i 0 } { $i < [llength $excluded_vars] } { incr i } {
- lassign [lindex $excluded_vars $i] item value
+ lassign [lindex $excluded_vars $i] item value
- if { $value eq "" } {
- set level [template::adp_level]
- # Obtain value from adp level
- upvar #$level \
- __item item_reference \
- __value value_reference
- set item_reference $item
- uplevel #$level {set __value [set $__item]}
- set value $value_reference
- }
- lappend excluded_vars_list $item
- if { $value ne "" } {
- # Value provided
- if { $excluded_vars_url ne "" } {
- append excluded_vars_url "&"
- }
- append excluded_vars_url [export_vars -url [list [list "$item" "$value"]]]
- }
+ if { $value eq "" } {
+ set level [template::adp_level]
+ # Obtain value from adp level
+ upvar #$level \
+ __item item_reference \
+ __value value_reference
+ set item_reference $item
+ uplevel #$level {set __value [set $__item]}
+ set value $value_reference
+ }
+ lappend excluded_vars_list $item
+ if { $value ne "" } {
+ # Value provided
+ if { $excluded_vars_url ne "" } {
+ append excluded_vars_url "&"
+ }
+ append excluded_vars_url [export_vars -url [list [list "$item" "$value"]]]
+ }
}
set saved_list ""
if { $vars ne "" } {
- foreach item_value [split $vars "&"] {
- lassign [split $item_value "="] item value
- if {$item ni $excluded_vars_list} {
- # No need to save the value if it's being passed ...
- if {$item in $saved_list} {
- # Allows for multiple values ...
- append value " [ad_get_client_property [ad_conn package_id] $item]"
- } else {
- # We'll keep track of who we've saved for this package ...
- lappend saved_list $item
- }
- ad_set_client_property -persistent $persistent [ad_conn package_id] $item $value
- }
- }
+ foreach item_value [split $vars "&"] {
+ lassign [split $item_value "="] item value
+ if {$item ni $excluded_vars_list} {
+ # No need to save the value if it's being passed ...
+ if {$item in $saved_list} {
+ # Allows for multiple values ...
+ append value " [ad_get_client_property [ad_conn package_id] $item]"
+ } else {
+ # We'll keep track of who we've saved for this package ...
+ lappend saved_list $item
+ }
+ ad_set_client_property -persistent $persistent [ad_conn package_id] $item $value
+ }
+ }
}
ad_returnredirect "$url?$excluded_vars_url"
@@ -2325,14 +2417,14 @@
This proc is a replacement for ns_returnredirect, but improved in two important respects:
-
- When the supplied target_url isn't complete, (e.g. /foo/bar.tcl or foo.tcl)
- the prepended location part is constructed by looking at the HTTP 1.1 Host header.
-
-
- If an URL relative to the current directory is supplied (e.g. foo.tcl)
- it prepends location and directory.
-
+
+ When the supplied target_url isn't complete, (e.g. /foo/bar.tcl or foo.tcl)
+ the prepended location part is constructed by looking at the HTTP 1.1 Host header.
+
+
+ If an URL relative to the current directory is supplied (e.g. foo.tcl)
+ it prepends location and directory.
+
@param message A message to display to the user. See util_user_message.
@@ -2344,16 +2436,16 @@
@see ad_script_abort
} {
if {$message ne ""} {
- #
- # Leave a hint, that we do not want to be consumed on the
- # current page.
- #
+ #
+ # Leave a hint, that we do not want to be consumed on the
+ # current page.
+ #
set ::__skip_util_get_user_messages 1
- if { [string is false $html_p] } {
- util_user_message -message $message
- } else {
- util_user_message -message $message -html
- }
+ if { [string is false $html_p] } {
+ util_user_message -message $message
+ } else {
+ util_user_message -message $message -html
+ }
}
if { [util_complete_url_p $target_url] } {
@@ -2368,10 +2460,9 @@
set url [util_current_location]$target_url
} else {
# URL is relative to current directory.
- if {$target_url eq "."} {
- set url [util_current_location][util_current_directory]
- } else {
- set url [util_current_location][util_current_directory]$target_url
+ set url [util_current_location][ad_urlencode_folder_path [util_current_directory]]
+ if {$target_url ne "."} {
+ append url $target_url
}
}
@@ -2399,7 +2490,7 @@
} {
if { $message ne "" } {
if { [string is false $html_p] } {
- set message [ad_quotehtml $message]
+ set message [ns_quotehtml $message]
}
if { !$replace_p } {
@@ -2435,7 +2526,7 @@
# content to be consumed (e.g. a redirect) the force keep_p.
#
if {[info exists ::__skip_util_get_user_messages]} {
- set keep_p 1
+ set keep_p 1
}
if { !$keep_p && $messages ne "" } {
ad_set_client_property "acs-kernel" "general_messages" {}
@@ -2446,135 +2537,270 @@
}
}
+
+
ad_proc -public util_complete_url_p {string} {
- Determine whether string is a complete URL, i.e.
- wheteher it begins with protocol: where protocol
- consists of letters only.
+ Determine whether string is a complete URL, i.e.
+ wheteher it begins with protocol: where protocol
+ consists of letters only.
} {
- if {[regexp -nocase {^[a-z]+:} $string]} {
- return 1
- } else {
- return 0
- }
+ if {[regexp -nocase {^[a-z]+:} $string]} {
+ return 1
+ } else {
+ return 0
+ }
}
ad_proc -public util_absolute_path_p {path} {
- Check whether the path begins with a slash
+ Check whether the path begins with a slash
} {
- set firstchar [string index $path 0]
- if {$firstchar ne "/" } {
+ set firstchar [string index $path 0]
+ if {$firstchar ne "/" } {
return 0
- } else {
+ } else {
return 1
- }
+ }
}
ad_proc -public util_driver_info {
- {-array:required}
- {-driver ""}
+ {-array}
+ {-driver ""}
} {
- Returns the protocol and port for the specified driver.
+ Returns the protocol and port for the specified (or current) driver.
- @param driver the driver to query (defaults to [ad_conn driver])
- @param array the array to populate with proto and port
+ @param driver the driver to query (defaults to [ad_conn driver])
+ @param array the array to populate with proto and port
+
+ @see security::configured_driver_info
} {
- upvar $array result
if {$driver eq ""} {
set driver [ad_conn driver]
}
set section [ns_driversection -driver $driver]
- switch $driver {
- nsudp -
- nssock {
- set result(proto) http
- set result(port) [ns_config -int $section Port]
+ switch -glob -- $driver {
+ nsudp* -
+ nssock* {
+ set d [list proto http port [ns_config -int $section Port]]
}
nsunix {
- set result(proto) http
- set result(port) {}
+ set d [list proto http port ""]
}
- nsssl - nsssle {
- set result(port) [ns_config -int $section Port]
- set result(proto) https
+ nsssl* - nsssle {
+ set d [list proto https port [ns_config -int $section Port]]
}
nsopenssl {
- set result(port) [ns_config -int $section ServerPort]
- set result(proto) https
+ set d [list proto https port [ns_config -int $section ServerPort]]
}
default {
ns_log Error "Unknown driver: [ad_conn driver]. Only know nssock, nsunix, nsssl, nsssle, nsopenssl"
- set result(port) [ns_config -int $section Port]
- set result(proto) http
+ set d [list proto http port [ns_config -int $section Port]]
}
}
+ lappend d hostname [ns_config $section hostname]
+
+ if {[info exists array]} {
+ upvar $array result
+ array set result $d
+ }
+ return $d
}
-ad_proc -public util_current_location {} {
- Like ad_conn location - Returns the location string of the current
- request in the form protocol://hostname[:port] but it looks at the
- Host header, that is, takes into account the host name the client
- used although it may be different from the host name from the server
- configuration file. If the Host header is missing or empty
- util_current_location falls back to ad_conn location.
+ad_proc util::split_host {hostspec hostnameVar portVar} {
+ Split host potentially into a host name and a port
+} {
+ upvar $hostnameVar hostname $portVar port
+ if {![regexp {^(.*):(\d+)$} $hostspec . hostname port]} {
+ set port ""
+ set hostname $hostspec
+ }
+ regexp {^\[(.+)\]$} $hostname . hostname
+}
- cro@ncacasi.org 2002-06-07
- Note: IE fouls up the Host header if a server is on a non-standard port; it
- does not change the port number when redirecting to https. So
- we would get redirects from http://some-host:8000 to
- https://some-host:8000
+ad_proc util::split_location {location protoVar hostnameVar portVar} {
+ Split the provided location into "proto", "hostname" and
+ "port". The results are returned to the provided output
+ variables. The function supports IP-literal notation according to
+ RFC 3986 section 3.2.2.
+
+ @author Gustaf Neumann
+ @return boolean value indicating success
+ @see util::join_location
+} {
+ upvar $protoVar proto $hostnameVar hostname $portVar port
- @author Lars Pind (lars@collaboraid.biz)
- @author Peter Marklund
+ set urlInfo [ns_parseurl $location]
+ if {[dict exists $urlInfo proto] && [dict exists $urlInfo host]} {
+ set proto [dict get $urlInfo proto]
+ set hostname [dict get $urlInfo host]
+ if {[dict exists $urlInfo port]} {
+ set port [dict get $urlInfo port]
+ } else {
+ set port [dict get {http 80 https 443} $proto]
+ }
+ set success 1
+ } else {
+ set success 0
+ }
+ return $success
+}
+
+ad_proc util::join_location {{-proto ""} {-hostname} {-port ""}} {
+ Join hostname and port and use IP-literal notation when necessary.
+ The function is the inverse function of util::split_location.
+ @return location consisting of hostname and optionally port
+ @author Gustaf Neumann
+ @see util::split_location
} {
- set default_port(http) 80
- set default_port(https) 443
+ set result ""
+ if {$proto ne ""} {
+ append result $proto://
+ #
+ # When the specified port is equal to the default port, omit
+ # it from the result.
+ #
+ if {$port ne "" && $port eq [dict get {http 80 https 443} $proto]} {
+ set port ""
+ }
+ }
+ if {[string match *:* $hostname]} {
+ append result "\[$hostname\]"
+ } else {
+ append result $hostname
+ }
+ if {$port ne ""} {
+ append result :$port
+ }
+ return $result
+}
+
+ad_proc -public util::configured_location {} {
+
+ Return the configured location as configured for the current
+ network driver. While [util_current_location] honors the virtual
+ host information of the host header field,
+ util::configured_location returns the main configured location
+ (probably the main subsite). This also differs from [ad_url],
+ which returns always the same value from the kernel parameter,
+ since it returns either the https or http result.
+
+ @return the configured location in the form "proto://hostname?:port?"
+
+ @see ad_url
+ @see util_current_location
+} {
+ set driver_info [util_driver_info]
+ return [util::join_location \
+ -proto [dict get $driver_info proto] \
+ -hostname [dict get $driver_info hostname] \
+ -port [dict get $driver_info port]]
+}
+
+ad_proc -public util_current_location {} {
- util_driver_info -array driver
- set proto $driver(proto)
- set port $driver(port)
+ Like [ad_conn location] - Returns the location string of the
+ current request in the form protocol://hostname?:port? but it
+ looks at the "Host:" header field, that is, takes into account the
+ host name the client used although it may be different from the
+ host name from the server configuration file. If the Host header
+ is missing or empty util_current_location falls back to ad_conn
+ location.
- # This is the host from the browser's HTTP request
- set Host [ns_set iget [ns_conn headers] Host]
- lassign [split $Host ":"] Host_hostname Host_port
+ @return the configured location in the form "protocol://hostname?:port?"
- # suppress the configured http port when server is behind a proxy, to keep connection behind proxy
- set suppress_port [parameter::get -package_id [apm_package_id_from_key acs-tcl] -parameter SuppressHttpPort -default 0]
- if { $suppress_port && $port eq [ns_config -int "ns/server/[ns_info server]/module/nssock" Port] } {
- ns_log Debug "util_current_location: suppressing http port $Host_port"
- set Host_port ""
- set port ""
- }
+ @see util::configured_location
+ @see ad_url
+ @see ad_conn
+} {
- # Server config location
- if { ![regexp {^([a-z]+://)?([^:]+)(:[0-9]*)?$} [ad_conn location] match location_proto location_hostname location_port] } {
- ns_log Error "util_current_location couldn't regexp '[ad_conn location]'"
+ #
+ # Compute util_current_location only once per request and cache
+ # the result per thread.
+ #
+ if {[info exists ::__util_current_location]} {
+ return $::__util_current_location
}
+
+ set default_port(http) 80
+ set default_port(https) 443
+ #
+ # The package parameter "SuppressHttpPort" might be set when the
+ # server is behind a proxy to hide the internal port.
+ #
+ set suppress_port [parameter::get \
+ -package_id [apm_package_id_from_key acs-tcl] \
+ -parameter SuppressHttpPort \
+ -default 0]
+ #
+ # Obtain the information from ns_conn based on the actual driver
+ # handling the current request. The obtained variables "proto",
+ # "hostname" and "port" will be the default and might be
+ # overwritten by more specific information.
+ #
+ if {![util::split_location [ns_conn location] proto hostname port]} {
+ ns_log Error "util_current_location got invalid information from driver '[ns_conn location]'"
+ # provide fallback info
+ set hostname [ns_info hostname]
+ set proto ""
+ }
+ if {$proto eq ""} {
+ set proto http
+ set port $default_port($proto)
+ }
- if { $Host eq "" } {
- # No Host header, return protocol from driver, hostname from [ad_conn location], and port from driver
- set hostname $location_hostname
- } else {
- set hostname $Host_hostname
- if { $Host_port ne "" } {
- set port $Host_port
- }
+ if { [ad_conn behind_proxy_p] } {
+ #
+ # We are running behind a proxy
+ #
+ if {[ad_conn behind_secure_proxy_p]} {
+ #
+ # We know, the request was an https request
+ #
+ set proto https
+ }
+ #
+ # reset to the default port
+ #
+ set port $default_port($proto)
}
- if { [ns_config "ns/parameters" ReverseProxyMode false] } {
- if { [ns_set ifind [ad_conn headers] X-Forwarded-For] > -1
- && [ns_set iget [ad_conn headers] X-SSL-Request] == 1} {
- set proto https
- }
+ #
+ # If we want to allow developers to access the backend server
+ # directly (not via the proxy), the clause above does not fire,
+ # although "ReverseProxyMode" was set, since there is no
+ # "X-Forwarded-For". The usage of "SuppressHttpPort" would not
+ # allow this use case.
+ #
+
+ #
+ # In case the "Host:" header field was provided, use the "hostame"
+ # and maybe the "port" from there (this has the highest priority)
+ #
+ set Host [security::validated_host_header]
+ #ns_log notice "util_current_location validated host header <$Host>"
+ if {$Host ne ""} {
+ util::split_host $Host hostname Host_port
+ if {$Host_port ne ""} {
+ set port $Host_port
+ }
+ } else {
+ ns_log notice "ignore non-existing or untrusted host header, fall back to <$hostname>"
}
- if { $port ne "" && $port ne $default_port($proto) } {
- return "$proto://$hostname:$port"
+ #
+ # We have all information, return the data...
+ #
+ if {$suppress_port || $port eq $default_port($proto) || $port eq ""} {
+ set result ${proto}://${hostname}
} else {
- return "$proto://$hostname"
+ set result ${proto}://${hostname}:${port}
}
+
+ set ::__util_current_location $result
+ #ns_log notice "util_current_location returns <$result> based on hostname <$hostname>"
+ return $result
}
ad_proc -public util_current_directory {} {
@@ -2587,51 +2813,84 @@
so that programs that use this proc don't have to treat
the root directory as a special case.
} {
- set path [ad_conn url]
+ set path [ad_conn vhost_url]
- set lastchar [string range $path end end]
- if {$lastchar eq "/" } {
+ set lastchar [string index $path end]
+ if {$lastchar eq "/" } {
return $path
- } else {
+ } else {
set file_dirname [file dirname $path]
# Treat the case of the root directory special
if {$file_dirname eq "/" } {
return /
} else {
return $file_dirname/
}
- }
+ }
}
ad_proc -public ad_call_proc_if_exists { proc args } {
Calls a procedure with particular arguments, only if the procedure is defined.
} {
if { [info commands $proc] ne "" } {
- $proc {*}$args
+ $proc {*}$args
}
}
ad_proc -public ad_get_tcl_call_stack {
{level -2}
} {
- Returns a stack trace from where the caller was called.
- See also ad_print_stack_trace which generates a more readable
- stack trace at the expense of truncating args.
+
+ Returns a stack trace from where the caller was called. See also
+ ad_print_stack_trace which generates a more readable stack trace
+ at the expense of truncating args.
@param level The level to start from, relative to this
- proc. Defaults to -2, meaning the proc that called this
- proc's caller.
+ proc. Defaults to -2, meaning the proc that called this proc's
+ caller. Per default, don't show "ad_log", when this calls
+ ad_get_tcl_call_stack.
-
@author Lars Pind (lars@pinds.com)
@see ad_print_stack_trace
} {
set stack ""
+ #
+ # keep the previous state of ::errorInfo
+ #
+ set errorInfo $::errorInfo
+
for { set x [expr {[info level] + $level}] } { $x > 0 } { incr x -1 } {
- append stack " called from [info level $x]\n"
+ set info [info level $x]
+ regsub -all \n $info {\\n} info
+ #
+ # In case, we have an nsf frame, add information about the
+ # current object and the current class to the debug output.
+ #
+ if {![catch {uplevel #$x ::nsf::current} obj]
+ && ![catch {uplevel #$x [list ::nsf::current class]} class]
+ } {
+ set objInfo [list $obj $class]
+ set info "{$objInfo} $info"
+ }
+ #
+ # Don't produce too long lines
+ #
+ if {[string length $info]>200} {
+ set arglist ""
+ foreach arg $info {
+ if {[string length $arg]>40} {set arg [string range $arg 0 40]...}
+ lappend arglist $arg
+ }
+ set info $arglist
+ }
+ append stack " called from $info\n"
}
+ #
+ # restore previous state of ::errorInfo
+ #
+ set ::errorInfo $errorInfo
return $stack
}
@@ -2658,25 +2917,25 @@
@author Lars Pind (lars@pinds.com)
} {
if { $duplicates ni {ignore fail overwrite} } {
- return -code error "The optional switch duplicates must be either overwrite, ignore or fail"
+ return -code error "The optional switch duplicates must be either overwrite, ignore or fail"
}
set size [ns_set size $set_id]
for { set i 0 } { $i < $size } { incr i } {
- set varname [ns_set key $set_id $i]
- upvar $level $varname var
- if { [info exists var] } {
- switch $duplicates {
- fail {
- return -code error "ad_ns_set_to_tcl_vars tried to set the var $varname which is already set"
- }
- ignore {
- # it's already set ... don't overwrite it
- continue
- }
- }
- }
- set var [ns_set value $set_id $i]
+ set varname [ns_set key $set_id $i]
+ upvar $level $varname var
+ if { [info exists var] } {
+ switch $duplicates {
+ fail {
+ return -code error "ad_ns_set_to_tcl_vars tried to set the var $varname which is already set"
+ }
+ ignore {
+ # it's already set ... don't overwrite it
+ continue
+ }
+ }
+ }
+ set var [ns_set value $set_id $i]
}
}
@@ -2701,18 +2960,18 @@
} {
if { ![info exists set_id] } {
- set set_id [ns_set create]
+ set set_id [ns_set create]
}
if { $put_p } {
- set command put
+ set command put
} else {
- set command update
+ set command update
}
foreach varname $args {
- upvar $varname var
- ns_set $command $set_id $varname $var
+ upvar $varname var
+ ns_set $command $set_id $varname $var
}
return $set_id
}
@@ -2738,18 +2997,18 @@
} {
if { ![info exists set_id] } {
- set set_id [ns_set create]
+ set set_id [ns_set create]
}
if { $put_p } {
- set command put
+ set command put
} else {
- set command update
+ set command update
}
foreach varname $vars_list {
- upvar $varname var
- ns_set $command $set_id $varname $var
+ upvar $varname var
+ ns_set $command $set_id $varname $var
}
return $set_id
}
@@ -2795,7 +3054,7 @@
set sorted_list1 [lsort $list1]
set sorted_list2 [lsort $list2]
-
+
set len1 [llength $sorted_list1]
set len2 [llength $sorted_list2]
@@ -2861,7 +3120,7 @@
}
}
set sorted_list2 [lsort $list2]
-
+
set len1 [llength $sorted_list1]
set len2 [llength $sorted_list2]
@@ -2932,17 +3191,17 @@
} {
if { ![info exists set_id] } {
- set set_id [ns_set create]
+ set set_id [ns_set create]
}
if { $put_p } {
- set command put
+ set command put
} else {
- set command update
+ set command update
}
foreach kv_pair $kv_pairs {
- ns_set $command $set_id [lindex $kv_pair 0] [lindex $kv_pair 1]
+ ns_set $command $set_id [lindex $kv_pair 0] [lindex $kv_pair 1]
}
return $set_id
@@ -2964,14 +3223,14 @@
set keys [list]
set size [ns_set size $set_id]
for { set i 0 } { $i < $size } { incr i } {
- set key [ns_set key $set_id $i]
- if {$key ni $exclude} {
- if { $colon_p } {
- lappend keys ":$key"
- } else {
- lappend keys $key
- }
- }
+ set key [ns_set key $set_id $i]
+ if {$key ni $exclude} {
+ if { $colon_p } {
+ lappend keys ":$key"
+ } else {
+ lappend keys $key
+ }
+ }
}
return $keys
}
@@ -2987,40 +3246,154 @@
@param eol the string to be used at the end of each line.
@param indent the number of spaces to use to indent all lines after the
- first.
+ first.
@param length the maximum line length.
@param items the list of items to be wrapped. Items are
- HTML-formatted. An individual item will never be wrapped onto separate
- lines.
+ HTML-formatted. An individual item will never be wrapped onto separate
+ lines.
} {
set out "
"
set line_length 0
set line_number 0
foreach item $items {
- regsub -all {<[^>]+>} $item "" item_notags
- if { $line_length > $indent } {
- if { $line_length + 1 + [string length $item_notags] > $length } {
- append out "$eol\n"
- incr line_number
- for { set i 0 } { $i < $indent } { incr i } {
- append out " "
- }
- set line_length $indent
- } else {
- append out " "
- incr line_length
- }
- } elseif {$line_number == 0} {
- append out " "
- }
- append out $item
- incr line_length [string length $item_notags]
+ regsub -all {<[^>]+>} $item "" item_notags
+ if { $line_length > $indent } {
+ if { $line_length + 1 + [string length $item_notags] > $length } {
+ append out "$eol\n"
+ incr line_number
+ for { set i 0 } { $i < $indent } { incr i } {
+ append out " "
+ }
+ set line_length $indent
+ } else {
+ append out " "
+ incr line_length
+ }
+ } elseif {$line_number == 0} {
+ append out " "
+ }
+ append out $item
+ incr line_length [string length $item_notags]
}
append out "
"
return $out
}
+# apisano 2017-06-08: this should someday replace proc
+# util_text_to_url, but it is unclear to me whether we want two
+# different semantics to sanitize URLs and filesystem names or
+# not. For the time being I have replaced util_text_to_url in every
+# place where this was used to sanitize filenames.
+ad_proc ad_sanitize_filename {
+ -no_resolve:boolean
+ {-existing_names ""}
+ -collapse_spaces:boolean
+ {-replace_with "-"}
+ -tolower:boolean
+ str
+} {
+ Sanitize the provided filename for modern Windows, OS X, and Unix
+ file systems (NTFS, ext, etc.). FAT 8.3 filenames are not supported.
+ The generated strings should be safe against
+
+ https://github.com/minimaxir/big-list-of-naughty-strings
+
+
+ @author Gustaf Neumann
+} {
+ #
+ # Trim trailing periods and spaces (for Windows)
+ #
+ set str [string trim $str { .}]
+
+ #
+ # Remove Control characters (0x00–0x1f and 0x80–0x9f)
+ # and reserved characters (/, ?, <, >, \, :, *, |, and ")
+ regsub -all {[\u0000-\u001f|/|?|<|>|\\:*|\"]+} $str "" str
+
+ # allow a custom replacement char, that must be safe.
+ regsub -all {[\u0000-\u001f|/|?|<|>|\\:*|\"|\.]+} $replace_with "" replace_with
+ if {$replace_with eq ""} {error "-replace_with must be a safe filesystem character"}
+
+ # dots other than in file extension are dangerous. Put inside two
+ # '#' character will be seen as message keys and file-storage is
+ # currently set to interpret them.
+ set str_ext [file extension $str]
+ set str_noext [string range $str 0 end-[string length $str_ext]]
+ regsub -all {\.} $str_noext $replace_with str_noext
+ set str ${str_noext}${str_ext}
+
+ #
+ # Remove Unix reserved filenames (. and ..)
+ # reserved names in windows
+ set l [string length $str]
+ if {($l < 3 && $str in {"." ".."}) ||
+ ($l == 3 && $str in {CON PRN AUX NUL}) ||
+ ($l == 4 && $str in {
+ COM1 COM2 COM3 COM4 COM5 COM6 COM7 COM8 COM9
+ LPT1 LPT2 LPT3 LPT4 LPT5 LPT6 LPT7 LPT8 LPT9
+ })
+ } {
+ set str ""
+ } elseif {$l > 255} {
+ #
+ # Truncate the name to 255 characters
+ #
+ set str [string range $str 0 254]
+ }
+
+ #
+ # The transformations above are necessary. The following
+ # transformation are optional.
+ #
+ if {$collapse_spaces_p} {
+ #
+ # replace all consecutive spaces by a single char
+ #
+ regsub -all {[ ]+} $str $replace_with str
+ }
+ if {$tolower_p} {
+ #
+ # replace all consecutive spaces by a single "-"
+ #
+ set str [string tolower $str]
+ }
+
+ # check if the resulting name is already present
+ if {$str in $existing_names} {
+
+ if { $no_resolve_p } {
+ # name is already present in the existing_names list and we
+ # are asked to not automatically resolve the collision
+ error "The name $str is already present"
+ } else {
+ # name is already present in the existing_names list -
+ # compute an unoccupied replacement using a pattern like
+ # this: if foo is taken, try foo-2, then foo-3 etc.
+
+ # Holes will not be re-occupied. E.g. if there's foo-2 and
+ # foo-4, a foo-5 will be created instead of foo-3. This
+ # way confusion through replacement of deleted content
+ # with new stuff is avoided.
+
+ set number 2
+
+ foreach name $existing_names {
+
+ if { [regexp "${str}${replace_with}(\\d+)\$" $name match n] } {
+ # matches the foo-123 pattern
+ if { $n >= $number } { set number [expr {$n + 1}] }
+ }
+ }
+
+ set str "$str$replace_with$number"
+ }
+ }
+
+ return $str
+}
+
ad_proc -public util_text_to_url {
{-existing_urls {}}
{-no_resolve:boolean}
@@ -3060,10 +3433,10 @@
# Save some german and french characters from removal by replacing
# them with their ascii counterparts.
- set text [string map { \x00e4 ae \x00f6 oe \x00fc ue \x00df ss \x00f8 o \x00e0 a \x00e1 a \x00e8 e \x00e9 e } $text]
+ set text [string map { \xe4 ae \xf6 oe \xfc ue \xdf ss \xf8 o \xe0 a \xe1 a \xe8 e \xe9 e } $text]
# here's the Danish ones (hm. the o-slash conflicts with the definition above, which just says 'o')
- set text [string map { \x00e6 ae \x00f8 oe \x00e5 aa \x00C6 Ae \x00d8 Oe \x00c5 Aa } $text]
+ set text [string map { \xe6 ae \xf8 oe \xe5 aa \xC6 Ae \xd8 Oe \xc5 Aa } $text]
# substitute all non-word characters
regsub -all {([^a-z0-9])+} $text $replacement text
@@ -3119,8 +3492,8 @@
} {
for { set i 0 } { $i < [llength $args] } { incr i } {
- upvar [lindex $args $i] val
- set val [lindex $list $i]
+ upvar [lindex $args $i] val
+ set val [lindex $list $i]
}
}
@@ -3173,9 +3546,9 @@
} {
set min [lindex $args 0]
foreach arg $args {
- if { $arg < $min } {
- set min $arg
- }
+ if { $arg < $min } {
+ set min $arg
+ }
}
return $min
}
@@ -3189,37 +3562,13 @@
} {
set max [lindex $args 0]
foreach arg $args {
- if { $arg > $max } {
- set max $arg
- }
+ if { $arg > $max } {
+ set max $arg
+ }
}
return $max
}
-# usage:
-# suppose the variable is called "expiration_date"
-# put "[ad_dateentrywidget expiration_date]" in your form
-# and it will expand into lots of weird generated var names
-# put ns_dbformvalue [ns_getform] expiration_date date expiration_date
-# and whatever the user typed will be set in $expiration_date
-
-proc ad_dateentrywidget {column {default_date "1940-11-03"}} {
- if {[ns_info name] ne "NaviServer"} {
- ns_share NS
- } else {
- set NS(months) [list January February March April May June \
- July August September October November December]
- }
- set output " "
-
- return [ns_dbformvalueput $output $column date $default_date]
-}
-
ad_proc -public util_ns_set_to_list {
{-set:required}
} {
@@ -3294,7 +3643,7 @@
set result [list]
foreach ns_set $list_of_ns_sets {
- lappend result [util_ns_set_to_list -set $ns_set]
+ lappend result [util_ns_set_to_list -set $ns_set]
}
return $result
@@ -3309,51 +3658,51 @@
Example:
-set tree [xml_parse -persist {
- <enterprise>
- <properties>
+ set tree [xml_parse -persist {
+ <enterprise>
+ <properties>
<datasource>Dunelm Services Limited</datasource>
<target>Telecommunications LMS</target>
<type>DATABASE UPDATE</type>
<datetime>2001-08-08</datetime>
- </properties>
- <person recstatus = "1">
+ </properties>
+ <person recstatus = "1">
<comments>Add a new Person record.</comments>
<sourcedid>
- <source>Dunelm Services Limited</source>
- <id>CK1</id>
+ <source>Dunelm Services Limited</source>
+ <id>CK1</id>
</sourcedid>
<name>
- <fn>Clark Kent</fn>
- <sort>Kent, C</sort>
- <nickname>Superman</nickname>
+ <fn>Clark Kent</fn>
+ <sort>Kent, C</sort>
+ <nickname>Superman</nickname>
</name>
<demographics>
- <gender>2</gender>
+ <gender>2</gender>
</demographics>
<adr>
- <extadd>The Daily Planet</extadd>
- <locality>Metropolis</locality>
- <country>USA</country>
+ <extadd>The Daily Planet</extadd>
+ <locality>Metropolis</locality>
+ <country>USA</country>
</adr>
- </person>
- </enterprise>
-}]
+ </person>
+ </enterprise>
+ }]
-set root_node [xml_doc_get_first_node $tree]
+ set root_node [xml_doc_get_first_node $tree]
-aa_equals "person -> name -> nickname is Superman" \
- [xml_get_child_node_content_by_path $root_node { { person name nickname } }] "Superman"
+ aa_equals "person -> name -> nickname is Superman" \
+ [xml_get_child_node_content_by_path $root_node { { person name nickname } }] "Superman"
-aa_equals "Same, but after trying a couple of non-existent paths or empty notes" \
- [xml_get_child_node_content_by_path $root_node { { does not exist } { properties } { person name nickname } { person sourcedid id } }] "Superman"
-aa_equals "properties -> datetime" \
- [xml_get_child_node_content_by_path $root_node { { person commments foo } { person name first_names } { properties datetime } }] "2001-08-08"
-
+ aa_equals "Same, but after trying a couple of non-existent paths or empty notes" \
+ [xml_get_child_node_content_by_path $root_node { { does not exist } { properties } { person name nickname } { person sourcedid id } }] "Superman"
+ aa_equals "properties -> datetime" \
+ [xml_get_child_node_content_by_path $root_node { { person commments foo } { person name first_names } { properties datetime } }] "2001-08-08"
+
@param node The node to start from
@param path_list List of list of nodes to try, e.g.
- { { user_id } { sourcedid id } }, or { { name given } { name fn } }.
+ { { user_id } { sourcedid id } }, or { { name given } { name fn } }.
@author Lars Pind (lars@collaboraid.biz)
} {
@@ -3421,7 +3770,7 @@
@param node The node to start from
@param path_list List of the node to try, e.g.
- { grouptype typevalue }.
+ { grouptype typevalue }.
@param attribute_name Attribute name at the very end of the very botton of the tree route at path_list.
@author Rocael Hernandez (roc@viaro.net)
@@ -3431,15 +3780,15 @@
set attribute {}
set current_node $node
foreach element_name $path_list {
- set current_node [xml_node_get_first_child_by_name $current_node $element_name]
- if { $current_node eq "" } {
- # Try the next path
- break
- }
+ set current_node [xml_node_get_first_child_by_name $current_node $element_name]
+ if { $current_node eq "" } {
+ # Try the next path
+ break
+ }
}
if { $current_node ne "" } {
- set attribute [xml_node_get_attribute $current_node $attribute_name ""]
+ set attribute [xml_node_get_attribute $current_node $attribute_name ""]
}
return $attribute
@@ -3473,14 +3822,14 @@
set return_code [catch {uplevel $code} string]
if {[info exists ::errorInfo]} {
- set s_errorInfo $::errorInfo
+ set s_errorInfo $::errorInfo
} else {
- set s_errorInfo ""
+ set s_errorInfo ""
}
if {[info exists ::errorCode]} {
- set s_errorCode $::errorCode
+ set s_errorCode $::errorCode
} else {
- set s_errorCode ""
+ set s_errorCode ""
}
# As promised, always execute FINALLY. If FINALLY throws an
@@ -3489,43 +3838,43 @@
uplevel $finally
switch $return_code {
- 0 {
- # CODE executed without a non-local exit -- return what it
- # evaluated to.
- return $string
- }
- 1 {
- # Error
- if {[lindex $s_errorCode 0 0] eq "CHILDSTATUS"} {
- #
- # GN: In case the errorCode starts with CHILDSTATUS it
- # means that an error was raised from an "exec". In
- # that case the raw error just tells that the "child
- # process exited abnormally", whithout given any
- # details. Therefore we add the exit code to the
- # messages.
- #
- set extra "child process (pid [lindex $s_errorCode 0 1]) exited with exit-code [lindex $s_errorCode 0 end]"
- append string " ($extra)"
- set s_errorInfo $extra\n$s_errorInfo
- }
- return -code error -errorinfo $s_errorInfo -errorcode $s_errorCode $string
- }
- 2 {
- # Return from the caller.
- return -code return $string
- }
- 3 {
- # break
- return -code break
- }
- 4 {
- # continue
- return -code continue
- }
- default {
- return -code $return_code $string
- }
+ 0 {
+ # CODE executed without a non-local exit -- return what it
+ # evaluated to.
+ return $string
+ }
+ 1 {
+ # Error
+ if {[lindex $s_errorCode 0 0] eq "CHILDSTATUS"} {
+ #
+ # GN: In case the errorCode starts with CHILDSTATUS it
+ # means that an error was raised from an "exec". In
+ # that case the raw error just tells that the "child
+ # process exited abnormally", whithout given any
+ # details. Therefore we add the exit code to the
+ # messages.
+ #
+ set extra "child process (pid [lindex $s_errorCode 0 1]) exited with exit-code [lindex $s_errorCode 0 end]"
+ append string " ($extra)"
+ set s_errorInfo $extra\n$s_errorInfo
+ }
+ return -code error -errorinfo $s_errorInfo -errorcode $s_errorCode $string
+ }
+ 2 {
+ # Return from the caller.
+ return -code return $string
+ }
+ 3 {
+ # break
+ return -code break
+ }
+ 4 {
+ # continue
+ return -code continue
+ }
+ default {
+ return -code $return_code $string
+ }
}
}
@@ -3545,7 +3894,7 @@
} {
ns_log Debug "util_background_exec: Starting, waiting for mutex"
-# ns_mutex lock [nsv_get util_background_exec_mutex .]
+ # ns_mutex lock [nsv_get util_background_exec_mutex .]
ns_log Debug "util_background_exec: Got mutex"
@@ -3554,7 +3903,7 @@
nsv_set util_background_exec [list $name] 1
}
-# ns_mutex unlock [nsv_get util_background_exec_mutex .]
+ # ns_mutex unlock [nsv_get util_background_exec_mutex .]
ns_log Debug "util_background_exec: Released mutex"
if { $running_p } {
@@ -3580,14 +3929,13 @@
set errinfo {}
set errcode {}
if { \$errno == 1 } {
- global errorInfo errorCode
- set errinfo \$errorInfo
- set errcode \$errorCode
+ set errinfo \$::errorInfo
+ set errcode \$::errorCode
}
if { \$errno == 1 } {
\# This is an error
- ns_log Error \"util_background_exec: Error in thread named '$name': \$errorInfo\"
+ ns_log Error \"util_background_exec: Error in thread named '$name': \$::errorInfo\"
}
\# errno = 0 (TCL_OK) or 2 (TCL_RETURN) is considered normal, i.e. first elm is true
@@ -3679,73 +4027,73 @@
set key [ns_set key $form $i]
set value [ns_set value $form $i]
- # michael@arsdigita.com:
- #
- # Removed 4000-character length check, because that allowed
- # malicious users to smuggle SQL fragments greater than 4000
- # characters in length.
- #
+ # michael@arsdigita.com:
+ #
+ # Removed 4000-character length check, because that allowed
+ # malicious users to smuggle SQL fragments greater than 4000
+ # characters in length.
+ #
if {
- [regexp -nocase {[^a-z_]or[^a-z0-9_]} $value]
- || [regexp -nocase {union([^a-z0-9_].*all)?[^a-z0-9_].*select} $value]
- } {
- # Looks like the user has added "union [all] select" to
- # the variable, # or is trying to modify the WHERE clause
- # by adding "or ...".
- #
+ [regexp -nocase {[^a-z_]or[^a-z0-9_]} $value]
+ || [regexp -nocase {union([^a-z0-9_].*all)?[^a-z0-9_].*select} $value]
+ } {
+ # Looks like the user has added "union [all] select" to
+ # the variable, # or is trying to modify the WHERE clause
+ # by adding "or ...".
+ #
# Let's see if Oracle would accept this variables as part
- # of a typical WHERE clause, either as string or integer.
- #
- # michael@arsdigita.com: Should we grab a handle once
- # outside of the loop?
- #
+ # of a typical WHERE clause, either as string or integer.
+ #
+ # michael@arsdigita.com: Should we grab a handle once
+ # outside of the loop?
+ #
set parse_result_integer [db_string sql_test_1 "select test_sql('select 1 from dual where 1=[DoubleApos $value]') from dual"]
if { [string first "'" $value] != -1 } {
- #
- # The form variable contains at least one single
- # quote. This can be a problem in the case that
- # the programmer forgot to QQ the variable before
- # interpolation into SQL, because the variable
- # could contain a single quote to terminate the
- # criterion and then smuggled SQL after that, e.g.:
- #
- # set foo "' or 'a' = 'a"
- #
- # db_dml "delete from bar where foo = '$foo'"
- #
- # which would be processed as:
- #
- # delete from bar where foo = '' or 'a' = 'a'
- #
- # resulting in the effective truncation of the bar
- # table.
- #
+ #
+ # The form variable contains at least one single
+ # quote. This can be a problem in the case that
+ # the programmer forgot to QQ the variable before
+ # interpolation into SQL, because the variable
+ # could contain a single quote to terminate the
+ # criterion and then smuggled SQL after that, e.g.:
+ #
+ # set foo "' or 'a' = 'a"
+ #
+ # db_dml "delete from bar where foo = '$foo'"
+ #
+ # which would be processed as:
+ #
+ # delete from bar where foo = '' or 'a' = 'a'
+ #
+ # resulting in the effective truncation of the bar
+ # table.
+ #
set parse_result_string [db_string sql_test_2 "select test_sql('select 1 from dual where 1=[DoubleApos "'$value'"]') from dual"]
} else {
set parse_result_string 1
}
if {
- $parse_result_integer == 0
- || $parse_result_integer == -904
- || $parse_result_integer == -1789
- || $parse_result_string == 0
- || $parse_result_string == -904
- || $parse_result_string == -1789
- } {
+ $parse_result_integer == 0
+ || $parse_result_integer == -904
+ || $parse_result_integer == -1789
+ || $parse_result_string == 0
+ || $parse_result_string == -904
+ || $parse_result_string == -1789
+ } {
# Code -904 means "invalid column", -1789 means
- # "incorrect number of result columns". We treat this
- # the same as 0 (no error) because the above statement
- # just selects from dual and 904 or 1789 only occur
- # after the parser has validated that the query syntax
- # is valid.
+ # "incorrect number of result columns". We treat this
+ # the same as 0 (no error) because the above statement
+ # just selects from dual and 904 or 1789 only occur
+ # after the parser has validated that the query syntax
+ # is valid.
ns_log Error "ad_block_sql_urls: Suspicious request from [ad_conn peeraddr]. Parameter $key contains code that looks like part of a valid SQL WHERE clause: [ad_conn url]?[ad_conn query]"
- # michael@arsdigita.com: Maybe we should just return a
- # 501 error.
- #
+ # michael@arsdigita.com: Maybe we should just return a
+ # 501 error.
+ #
ad_return_error "Suspicious Request" "Parameter $key looks like it contains SQL code. For security reasons, the system won't accept your request."
return filter_return
@@ -4016,7 +4364,7 @@
}
#exec "mv" "$file_path" "$backup_path"
- file rename $file_path $backup_path
+ file rename -- $file_path $backup_path
}
@@ -4076,7 +4424,7 @@
set len [llength $list]
set result [list]
while { [llength $list] > 0 } {
- set index [randomRange [llength $list]]
+ set index [randomRange [expr {[llength $list] - 1}]]
lappend result [lindex $list $index]
set list [lreplace $list $index $index]
}
@@ -4121,7 +4469,7 @@
set age_seconds 60
}
- if { $age_seconds < $hours_limit * 60 * 60 } {
+ if { $age_seconds < $hours_limit * 60 * 60 } {
set hours [expr {abs($age_seconds / 3600)}]
set minutes [expr {round(($age_seconds% 3600)/60.0)}]
if {$hours < 24} {
@@ -4154,119 +4502,119 @@
ad_proc -public util::word_diff {
- {-old:required}
- {-new:required}
- {-split_by {}}
- {-filter_proc {ad_quotehtml}}
- {-start_old {}}
- {-end_old {}}
- {-start_new {}}
- {-end_new {}}
+ {-old:required}
+ {-new:required}
+ {-split_by {}}
+ {-filter_proc {ns_quotehtml}}
+ {-start_old {}}
+ {-end_old {}}
+ {-start_new {}}
+ {-end_new {}}
} {
- Does a word (or character) diff on two lines of text and indicates text
- that has been deleted/changed or added by enclosing it in
- start/end_old/new.
-
- @param old The original text.
- @param new The modified text.
-
- @param split_by If split_by is a space, the diff will be made
- on a word-by-word basis. If it is the empty string, it will be made on
- a char-by-char basis.
+ Does a word (or character) diff on two lines of text and indicates text
+ that has been deleted/changed or added by enclosing it in
+ start/end_old/new.
+
+ @param old The original text.
+ @param new The modified text.
+
+ @param split_by If split_by is a space, the diff will be made
+ on a word-by-word basis. If it is the empty string, it will be made on
+ a char-by-char basis.
- @param filter_proc A filter to run the old/new text through before
- doing the diff and inserting the HTML fragments below. Keep in mind
- that if the input text is HTML, and the start_old, etc... fragments are
- inserted at arbitrary locations depending on where the diffs are, you
- might end up with invalid HTML unless the original HTML is quoted.
+ @param filter_proc A filter to run the old/new text through before
+ doing the diff and inserting the HTML fragments below. Keep in mind
+ that if the input text is HTML, and the start_old, etc... fragments are
+ inserted at arbitrary locations depending on where the diffs are, you
+ might end up with invalid HTML unless the original HTML is quoted.
- @param start_old HTML fragment to place before text that has been removed.
- @param end_old HTML fragment to place after text that has been removed.
- @param start_new HTML fragment to place before new text.
- @param end_new HTML fragment to place after new text.
+ @param start_old HTML fragment to place before text that has been removed.
+ @param end_old HTML fragment to place after text that has been removed.
+ @param start_new HTML fragment to place before new text.
+ @param end_new HTML fragment to place after new text.
- @see ad_quotehtml
- @author Gabriel Burca
+ @see ns_quotehtml
+ @author Gabriel Burca
} {
- if {$filter_proc ne ""} {
- set old [$filter_proc $old]
- set new [$filter_proc $new]
- }
+ if {$filter_proc ne ""} {
+ set old [$filter_proc $old]
+ set new [$filter_proc $new]
+ }
- set old_f [ad_tmpnam]
- set new_f [ad_tmpnam]
- set old_fd [open $old_f "w"]
- set new_fd [open $new_f "w"]
- puts $old_fd [join [split $old $split_by] "\n"]
- puts $new_fd [join [split $new $split_by] "\n"]
- close $old_fd
- close $new_fd
+ set old_f [ad_tmpnam]
+ set new_f [ad_tmpnam]
+ set old_fd [open $old_f "w"]
+ set new_fd [open $new_f "w"]
+ puts $old_fd [join [split $old $split_by] "\n"]
+ puts $new_fd [join [split $new $split_by] "\n"]
+ close $old_fd
+ close $new_fd
- # Diff output is 1 based, our lists are 0 based, so insert a dummy
- # element to start the list with.
- set old_w [linsert [split $old $split_by] 0 {}]
- set sv 1
+ # Diff output is 1 based, our lists are 0 based, so insert a dummy
+ # element to start the list with.
+ set old_w [linsert [split $old $split_by] 0 {}]
+ set sv 1
-# For debugging purposes:
-# set diff_pipe [open "| diff -f $old_f $new_f" "r"]
-# while {![eof $diff_pipe]} {
-# append res "[gets $diff_pipe] "
-# }
+ # For debugging purposes:
+ # set diff_pipe [open "| diff -f $old_f $new_f" "r"]
+ # while {![eof $diff_pipe]} {
+ # append res "[gets $diff_pipe] "
+ # }
- set diff_pipe [open "| diff -f $old_f $new_f" "r"]
- while {![eof $diff_pipe]} {
- gets $diff_pipe diff
- if {[regexp {^d(\d+)(\s+(\d+))?$} $diff full m1 m2]} {
- if {$m2 ne ""} {set d_end $m2} else {set d_end $m1}
- for {set i $sv} {$i < $m1} {incr i} {
- append res "${split_by}[lindex $old_w $i]"
- }
- for {set i $m1} {$i <= $d_end} {incr i} {
- append res "${split_by}${start_old}[lindex $old_w $i]${end_old}"
- }
- set sv [expr {$d_end + 1}]
- } elseif {[regexp {^c(\d+)(\s+(\d+))?$} $diff full m1 m2]} {
- if {$m2 ne ""} {set d_end $m2} else {set d_end $m1}
- for {set i $sv} {$i < $m1} {incr i} {
- append res "${split_by}[lindex $old_w $i]"
- }
- for {set i $m1} {$i <= $d_end} {incr i} {
- append res "${split_by}${start_old}[lindex $old_w $i]${end_old}"
- }
- while {![eof $diff_pipe]} {
- gets $diff_pipe diff
- if {$diff eq "."} {
- break
- } else {
- append res "${split_by}${start_new}${diff}${end_new}"
- }
- }
- set sv [expr {$d_end + 1}]
- } elseif {[regexp {^a(\d+)$} $diff full m1]} {
- set d_end $m1
- for {set i $sv} {$i < $m1} {incr i} {
- append res "${split_by}[lindex $old_w $i]"
- }
- while {![eof $diff_pipe]} {
- gets $diff_pipe diff
- if {$diff eq "."} {
- break
- } else {
- append res "${split_by}${start_new}${diff}${end_new}"
- }
- }
- set sv [expr {$d_end + 1}]
- }
- }
-
- for {set i $sv} {$i < [llength $old_w]} {incr i} {
- append res "${split_by}[lindex $old_w $i]"
- }
+ set diff_pipe [open "| diff -f $old_f $new_f" "r"]
+ while {![eof $diff_pipe]} {
+ gets $diff_pipe diff
+ if {[regexp {^d(\d+)(\s+(\d+))?$} $diff full m1 m2]} {
+ if {$m2 ne ""} {set d_end $m2} else {set d_end $m1}
+ for {set i $sv} {$i < $m1} {incr i} {
+ append res "${split_by}[lindex $old_w $i]"
+ }
+ for {set i $m1} {$i <= $d_end} {incr i} {
+ append res "${split_by}${start_old}[lindex $old_w $i]${end_old}"
+ }
+ set sv [expr {$d_end + 1}]
+ } elseif {[regexp {^c(\d+)(\s+(\d+))?$} $diff full m1 m2]} {
+ if {$m2 ne ""} {set d_end $m2} else {set d_end $m1}
+ for {set i $sv} {$i < $m1} {incr i} {
+ append res "${split_by}[lindex $old_w $i]"
+ }
+ for {set i $m1} {$i <= $d_end} {incr i} {
+ append res "${split_by}${start_old}[lindex $old_w $i]${end_old}"
+ }
+ while {![eof $diff_pipe]} {
+ gets $diff_pipe diff
+ if {$diff eq "."} {
+ break
+ } else {
+ append res "${split_by}${start_new}${diff}${end_new}"
+ }
+ }
+ set sv [expr {$d_end + 1}]
+ } elseif {[regexp {^a(\d+)$} $diff full m1]} {
+ set d_end $m1
+ for {set i $sv} {$i < $m1} {incr i} {
+ append res "${split_by}[lindex $old_w $i]"
+ }
+ while {![eof $diff_pipe]} {
+ gets $diff_pipe diff
+ if {$diff eq "."} {
+ break
+ } else {
+ append res "${split_by}${start_new}${diff}${end_new}"
+ }
+ }
+ set sv [expr {$d_end + 1}]
+ }
+ }
+
+ for {set i $sv} {$i < [llength $old_w]} {incr i} {
+ append res "${split_by}[lindex $old_w $i]"
+ }
- file delete -- $old_f $new_f
+ file delete -- $old_f $new_f
- return $res
+ return $res
}
ad_proc -public util::string_length_compare { s1 s2 } {
@@ -4275,18 +4623,18 @@
set l1 [string length $s1]
set l2 [string length $s2]
if { $l1 < $l2 } {
- return -1
+ return -1
} elseif { $l1 > $l2 } {
- return 1
+ return 1
} else {
- return 0
+ return 0
}
}
ad_proc -public util::roll_server_log {} {
Invoke the AOLserver ns_logroll command with some bookend log records. This rolls the error log, not the access log.
} {
- # This param controlls how many backups of the server log to keep,
+ # This param controls how many backups of the server log to keep,
ns_config -int "ns/parameters" logmaxbackup 10
ns_log Notice "util::roll_server_log: Rolling the server log now..."
ns_logroll
@@ -4338,103 +4686,102 @@
# add contained files to $new_files_to_examine (which will become
# $files_to_examine in the next iteration).
while { [incr max_depth -1] > -2 && [llength $files_to_examine] != 0 } {
- set new_files_to_examine [list]
- foreach file $files_to_examine {
- # Only examine the file if we haven't already. (This is just a safeguard
- # in case, e.g., Tcl decides to play funny games with symbolic links so
- # we end up encountering the same file twice.)
- if { ![info exists examined_files($file)] } {
- # Remember that we've examined the file.
- set examined_files($file) 1
+ set new_files_to_examine [list]
+ foreach file $files_to_examine {
+ # Only examine the file if we haven't already. (This is just a safeguard
+ # in case, e.g., Tcl decides to play funny games with symbolic links so
+ # we end up encountering the same file twice.)
+ if { ![info exists examined_files($file)] } {
+ # Remember that we've examined the file.
+ set examined_files($file) 1
- if { $check_file_func eq "" || [$check_file_func $file] } {
- # If it's a file, add to our list. If it's a
- # directory, add its contents to our list of files to
- # examine next time.
-
- set filename [lindex [split $file "/"] end]
- set file_extension [lindex [split $filename "."] end]
- if { [file isfile $file] } {
- if {$extension eq "" || $file_extension eq $extension} {
- lappend files [list $filename $file]
- }
- } elseif { [file isdirectory $file] } {
- if { $include_dirs == 1 } {
- lappend files $file
- }
- set new_files_to_examine [concat $new_files_to_examine [glob -nocomplain "$file/*"]]
- }
- }
- }
- }
- set files_to_examine $new_files_to_examine
+ if { $check_file_func eq "" || [$check_file_func $file] } {
+ # If it's a file, add to our list. If it's a
+ # directory, add its contents to our list of files to
+ # examine next time.
+
+ set filename [lindex [split $file "/"] end]
+ set file_extension [lindex [split $filename "."] end]
+ if { [file isfile $file] } {
+ if {$extension eq "" || $file_extension eq $extension} {
+ lappend files [list $filename $file]
+ }
+ } elseif { [file isdirectory $file] } {
+ if { $include_dirs == 1 } {
+ lappend files $file
+ }
+ set new_files_to_examine [concat $new_files_to_examine [glob -nocomplain "$file/*"]]
+ }
+ }
+ }
+ }
+ set files_to_examine $new_files_to_examine
}
return $files
}
ad_proc -public util::string_check_urlsafe {
- s1
+ s1
} {
- This proc accepts a string and verifies if it is url safe.
- - make sure there is no space
- - make sure there is no special characters except '-' or '_'
- Returns 1 if yes and 0 if not.
- Meant to be used in the validation section of ad_form.
+ This proc accepts a string and verifies if it is url safe.
+ - make sure there is no space
+ - make sure there is no special characters except '-' or '_'
+ Returns 1 if yes and 0 if not.
+ Meant to be used in the validation section of ad_form.
} {
- return [regexp {[<>:\"|/@\#%&+\\ ]} $s1]
+ return [regexp {[<>:\"|/@\#%&+\\ ]} $s1]
}
ad_proc -public util::which {prog} {
- @author Gustaf Neumann
+ Use environment variable PATH to search for the specified executable
+ program. Replacement for UNIX command "which", avoiding exec.
- Use environment variable PATH to search for the specified executable
- program. Replacement for UNIX command "which", avoiding exec.
-
exec which: 3368.445 microseconds per iteration
::util::which: 282.372 microseconds per iteration
-
- In addition of being more than 10 time faster than the
- version via exec, this version is less platform dependent.
+
+ In addition of being more than 10 time faster than the
+ version via exec, this version is less platform dependent.
- @param prog name of the program to be located on the search path
- @return fully qualified name including path, when specified program is found,
- or otherwise empty string
+ @param prog name of the program to be located on the search path
+ @return fully qualified name including path, when specified program is found,
+ or otherwise empty string
+ @author Gustaf Neumann
} {
- switch $::tcl_platform(platform) {
- windows {
- #
- # Notice: Windows has an alternative search environment
- # via registry. Maybe it is necessary in the future
- # to locate the program via registry (sketch below)
- #
- # package require registry
- # set key {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths}
- # set entries [registry keys $key $prog.*]
- # if {[llength $entries]>0} {
- # set fullkey "$key\\[lindex $entries 0]"
- # return [registry get $fullkey ""]
- # }
- # return ""
- #
- set searchdirs [split $::env(PATH) \;]
- set exts [list .exe .dll .com .bat]
+ switch $::tcl_platform(platform) {
+ windows {
+ #
+ # Notice: Windows has an alternative search environment
+ # via registry. Maybe it is necessary in the future
+ # to locate the program via registry (sketch below)
+ #
+ # package require registry
+ # set key {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths}
+ # set entries [registry keys $key $prog.*]
+ # if {[llength $entries]>0} {
+ # set fullkey "$key\\[lindex $entries 0]"
+ # return [registry get $fullkey ""]
+ # }
+ # return ""
+ #
+ set searchdirs [split $::env(PATH) \;]
+ set exts [list .exe .dll .com .bat]
+ }
+ default {
+ set searchdirs [split $::env(PATH) :]
+ set exts [list ""]
+ }
}
- default {
- set searchdirs [split $::env(PATH) :]
- set exts [list ""]
+ foreach dir $searchdirs {
+ set fullname [file join $dir $prog]
+ foreach ext $exts {
+ if {[file executable $fullname$ext]} {
+ return $fullname$ext
+ }
+ }
}
- }
- foreach dir $searchdirs {
- set fullname [file join $dir $prog]
- foreach ext $exts {
- if {[file executable $fullname$ext]} {
- return $fullname$ext
- }
- }
- }
- return ""
+ return ""
}
ad_proc util::catch_exec {command result_var} {
@@ -4446,8 +4793,9 @@
@param command A list of arguments to pass to exec
@param result_var Variable name in caller's scope to set the result in
- @return 0 or 1. 0 if no error, 1 if an error occured. If an error occured
- the error message will be put into result_var in the caller's scope.
+ @return 0 or 1. 0 if no error, 1 if an error occurred. If an error
+ occurred the error message will be put into result_var in the
+ caller's scope.
@author Dave Bauer
@creation-date 2008-01-28
@@ -4514,7 +4862,7 @@
# failed. The error code is in $errName, and a
# human-readable message is in $msg.
ns_log notice "util::catch_exec: posix $errName $msg $result"
- set result "an error occured $errName \"$msg\""
+ set result "an error occurred $errName \"$msg\""
return 1
}
@@ -4528,18 +4876,28 @@
valid alternatives include
HTTPS or HTTP protocol change
HTTP or HTTPS port number added or removed from current host name
- or another hostname that the host responds to (from host_node_map)
+ or another hostname that the host responds to (from host_node_map)
} {
- set locations_list [security::locations]
- # there may be as many as 3 valid full urls from one hostname
set external_url_p [util_complete_url_p $url]
-
- # more valid url pairs with host_node_map
- foreach location $locations_list {
- set encoded_location [ns_urlencode $location]
- # ns_log Notice "util::external_url_p location \"$location/*\" url $url match [string match "${encoded_location}/*" $url]"
- set external_url_p [expr { $external_url_p && ![string match "$location/*" $url] } ]
- set external_url_p [expr { $external_url_p && ![string match "${encoded_location}/*" $url] } ]
+ #
+ # Only if the URL is syntactical a URL with a protocol, it might
+ # be external.
+ #
+ if {$external_url_p} {
+ #
+ # If it has a protocol, we have to be able to find it in security::locations
+ #
+ set locations_list [security::locations]
+ # more valid url pairs with host_node_map
+
+ foreach location $locations_list {
+ set len [string length $location]
+ #ns_log notice "util::external_url_p location match <$location/*> with <$url> sub <[string range $url 0 $len-1]>"
+ if {[string range $url 0 $len-1] eq $location} {
+ set external_url_p 0
+ break
+ }
+ }
}
return $external_url_p
}
@@ -4569,10 +4927,10 @@
} {
if {$timeout ne ""} {
- set timeout "-timeout $timeout"
+ set timeout "-timeout $timeout"
}
if {$queue ni [ns_job queues]} {
- ns_job create $queue
+ ns_job create $queue
}
set j [ns_job queue $queue $args]
return [ns_job wait {*}$timeout $queue $j]
@@ -4587,32 +4945,32 @@
if {[ns_info name] eq "NaviServer"} {
ad_proc -public ad_mutex_eval {mutex script} {
- Compatibility proc for handling differences between NaviServer
- and AOLserver since AOLserver does not support "ns_mutex
- eval".
+ Compatibility proc for handling differences between NaviServer
+ and AOLserver since AOLserver does not support "ns_mutex
+ eval".
- @author Gustaf Neumann
-
+ @author Gustaf Neumann
+
} {
- uplevel [list ns_mutex eval $mutex $script]
+ uplevel [list ns_mutex eval $mutex $script]
}
} else {
ad_proc -public ad_mutex_eval {mutex script} {
- Compatibility proc for handling differences between NaviServer
- and AOLserver since AOLserver does not support "ns_mutex
- eval".
+ Compatibility proc for handling differences between NaviServer
+ and AOLserver since AOLserver does not support "ns_mutex
+ eval".
- @author Gustaf Neumann
+ @author Gustaf Neumann
} {
- ns_mutex lock $mutex
- set err [catch {uplevel $script} result]
- ns_mutex unlock $mutex
- if {$err} {
- error $result
- }
- return $result
+ ns_mutex lock $mutex
+ set err [catch {uplevel $script} result]
+ ns_mutex unlock $mutex
+ if {$err} {
+ error $result
+ }
+ return $result
}
}
@@ -4621,13 +4979,230 @@
which uses the deprecated C-library function "tmpnam()"
} {
if {$template eq ""} {
- set template [ns_config ns/parameters tmpdir]/oacs-XXXXXX
+ set template [ns_config ns/parameters tmpdir]/oacs-XXXXXX
}
ns_mktemp $template
}
ad_proc ad_tmpdir {} {
- conveniece function to return the tmp directory
+ Convenience function to return the tmp directory
} {
return [ns_config ns/parameters tmpdir]
}
+
+
+#
+# Experimental disk-cache, to test whether this can speed up e.g. openacs.org forums threads....
+# Documentation follows
+#
+
+if { [apm_first_time_loading_p] } {
+ nsv_set ad_disk_cache mutex [ns_mutex create]
+}
+
+ad_proc -public util::disk_cache_flush {
+ -key:required
+ -id:required
+} {
+} {
+ set dir [ad_tmpdir]/$key
+ foreach file [flib -nocomplain $dir/$id-*] {
+ file delete -- $file
+ ns_log notice "FLUSH file delete -- $file"
+ }
+}
+
+ad_proc -public util::disk_cache_eval {
+ -call:required
+ -key:required
+ -id:required
+} {
+} {
+ set cache [::parameter::get_from_package_key \
+ -package_key acs-tcl \
+ -parameter DiskCache \
+ -default 1]
+ if {$cache} {
+ set hash [ns_sha1 $call]
+ set dir [ad_tmpdir]/oacs-cache/$key
+ set file_name $dir/$id-$hash
+ if {![file isdirectory $dir]} {file mkdir $dir}
+ ns_mutex eval [nsv_get ad_disk_cache mutex] {
+ if {[file readable $file_name]} {
+ set result [template::util::read_file $file_name]
+ } else {
+ set result [{*}$call]
+ template::util::write_file $file_name $result
+ }
+ }
+ } else {
+ set result [{*}$call]
+ }
+ return $result
+}
+
+ad_proc -public util::request_info {
+ {-with_headers:boolean false}
+} {
+
+ Produce a string containing the detailed request information.
+ This is in particular useful for debugging, when errors are raised.
+
+ @param with_headers Include request headers
+ @author Gustaf Neumann
+
+} {
+ set info ""
+ if {[ns_conn isconnected]} {
+ #
+ # Base information
+ #
+ append info " " \
+ [ns_conn method] \
+ " [util_current_location][ns_conn url]?[ns_conn query]" \
+ " referred by '[get_referrer]' peer [ad_conn peeraddr] user_id [ad_conn user_id]"
+
+ if {[ns_conn method] eq "POST"} {
+ #
+ # POST data info
+ #
+ if {[ns_conn flags] & 1} {
+ append info "\n connection already closed, cooked form-content:"
+ foreach {k v} [ns_set array [ns_getform]] {
+ if {[string length $v] > 100} {
+ set v "[string range $v 0 100]..."
+ }
+ append info "\n $k:\t$v"
+ }
+ } else {
+ set ct [ns_set iget [ns_conn headers] content-type]
+ if {[string match text/* $ct] || $ct eq "application/x-www-form-urlencoded"} {
+ set data [ns_conn content]
+ if {[string length $data] < 2000} {
+ append info "\n post-data: $data"
+ }
+ }
+ }
+ }
+
+ #
+ # Optional header info
+ #
+ if {$with_headers_p} {
+ append info \n
+ foreach {k v} [ns_set array [ns_conn headers]] {
+ append info "\n $k:\t$v"
+ }
+ }
+ }
+ return $info
+}
+
+ad_proc util::trim_leading_zeros {
+ string
+} {
+ Returns a string w/ leading zeros trimmed.
+ Used to get around Tcl interpreter problems w/ thinking leading
+ zeros are octal.
+
+ If string is real and mod(number)<1, then we have pulled off
+ the leading zero; i.e. 0.231 -> .231 -- this is still fine
+ for Tcl though...
+} {
+ if {$string ne ""} {
+ set string [string trimleft $string 0]
+ if {$string eq ""} {
+ set string 0
+ }
+ }
+ return $string
+}
+
+ad_proc -public ad_log {
+ level
+ message
+} {
+ Output ns_log message with detailed context. This function is
+ intended to be used typically with "error" to ease debugging.
+
+ @param level Severity level such as "error" or "warning".
+ @param message Log message
+
+ @author Gustaf Neumann
+} {
+ set with_headers [expr {$level in {error Error}}]
+ append request " " \
+ [util::request_info -with_headers=$with_headers]
+
+ ns_log $level "${message}\n[uplevel ad_get_tcl_call_stack]${request}\n"
+}
+
+
+if {[info commands ns_parseurl] eq ""} {
+ #
+ # In case, we are not running under NaviServer, provide a proc
+ # compatible with NaviServer's built in ns_parseurl.
+ #
+ ad_proc ns_parseurl {url} {
+ Emulation of NaviServer's ns_parseurl
+
+ @author Gustaf Neumann
+ } {
+ #puts stderr url=$url
+ set result ""
+ if {[regexp {^([a-zA-Z]+):(.*)$} $url . proto url]} {
+ #
+ # a protocol was specified
+ #
+ lappend result proto $proto
+ }
+ if {[regexp {^//([^/]+)(/?.*)$} $url . host url]} {
+ #
+ # two slashes -> host is specified
+ #
+ if {[regexp {^\[(.*)\]:([0-9]+)$} $host . host port]} {
+ # IP literal notation followed by port
+ lappend result host $host port $port
+ } elseif {[regexp {^\[(.*)\]$} $host . host port]} {
+ # IP literal notation followed with no port
+ lappend result host $host
+ } elseif {[regexp {^(.*):([0-9]+)$} $host . host port]} {
+ lappend result host $host port $port
+ } else {
+ lappend result host $host
+ }
+ }
+ if {[regexp {^/(.*)/([^/]+)$} $url . path tail]} {
+ lappend result path $path tail $tail
+ } elseif {[regexp {^/([^/]+)$} $url . tail]} {
+ lappend result path "" tail $tail
+ } elseif {$url in {"/" ""}} {
+ lappend result path {} tail {}
+ } else {
+ lappend result tail $url
+ }
+ return $result
+ }
+}
+
+if {[info commands ns_md5] eq ""} {
+ #
+ # In case, we are not running under NaviServer, provide a proc
+ # compatible with NaviServer's built in ns_md5
+ #
+ ad_proc ns_md5 {value} {
+ Emulation of NaviServer's ns_md5
+
+ @author Gustaf Neumann
+ } {
+ package require md5
+ return [md5::Hex [md5::md5 -- $value]]
+ }
+}
+
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End: