Index: openacs-4/packages/xotcl-core/tcl/context-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/context-procs.tcl,v
diff -u -r1.75 -r1.76
--- openacs-4/packages/xotcl-core/tcl/context-procs.tcl 5 Aug 2018 21:16:25 -0000 1.75
+++ openacs-4/packages/xotcl-core/tcl/context-procs.tcl 3 Sep 2024 15:37:54 -0000 1.76
@@ -1,6 +1,6 @@
xo::library doc {
Context handling interface
-
+
Definition of a connection context, containing user info, URLs, parameters.
this is used via "Package initialize"... similar as page_contracts and
for included content (includelets), and used for per-connection caching as well.
@@ -15,21 +15,21 @@
namespace eval ::xo {
::xotcl::Class create Context -ad_doc {
- This class provides a context for evaluation, somewhat similar to an
+ This class provides a context for evaluation, somewhat similar to an
activation record in programming languages. It combines the parameter
declaration (e.g. of a page, an includelet) with the actual parameters
(specified in an includelet) and the provided query values (from the url).
The parameter decaration are actually XOTcl's non positional arguments.
} -parameter {
- {parameter_declaration ""}
+ {parameter_declaration ""}
{actual_query " "}
{package_id 0}
{invoke_object}
locale
}
#
- # Syntactic sugar for includelets, to allow the same syntax as
+ # Syntactic sugar for includelets, to allow the same syntax as
# for "Package initialize ...."; however, we do not allow currently
# do switch user or package id etc., just the parameter declaration
Context instproc initialize {{-parameter ""}} {
@@ -41,79 +41,90 @@
{-all_from_caller:boolean true}
{-caller_parameters}
} {
- :proc __parse [:parameter_declaration] {
- foreach v [info vars] { uplevel [list set :queryparm($v) [set $v]]}
- }
-
- foreach v [:parameter_declaration] {
- set ([lindex [split [lindex $v 0] :] 0]) 1
- }
+ set declared_parameters [lmap v ${:parameter_declaration} {
+ string range [lindex [split [lindex $v 0] :] 0] 1 end
+ }]
+
if {${:actual_query} eq " "} {
if {[ns_conn isconnected]} {
set :actual_query [ns_conn query]
}
- #my log "--CONN ns_conn query = <$actual_query>"
+ #:log "--P actual_query <${:actual_query}> url [ns_conn url] q [ns_conn query]"
}
-
- set decodeCmd ns_urldecode
- if {$::xo::naviserver} {lappend decodeCmd --}
-
- # get the query parameters (from the url)
- #my log "--P processing actual query ${:actual_query}"
- foreach querypart [split ${:actual_query} &] {
- set name_value_pair [split $querypart =]
- set att_name [{*}$decodeCmd [lindex $name_value_pair 0]]
- if {$att_name eq ""} continue
- if {[llength $name_value_pair] == 1} {
- set att_value 1
- } else {
- set att_value [{*}$decodeCmd [lindex $name_value_pair 1]]
+ set passed_args ""
+ #:log "--P processing actual query '${:actual_query}'"
+ try {
+ set paramset [ns_parsequery ${:actual_query}]
+ foreach {att_name att_value} [ns_set array $paramset] {
+ if {$att_name eq ""} continue
+ if {$att_name in $declared_parameters} {
+ dict lappend passed_args -$att_name $att_value
+ } elseif {$all_from_query} {
+ set :queryparm($att_name) $att_value
+ }
}
- if {[info exists (-$att_name)]} {
- lappend passed_args(-$att_name) $att_value
- } elseif {$all_from_query} {
- set :queryparm($att_name) $att_value
- }
+ } on error {errorMsg} {
+ ad_log warning "process_query_parameter: $errorMsg"
+ ad_return_complaint 1 "invalid characters in HTTP query parameters"
}
# get the query parameters (from the form if necessary)
if {[:istype ::xo::ConnectionContext]} {
- foreach param [array names ""] {
- #my log "--cc check $param [info exists passed_args($param)]"
- set name [string range $param 1 end]
- if {![info exists passed_args($param)] &&
- [:exists_form_parameter $name]} {
- #my log "--cc adding passed_args(-$name) [:form_parameter $name]"
- set passed_args($param) [:form_parameter $name]
+ foreach name $declared_parameters {
+ set param -$name
+ #:log "--cc check $param [dict exists $passed_args $param]"
+ if {![dict exists $passed_args $param]
+ && [:exists_form_parameter $name]
+ } {
+ #:log "--cc adding passed_args(-$name) [:form_parameter $name]"
+ dict set passed_args $param [:form_parameter $name]
}
}
}
-
+
# get the caller parameters (e.g. from the includelet call)
if {[info exists caller_parameters]} {
- #my log "--cc caller_parameters=$caller_parameters"
- array set caller_param $caller_parameters
-
- foreach param [array names caller_param] {
- if {[info exists ($param)]} {
- set passed_args($param) $caller_param($param)
+ #:log "--cc caller_parameters=$caller_parameters"
+
+ foreach param [dict keys $caller_parameters] {
+ set name [string range $param 1 end]
+ if {$name in $declared_parameters} {
+ dict set passed_args $param [dict get $caller_parameters $param]
} elseif {$all_from_caller} {
- set :queryparm([string range $param 1 end]) $caller_param($param)
+ set :queryparm($name) [dict get $caller_parameters $param]
+ lappend declared_parameters $name
}
}
}
- set parse_args [list]
- foreach param [array names passed_args] {
- lappend parse_args $param $passed_args($param)
+ if {[::acs::icanuse "nsf::parseargs -asdict"]} {
+ # OLD {64.347249 microseconds per iteration}
+ # NEW {17.132942 microseconds per iteration}
+ try {
+ foreach {k v} [nsf::parseargs -asdict ${:parameter_declaration} $passed_args] {
+ set :queryparm($k) $v
+ }
+ } on error {errorMsg} {
+ ad_return_complaint 1 [ns_quotehtml $errorMsg]
+ ad_script_abort
+ }
+ } else {
+ #:log "--cc calling parser eval [self] __parse <${:parameter_declaration}> <$passed_args>"
+
+ :proc __parse ${:parameter_declaration} {
+ foreach v [info vars] {
+ :log "--cc uplevel [list set :queryparm($v) [set $v]]"
+ uplevel [list set :queryparm($v) [set $v]]
+ }
+ }
+
+ if {[catch {[self] __parse {*}$passed_args} errorMsg]} {
+ ad_return_complaint 1 [ns_quotehtml $errorMsg]
+ ad_script_abort
+ }
}
-
- #my log "--cc calling parser eval [self] __parse $parse_args"
- if {[catch {[self] __parse {*}$parse_args} errorMsg]} {
- ad_return_complaint 1 [ns_quotehtml $errorMsg]
- ad_script_abort
- }
- #my msg "--cc qp [array get :queryparm] // ${:actual_query}"
+ set :declared_parameters $declared_parameters
+ #:log "--cc qp [array get :queryparm] // ${:actual_query}"
}
Context instproc original_url_and_query args {
@@ -129,44 +140,74 @@
Context instproc query_parameter {name {default ""}} {
if {[info exists :queryparm($name)]} {
return [set :queryparm($name)]
- }
+ }
return $default
}
-
+
Context instproc exists_query_parameter {name} {
- #my log "--qp exists $name => [info exists :queryparm($name)]"
+ #:log "--qp exists $name => [info exists :queryparm($name)]"
info exists :queryparm($name)
}
Context instproc get_all_query_parameter {} {
return [array get :queryparm]
}
- Context ad_instproc export_vars {{-level 1}} {
- Export the query variables
+ Context instproc unset_query_parameter {name} {
+ unset -nocomplain :queryparm($name)
+ }
+
+ Context instproc set_query_parameter {name value} {
+ set :queryparm($name) $value
+ }
+
+ Context ad_instproc export_vars {-all:switch {-level 1}} {
+
+ Export either the declared query variables (default) or all (when
+ explicitly demanded).
+
+ @param all when specified, export all query variables
@param level target level
} {
- foreach p [array names :queryparm] {
- regsub -all : $p _ varName
- uplevel $level [list set $varName [set :queryparm($p)]]
+
+ if {$all} {
+ foreach p [array names :queryparm] {
+ regsub -all : $p _ varName
+ uplevel $level [list set $varName [set :queryparm($p)]]
+ }
+ } else {
+ #
+ # Export only declared parameters (coming from the package
+ # initialization or from the includelet definition).
+ #
+ foreach p [array names :queryparm] {
+ if {$p in ${:declared_parameters}} {
+ #ns_log notice "=== export <$p>"
+ uplevel $level [list set $p [set :queryparm($p)]]
+ }
+ }
}
+ #
+ # Set always variable package_id
+ #
uplevel $level [list set package_id ${:package_id}]
- #::xo::show_stack
}
Context ad_instproc get_parameters {} {
Convenience routine for includelets. It combines the actual
- parameters from the call in the page (highest priority) wit
+ parameters from the call in the page (highest priority) with
the values from the url (second priority) and the default
- values from the signature
+ values from the signature.
} {
- set source [expr {[info exists :__caller_parameters] ?
- [self] : [:info parent]}]
+ set source [expr {[info exists :__caller_parameters]
+ ? [self] : [:info parent]}]
$source instvar __caller_parameters
-
+
+ #set n [expr {[info exists :name] ? ${:name} : "NONE"}]
+ #ns_log notice "$n: GET PARAMETERS source <$source> have [info exists __caller_parameters]"
if {![info exists :__including_page]} {
#
- # An includelet is called from the toplevel. The actual_query
+ # An includelet is called from the top-level. The actual_query
# might be cached, so we reset it here.
#
set :actual_query [::xo::cc actual_query]
@@ -177,7 +218,7 @@
} else {
:process_query_parameter -all_from_query false
}
- :export_vars -level 2
+ :export_vars -level 2
}
@@ -187,47 +228,56 @@
Class create ConnectionContext -superclass Context -parameter {
user_id
- requestor
+ requester
user
url
mobile
}
-
+
ConnectionContext proc require_package_id_from_url {{-package_id 0} url} {
- # get package_id from url in case it is not known
+ #
+ # Get package_id from URL in case it is not known. In case, the
+ # package_id is known, this method is essentially a no-op, but
+ # takes care about ::ad_conn initialization.
+ #
if {$package_id == 0} {
- array set "" [site_node::get_from_url -url $url]
- set package_id $(package_id)
+ set node_info [site_node::get_from_url -url $url]
+ set package_id [dict get $node_info package_id]
}
- if {![info exists ::ad_conn(node_id)]} {
- #
+ if {![info exists ::ad_conn(node_id)] && [info exists node_info]} {
+ #
# The following should not be necessary, but is here for
# cases, where some oacs-code assumes wrongly it is running in a
# connection thread (e.g. the site master requires to have a
# node_id and a URL accessible via ad_conn)
#
- if {![info exists (node_id)]} {
+ if {![dict exists $node_info node_id]} {
if {$url eq ""} {
set url [lindex [site_node::get_url_from_object_id -object_id $package_id] 0]
}
- array set "" [site_node::get_from_url -url $url]
+ set node_info [site_node::get_from_url -url $url]
}
- set ::ad_conn(node_id) $(node_id)
+ set ::ad_conn(node_id) [dict get $node_info node_id]
set ::ad_conn(url) $url
- set ::ad_conn(extra_url) [string range $url [string length $(url)] end]
+ set ::ad_conn(extra_url) [string range $url [string length [dict get $node_info url]] end]
}
return $package_id
}
ConnectionContext proc require {
-url
- {-package_id 0}
+ {-package_id 0}
{-parameter ""}
{-user_id -1}
{-actual_query " "}
{-keep_cc false}
} {
- set exists_cc [:isobject ::xo::cc]
+ #
+ # This is a private method used for low-level connection context
+ # creation. This function has to be called either with a valid
+ # "-url" when being used outside connection threads.
+ #
+ set exists_cc [nsf::is object ::xo::cc]
# if we have a connection context and we want to keep it, do
# nothing and return.
@@ -240,62 +290,100 @@
}
if {![info exists url]} {
- #my log "--CONN ns_conn url"
- set url [ns_conn url]
+ #:log "--CONN ns_conn url"
+ if {[ns_conn isconnected]} {
+ set url [ad_conn url]
+ } else {
+ set url ""
+ ad_log error "fallback to empty url"
+ }
}
set package_id [:require_package_id_from_url -package_id $package_id $url]
- #my log "--i [self args] URL='$url', pkg=$package_id"
+ #:log "--i [self args] URL='$url', pkg=$package_id"
# get locale; TODO at some time, we should get rid of the ad_conn init problem
if {[ns_conn isconnected]} {
- # This can be called, before ad_conn is initialized.
+ # This can be called, before ad_conn is initialized.
# Since it is not possible to pass the user_id and ad_conn barfs
# when it tries to detect it, we try to get it and reset it later
ad_try {
set locale [lang::conn::locale -package_id $package_id]
} on error {errorMsg} {
+ ns_log warning "fall back to locale en_US"
set locale en_US
}
} else {
set locale [lang::system::locale -package_id $package_id]
}
if {!$exists_cc} {
- :create ::xo::cc \
- -package_id $package_id \
- [list -parameter_declaration $parameter] \
- -user_id $user_id \
- -actual_query $actual_query \
- -locale $locale \
- -url $url
- #::xo::show_stack
- #my msg "--cc ::xo::cc created $url [::xo::cc serialize]"
+ try {
+ :create ::xo::cc \
+ -package_id $package_id \
+ -parameter_declaration $parameter \
+ -user_id $user_id \
+ -actual_query $actual_query \
+ -locale $locale \
+ -url $url
+ } on error {errorMsg} {
+ if {[nsf::is object ::xo::cc]} {
+ ::xo::cc destroy
+ }
+ return -code error -errorcode $::errorCode -errorinfo $::errorInfo $errorMsg
+ }
::xo::cc destroy_on_cleanup
+
+ # if {[ns_conn isconnected]} {
+ # ns_log notice "XXX ::xo::cc created [ns_conn id] [ns_conn request]"
+ # ::xo::cc set ID [ns_conn id]
+ # } else {
+ # ns_log notice "XXX ::xo::cc created without connection"
+ # ::xo::cc set ID UNKNOWN
+ # }
+ # ::xo::cc proc destroy {args} {
+ # set ID [expr {[info exists :ID] ? ${:ID} : {-}}]
+ # ns_log notice "::xo::cc destroyed ID $ID"
+ # next
+ # }
+
+ #::xo::show_stack
+ #:msg "--cc ::xo::cc created $url [::xo::cc serialize]"
+
} else {
- #my msg "--cc ::xo::cc reused $url -package_id $package_id"
+ #:msg "--cc ::xo::cc reused $url -package_id $package_id"
::xo::cc configure \
-url $url \
-actual_query $actual_query \
-locale $locale \
- [list -parameter_declaration $parameter]
+ -parameter_declaration $parameter
- ::xo::cc package_id $package_id
+ ::xo::cc package_id $package_id
::xo::cc set_user_id $user_id
::xo::cc process_query_parameter
}
# simple mobile detection
::xo::cc mobile 0
if {[ns_conn isconnected]} {
- set user_agent [string tolower [ns_set get [ns_conn headers] User-Agent]]
+ set user_agent [string tolower [ns_set iget [ns_conn headers] User-Agent]]
::xo::cc mobile [regexp (android|webos|iphone|ipad) $user_agent]
}
if {![info exists ::ad_conn(charset)]} {
- set ::ad_conn(charset) [lang::util::charset_for_locale $locale]
+ set ::ad_conn(charset) [lang::util::charset_for_locale $locale]
set ::ad_conn(language) [::xo::cc lang]
set ::ad_conn(file) ""
}
}
+
+ ConnectionContext instproc requestor {} {
+ #
+ # Helper method to ease migration to the name without the spelling
+ # error.
+ #
+ ad_log_deprecated method "... requestor" "... requester"
+ return [expr {[info exists :requester] ? ${:requester} : ${:requester}}]
+ }
+
ConnectionContext instproc lang {} {
return [string range [:locale] 0 1]
}
@@ -331,13 +419,37 @@
if {[info exists :untrusted_user_id]} {
return ${:untrusted_user_id}
}
- return [:user_id]
+ return ${:user_id}
}
+ ConnectionContext ad_instproc eval_as_user {-user_id:integer cmd} {
+ Run a command as the specified different user. Essentially, this
+ method updates xo::cc and the ad_conn array array with the
+ specified user, runs the command and resets the user to the
+ previous value.
+
+ @param user_id switch temporarily to this user
+ @param cmd command to be exevuted
+
+ } {
+ #ns_log notice "RUN AS USER $user_id $cmd"
+ set result ""
+ set current_user_id [:get_user_id]
+ try {
+ :set_user_id $user_id
+ :uplevel $cmd
+ } on ok {r} {
+ set result $r
+ } finally {
+ :set_user_id $current_user_id
+ }
+ return $result
+ }
+
ConnectionContext instproc returnredirect {-allow_complete_url:switch url} {
- #my log "--rp"
- set :__continuation [expr {$allow_complete_url
- ? [list ad_returnredirect -allow_complete_url $url]
+ #:log "--rp"
+ set :__continuation [expr {$allow_complete_url
+ ? [list ad_returnredirect -allow_complete_url $url]
: [list ad_returnredirect $url]}]
return ""
}
@@ -347,30 +459,33 @@
set pa [expr {[ns_conn isconnected] ? [ad_conn peeraddr] : "nowhere"}]
if {${:user_id} != 0} {
- set :requestor ${:user_id}
+ set :requester ${:user_id}
} else {
- # for requests bypassing the ordinary connection setup (resources in oacs 5.2+)
- # we have to get the user_id by ourselves
+ #
+ # For requests bypassing the ordinary connection setup
+ # (resources in oacs 5.2+) we have to get the user_id by
+ # ourselves.
+ #
ad_try {
set cookie_list [ad_get_signed_cookie_with_expr "ad_session_id"]
set cookie_data [split [lindex $cookie_list 0] {,}]
set untrusted_user_id [lindex $cookie_data 1]
- set :requestor $untrusted_user_id
+ set :requester $untrusted_user_id
} on error {errorMsg } {
- set :requestor 0
+ set :requester 0
}
}
-
- # if user not authorized, use peer address as requestor key
- if {${:requestor} == 0} {
- set :requestor $pa
+
+ # if user not authorized, use peer address as requester key
+ if {${:requester} == 0} {
+ set :requester $pa
set :user "client from $pa"
} else {
- set user_url [acs_community_member_admin_url -user_id ${:requestor}]
- set :user "${:requestor}"
+ set user_url [acs_community_member_admin_url -user_id ${:requester}]
+ set :user "${:requester}"
}
- #my log "--i requestor = ${:requestor}"
-
+ #:log "--i requester = ${:requester}"
+
:process_query_parameter
}
@@ -428,43 +543,43 @@
return 0
}
- ConnectionContext ad_instproc permission {-object_id:required -privilege:required -party_id } {
- call ::permission::permission_p but avoid multiple calls in the same
- session through caching in the connection context
+ ConnectionContext ad_instproc permission {
+ -object_id:integer,required
+ -privilege:required
+ -party_id:integer
} {
+ Call ::permission::permission_p but avoid multiple calls in the same
+ request through caching in the connection context
+ } {
if {![info exists party_id]} {
set party_id ${:user_id}
}
- # :log "-- context permission user_id=$party_id uid=[::xo::cc user_id] untrusted=[::xo::cc set untrusted_user_id]"
+ # :log "-- context permission user_id=$party_id uid=[::xo::cc user_id]" \
+ "untrusted=[::xo::cc set untrusted_user_id]"
if {$party_id == 0} {
- set key :permission($object_id,$privilege,$party_id)
- if {[info exists $key]} {return [set $key]}
set granted [permission::permission_p -no_login -party_id $party_id \
-object_id $object_id \
-privilege $privilege]
- #my msg "--p lookup $key ==> $granted uid=[:user_id] uuid=${:untrusted_user_id}"
+ #:msg "--p lookup $key ==> $granted uid=${:user_id} uuid=${:untrusted_user_id}"
if {$granted || ${:user_id} == ${:untrusted_user_id}} {
- set $key $granted
return $granted
}
# The permission is not granted for the public.
# We force the user to login
- #my log "-- require login"
+ #:log "-- require login"
#auth::require_login
return 0
}
- set key :permission($object_id,$privilege,$party_id)
- if {[info exists $key]} {return [set $key]}
- #my msg "--p lookup $key"
- set $key [permission::permission_p -no_login \
- -party_id $party_id \
- -object_id $object_id \
- -privilege $privilege]
- #my log "-- context return [set :$key]"
+ #:msg "--p lookup $key"
+ return [permission::permission_p -no_login \
+ -party_id $party_id \
+ -object_id $object_id \
+ -privilege $privilege]
+ #:log "-- context return [set :$key]"
#set :$key
}
-
+
# ConnectionContext instproc destroy {} {
# :log "--i destroy [:url]"
# #::xo::show_stack
@@ -491,94 +606,203 @@
}
}
- ConnectionContext instproc form_parameter {name {default ""}} {
+ ConnectionContext instproc require_form_parameter {} {
if {![info exists :form_parameter]} {
:load_form_parameter
}
+ }
+
+ ConnectionContext instproc form_parameter {spec {default ""}} {
+ :require_form_parameter
+
+ set name $spec
+ regexp {^([^:]+):(.*)$} $spec . name constraint
+
if {[info exists :form_parameter($name)]} {
if {[info exists :form_parameter_multiple($name)]} {
- return [set :form_parameter($name)]
+ set value [set :form_parameter($name)]
} else {
- return [lindex [set :form_parameter($name)] 0]
+ set value [lindex [set :form_parameter($name)] 0]
}
+ if {[info exists constraint]} {
+ set r [xo::validate_parameter_constraints $name $constraint $value]
+ if {$r ne $value} {
+ ns_log notice "converting value checker: form parameter validate <$spec> -> '$value' -> '$r'"
+ set value $r
+ }
+ } else {
+ #:msg "FORM_PARAMETER spec <$spec> no constraint -> '$value'"
+ }
+ return $value
} else {
return $default
}
}
ConnectionContext instproc exists_form_parameter {name} {
- if {![info exists :form_parameter]} {
- :load_form_parameter
- }
+ :require_form_parameter
info exists :form_parameter($name)
}
ConnectionContext instproc get_all_form_parameter {} {
+ :require_form_parameter
return [array get :form_parameter]
}
#
# Version of query_parameter respecting set-parameter
#
- ConnectionContext instproc query_parameter {name {default ""}} {
- if {[:exists_parameter $name]} {
- return [:get_parameter $name]
+ ConnectionContext ad_instproc query_parameter {__spec {default ""}} {
+
+ Get query parameter with default and optional value constraints.
+ In case the value check for the query parameter fails, and no
+ further precautions are performed (::aa_test_noabort is set), the
+ method raises an exception with "ad_return_complaint" and aborts
+ the script.
+
+ @param __spec has the formname or name:value_constraint
+ @param default default value
+ @return actual value of the query parameter
+ } {
+ #
+ # Try to split up provided "__spec" argument into name and
+ # value constraint components.
+ #
+ set __name $__spec
+ regexp {^([^:]+):(.*)$} $__spec . __name constraint
+
+ if {[:exists_parameter $__name]} {
+ set value [:get_parameter $__name]
+ } else {
+ set value [next $__name $default]
}
- next
+ #
+ # If we have a value-constraint, we check for empty values only in
+ # cases, where multiplicity is specified. This means effectively
+ # that the default multiplicity is "0..1".
+ #
+ if {[info exists constraint]} {
+ set r [xo::validate_parameter_constraints $__name $constraint $value]
+ if {$r ne $value} {
+ ns_log notice "converting value checker: query parameter <$__spec> -> '$value' -> '$r'"
+ set value $r
+ }
+ }
+ return $value
}
-
ConnectionContext instproc set_parameter {name value} {
set key [list get_parameter $name]
- if {[:cache_exists $key]} {my cache_unset $key}
+ if {[:cache_exists $key]} {:cache_unset $key}
set :perconnectionparam($name) $value
}
+ ConnectionContext instproc unset_parameter {name} {
+ set key [list get_parameter $name]
+ if {[:cache_exists $key]} {:cache_unset $key}
+ unset -nocomplain :perconnectionparam($name)
+ }
ConnectionContext instproc get_parameter {name {default ""}} {
- return [expr {[info exists :perconnectionparam($name)] ? [set :perconnectionparam($name)] : $default}]
+ return [expr {[info exists :perconnectionparam($name)]
+ ? [set :perconnectionparam($name)]
+ : $default}]
}
ConnectionContext instproc exists_parameter {name} {
info exists :perconnectionparam($name)
}
-
+ ConnectionContext instproc perconnection_parameter_get_all {} {
+ array get :perconnectionparam
+ }
+ ConnectionContext instproc perconnection_parameter_set_all {pairs} {
+ array unset :perconnectionparam
+ array set :perconnectionparam $pairs
+ }
}
namespace eval ::xo {
-
- proc ::xo::update_query_variable {old_query var value} {
- #
- # Replace in a URL-query old occurrences of var with new value.
- #
- # @return pairs in a form suitable for export_vars
- #
- set decodeCmd ns_urldecode
- if {$::xo::naviserver} {lappend decodeCmd --}
+ ad_proc -private ::xo::update_query_variable {old_query var value} {
+
+ Replace in a URL-query old occurrences of var with new value.
+
+ @return pairs in a form suitable for export_vars
+ } {
set query [list [list $var $value]]
- foreach pair [split $old_query &] {
- lassign [split $pair =] key value
+ foreach {key value} [ns_set array [ns_parsequery $old_query]] {
if {$key eq $var} continue
- lappend query [list [{*}$decodeCmd $key] [{*}$decodeCmd $value]]
+ lappend query [list $key $value]
}
return $query
- }
+ }
- proc ::xo::update_query {old_query var value} {
- #
- # Replace in a URL-query old occurrences of var with new value.
- #
- # @return encoded HTTP query
- #
- set decodeCmd ns_urldecode
+ ad_proc -private ::xo::update_query {old_query var value} {
+
+ Replace in a URL-query old occurrences of var with new value.
+
+ @return encoded HTTP query
+ } {
set encodeCmd ns_urlencode
- if {$::xo::naviserver} {lappend decodeCmd --; lappend encodeCmd --}
+ if {$::xo::naviserver} {lappend encodeCmd --}
set query [{*}$encodeCmd $var]=[{*}$encodeCmd $value]
- foreach pair [split $old_query &] {
- lassign [split $pair =] key value
- if {[{*}$decodeCmd $key] eq $var} continue
- append query &$pair
+
+ if {$old_query ne ""} {
+ foreach {key value} [ns_set array [ns_parsequery $old_query]] {
+ if {$key eq $var} continue
+ append query &[{*}$encodeCmd $key]=[{*}$encodeCmd $value]
+ }
}
return $query
}
+ ad_proc ::xo::validate_parameter_constraints {name constraint value} {
+
+ Validate the provided value against the constraints. In case of
+ failure, return with ad_return_complaint when there is a
+ connection, otherwise raise an error.
+
+ } {
+ #
+ # If we have a value-constraint, we check for empty values only in
+ # cases, where multiplicity is specified. This means effectively
+ # that the default multiplicity is "0..1".
+ #
+ #ns_log notice "::xo::validate_parameter_constraints $name $constraint input '$value'"
+ if {[string first . $constraint] > -1 || $value ne ""} {
+ try {
+ #
+ # Use parseargs with "-asdict" option when it is available,
+ # since it does not globber the variable namespace. For legacy
+ # applications, lets hope that no query parameter named
+ # "__name" is used with a value constraint.
+ #
+ if {[::acs::icanuse "nsf::parseargs -asdict"]} {
+ #
+ # Newer versions will use this branch
+ #
+ set value [dict get \
+ [nsf::parseargs -asdict ${name}:$constraint [list $value]] \
+ $name]
+ } else {
+ #
+ # This is the legacy branch. nsf::parseargs might clobber
+ # "name", therefore, save it in an highly unlikely variable
+ # name.
+ #
+ set { name } $name
+ nsf::parseargs ${name}:$constraint [list $value]
+ set value [set ${ name }]
+ }
+ } on error {errorMsg} {
+ #ns_log notice ".... nsf::parseargs error '$errorMsg'"
+ if {[ns_conn isconnected] && ![info exists ::aa_test_noabort]} {
+ ad_return_complaint 1 [ns_quotehtml $errorMsg]
+ ad_script_abort
+ } else {
+ throw $::errorInfo $errorMsg
+ }
+ }
+ }
+ #ns_log notice "::xo::validate_parameter_constraints $name $constraint -> '$value'"
+ return $value
+ }
}
::xo::library source_dependent
@@ -588,4 +812,5 @@
# mode: tcl
# tcl-indent-level: 2
# indent-tabs-mode: nil
+# eval: (setq tcl-type-alist (remove* "method" tcl-type-alist :test 'equal :key 'car))
# End: