Index: openacs-4/packages/acs-developer-support/tcl/acs-developer-support-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-developer-support/tcl/acs-developer-support-procs.tcl,v diff -u -N -r1.44 -r1.44.2.1 --- openacs-4/packages/acs-developer-support/tcl/acs-developer-support-procs.tcl 6 Mar 2005 18:51:06 -0000 1.44 +++ openacs-4/packages/acs-developer-support/tcl/acs-developer-support-procs.tcl 20 Jul 2005 19:55:00 -0000 1.44.2.1 @@ -1,482 +1,482 @@ -# $Id$ -# File: developer-support-procs.tcl -# Author: Jon Salz -# Date: 22 Apr 2000 -# Description: Provides routines used to aggregate request/response information for debugging. + # $Id$ + # File: developer-support-procs.tcl + # Author: Jon Salz + # Date: 22 Apr 2000 + # Description: Provides routines used to aggregate request/response information for debugging. -ad_proc -private ds_instance_id {} { + ad_proc -private ds_instance_id {} { - @return The instance of a running acs developer support. + @return The instance of a running acs developer support. -} { - return [util_memoize [list db_string acs_kernel_id_get { - select package_id from apm_packages - where package_key = 'acs-developer-support' - and rownum=1 - } -default 0]] -} + } { + return [util_memoize [list db_string acs_kernel_id_get { + select package_id from apm_packages + where package_key = 'acs-developer-support' + and rownum=1 + } -default 0]] + } -ad_proc -public ds_permission_p {} { - Do we have permission to view developer support stuff. -} { - set party_id [ds_ad_conn user_id] - if {$party_id == 0} { - # set up a fake id in order to make user_switching mode work - # with - # non logged users, if not it will enter into a infinite loop - # with - # ad_conn in any new unknown request (roc) - set party_id "-99" - } - return [permission::permission_p -party_id $party_id -object_id [ds_instance_id] -privilege "admin"] -} + ad_proc -public ds_permission_p {} { + Do we have permission to view developer support stuff. + } { + set party_id [ds_ad_conn user_id] + if {$party_id == 0} { + # set up a fake id in order to make user_switching mode work + # with + # non logged users, if not it will enter into a infinite loop + # with + # ad_conn in any new unknown request (roc) + set party_id "-99" + } + return [permission::permission_p -party_id $party_id -object_id [ds_instance_id] -privilege "admin"] + } -ad_proc -public ds_require_permission { - object_id - privilege -} { - set user_id [ds_ad_conn user_id] - if {![permission::permission_p -party_id $user_id -object_id $object_id -privilege $privilege]} { - if {$user_id == 0} { - auth::require_login - } else { - ns_log Warning "$user_id doesn't have $privilege on object $object_id" - ad_return_forbidden "Permission Denied" "
-

You don't have permission to $privilege [db_string name {select acs_object.name(:object_id) from dual}].

-
" - } - ad_script_abort - } -} + ad_proc -public ds_require_permission { + object_id + privilege + } { + set user_id [ds_ad_conn user_id] + if {![permission::permission_p -party_id $user_id -object_id $object_id -privilege $privilege]} { + if {$user_id == 0} { + auth::require_login + } else { + ns_log Warning "$user_id doesn't have $privilege on object $object_id" + ad_return_forbidden "Permission Denied" "
+

You don't have permission to $privilege [db_string name {select acs_object.name(:object_id) from dual}].

+
" + } + ad_script_abort + } + } -ad_proc -public ds_enabled_p {} { - Returns true if developer-support facilities are enabled. -} { - if { ![nsv_exists ds_properties enabled_p] || ![nsv_get ds_properties enabled_p] } { - return 0 - } - return 1 -} + ad_proc -public ds_enabled_p {} { + Returns true if developer-support facilities are enabled. + } { + if { ![nsv_exists ds_properties enabled_p] || ![nsv_get ds_properties enabled_p] } { + return 0 + } + return 1 + } -ad_proc -public ds_collection_enabled_p {} { - Returns whether we're collecting information about this request -} { - global ad_conn - if { [info exists ad_conn(ds_collection_enabled_p)] } { - return $ad_conn(ds_collection_enabled_p) - } - if { ![info exists ad_conn(request)] } { - return 0 - } - foreach pattern [nsv_get ds_properties enabled_ips] { - if { [string match $pattern [ad_conn peeraddr]] } { - set ad_conn(ds_collection_enabled_p) 1 - return 1 - } - } - set ad_conn(ds_collection_enabled_p) 0 - return 0 -} + ad_proc -public ds_collection_enabled_p {} { + Returns whether we're collecting information about this request + } { + global ad_conn + if { [info exists ad_conn(ds_collection_enabled_p)] } { + return $ad_conn(ds_collection_enabled_p) + } + if { ![info exists ad_conn(request)] } { + return 0 + } + foreach pattern [nsv_get ds_properties enabled_ips] { + if { [string match $pattern [ad_conn peeraddr]] } { + set ad_conn(ds_collection_enabled_p) 1 + return 1 + } + } + set ad_conn(ds_collection_enabled_p) 0 + return 0 + } -ad_proc -public ds_user_switching_enabled_p {} { - Returns whether user-switching is enabled. -} { - return [expr {[nsv_exists ds_properties user_switching_enabled_p] && - [nsv_get ds_properties user_switching_enabled_p]}] -} + ad_proc -public ds_user_switching_enabled_p {} { + Returns whether user-switching is enabled. + } { + return [expr {[nsv_exists ds_properties user_switching_enabled_p] && + [nsv_get ds_properties user_switching_enabled_p]}] + } -ad_proc -public ds_database_enabled_p {} { - Returns true if developer-support database facilities are enabled. -} { - return [nsv_get ds_properties database_enabled_p] -} + ad_proc -public ds_database_enabled_p {} { + Returns true if developer-support database facilities are enabled. + } { + return [nsv_get ds_properties database_enabled_p] + } -ad_proc -public ds_page_fragment_cache_enabled_p {} { o - Are we populating the page fragment cache? -} { - return [nsv_get ds_properties page_fragment_cache_p] -} + ad_proc -public ds_page_fragment_cache_enabled_p {} { o + Are we populating the page fragment cache? + } { + return [nsv_get ds_properties page_fragment_cache_p] + } -ad_proc -public ds_adp_reveal_enabled_p {} { - Returns true if developer-support adp revealing facilities are enabled. -} { - return [nsv_get ds_properties adp_reveal_enabled_p] -} + ad_proc -public ds_adp_reveal_enabled_p {} { + Returns true if developer-support adp revealing facilities are enabled. + } { + return [nsv_get ds_properties adp_reveal_enabled_p] + } -ad_proc -public ds_adp_box_class {} { - if { [ds_adp_reveal_enabled_p] } { - return developer-support-adp-box-on - } else { - return developer-support-adp-box-off - } -} + ad_proc -public ds_adp_box_class {} { + if { [ds_adp_reveal_enabled_p] } { + return developer-support-adp-box-on + } else { + return developer-support-adp-box-off + } + } -ad_proc -public ds_adp_file_class {} { - if { [ds_adp_reveal_enabled_p] } { - return developer-support-adp-file-on - } else { - return developer-support-adp-file-off - } -} + ad_proc -public ds_adp_file_class {} { + if { [ds_adp_reveal_enabled_p] } { + return developer-support-adp-file-on + } else { + return developer-support-adp-file-off + } + } -ad_proc -public ds_adp_output_class {} { - if { [ds_adp_reveal_enabled_p] } { - return developer-support-adp-output-on - } else { - return developer-support-adp-output-off - } -} + ad_proc -public ds_adp_output_class {} { + if { [ds_adp_reveal_enabled_p] } { + return developer-support-adp-output-on + } else { + return developer-support-adp-output-off + } + } -ad_proc -public ds_adp_start_box { - {-stub \$__adp_stub} -} { - template::adp_append_code "if { \[::ds_show_p\] } {" - template::adp_append_code " set __apidoc_path \[string range $stub \[string length \[::acs_root_dir\]\] end\].adp" - template::adp_append_code " set __stub_path \[join \[split $stub /\] \" / \"\]" - template::adp_append_code " append __adp_output \"
\$__stub_path
\"" - template::adp_append_code "}" -} + ad_proc -public ds_adp_start_box { + {-stub \$__adp_stub} + } { + template::adp_append_code "if { \[::ds_show_p\] } {" + template::adp_append_code " set __apidoc_path \[string range $stub \[string length \[::acs_root_dir\]\] end\].adp" + template::adp_append_code " set __stub_path \[join \[split $stub /\] \" / \"\]" + template::adp_append_code " append __adp_output \"
\$__stub_path
\"" + template::adp_append_code "}" + } -ad_proc -public ds_adp_end_box { - {-stub \$__adp_stub} -} { - template::adp_append_code "if { \[::ds_show_p\] } {" - template::adp_append_code " append __adp_output \"
\"" - template::adp_append_code "}" -} + ad_proc -public ds_adp_end_box { + {-stub \$__adp_stub} + } { + template::adp_append_code "if { \[::ds_show_p\] } {" + template::adp_append_code " append __adp_output \"
\"" + template::adp_append_code "}" + } -ad_proc -public ds_lookup_administrator_p { user_id } { } { - return 1 -} + ad_proc -public ds_lookup_administrator_p { user_id } { } { + return 1 + } -ad_proc -private ds_support_url {} { + ad_proc -private ds_support_url {} { - @return A link to the first instance of the developer-support information available in the site node, \ - the empty_string if none are available. -} { - return [apm_package_url_from_key "acs-developer-support"] -} + @return A link to the first instance of the developer-support information available in the site node, \ + the empty_string if none are available. + } { + return [apm_package_url_from_key "acs-developer-support"] + } -ad_proc ds_link {} { - Returns the "Developer Information" link in a right-aligned table, if enabled. -} { + ad_proc ds_link {} { + Returns the "Developer Information" link in a right-aligned table, if enabled. + } { - if { ![ds_enabled_p] && ![ds_user_switching_enabled_p] } { - return "" - } + if { ![ds_enabled_p] && ![ds_user_switching_enabled_p] } { + return "" + } - if { ![ds_permission_p] } { - return "" - } - - set out "
" - if { [ds_enabled_p] && [ds_collection_enabled_p] } { - global ad_conn - - set ds_url [ds_support_url] - if {![empty_string_p $ds_url]} { - append out "Developer Support Home - Request Information
" - } else { - ns_log Error "ACS-Developer-Support: Unable to offer link to Developer Support \ - because it is not mounted anywhere." - } - - if { [nsv_exists ds_request "$ad_conn(request).db"] } { - set total 0 - set counter 0 - foreach { handle command statement_name sql start end errno error } [nsv_get ds_request "$ad_conn(request).db"] { - incr total [expr { $end - $start }] - if { [lsearch { dml exec 1row 0or1row select } [lindex $command 0]] >= 0 } { - incr counter - } - } - if { $counter > 0 } { - append out "$counter database command[ad_decode $counter 1 " taking" "s totalling"] [format "%.f" [expr { $total }]] ms
" - } - } - - if { [nsv_exists ds_request "$ad_conn(request).conn"] } { - array set conn [nsv_get ds_request "$ad_conn(request).conn"] - if { [info exists conn(startclicks)] } { - append out "Page served in [format "%.f" [expr { ([clock clicks -milliseconds] - $conn(startclicks)) }]] ms
\n" - } - } - - if { [ad_parameter -package_id [ds_instance_id] ShowCommentsInlineP acs-developer-support 0] } { - append out "Comments: On | Off
" - if { [nsv_exists ds_request "$ad_conn(request).comment"] } { - foreach comment [nsv_get ds_request "$ad_conn(request).comment"] { - append out "Comment: $comment
\n" - } - } - } else { - append out "Comments: On | Off
" - } - } - - if { [ds_user_switching_enabled_p] } { - append out "[ds_user_select_widget]
" - } - - return $out + if { ![ds_permission_p] } { + return "" + } -} + set out "
" + if { [ds_enabled_p] && [ds_collection_enabled_p] } { + global ad_conn -ad_proc ds_show_p {} { - Should we show developer-support on the current connection. -} { - if { [ds_enabled_p] && [ds_permission_p] } { - return 1 - } - return 0 -} + set ds_url [ds_support_url] + if {![empty_string_p $ds_url]} { + append out "Developer Support Home - Request Information
" + } else { + ns_log Error "ACS-Developer-Support: Unable to offer link to Developer Support \ + because it is not mounted anywhere." + } -ad_proc -public ds_get_page_serve_time_ms {} { - Returns the number of miliseconds passed since this request thread was started. + if { [nsv_exists ds_request "$ad_conn(request).db"] } { + set total 0 + set counter 0 + foreach { handle command statement_name sql start end errno error } [nsv_get ds_request "$ad_conn(request).db"] { + incr total [expr { $end - $start }] + if { [lsearch { dml exec 1row 0or1row select } [lindex $command 0]] >= 0 } { + incr counter + } + } + if { $counter > 0 } { + append out "$counter database command[ad_decode $counter 1 " taking" "s totalling"] [format "%.f" [expr { $total }]] ms
" + } + } - Returns the empty string if this information is not available. -} { - set result {} - if { [ds_enabled_p] && [ds_collection_enabled_p] } { - global ad_conn - if { [nsv_exists ds_request "$ad_conn(request).conn"] } { - array set conn [nsv_get ds_request "$ad_conn(request).conn"] - if { [info exists conn(startclicks)] } { - set result [format "%.f" [expr { ([clock clicks -milliseconds] - $conn(startclicks)) }]] - } - } - } - return $result -} + if { [nsv_exists ds_request "$ad_conn(request).conn"] } { + array set conn [nsv_get ds_request "$ad_conn(request).conn"] + if { [info exists conn(startclicks)] } { + append out "Page served in [format "%.f" [expr { ([clock clicks -milliseconds] - $conn(startclicks)) }]] ms
\n" + } + } -ad_proc -public ds_get_db_command_info {} { - Get a Tcl list with { num_commands total_ms } for the database commands for the request. - - Returns the empty string if the information is not available. -} { - set result {} - if { [ds_enabled_p] && [ds_collection_enabled_p] } { - global ad_conn - if { [nsv_exists ds_request "$ad_conn(request).db"] } { - set total 0 - set counter 0 - foreach { handle command statement_name sql start end errno error } [nsv_get ds_request "$ad_conn(request).db"] { - incr total [expr { $end - $start }] - if { [lsearch { dml exec 1row 0or1row select } [lindex $command 0]] >= 0 } { - incr counter - } - } - set result [list $counter $total] - } - } - return $result -} + if { [ad_parameter -package_id [ds_instance_id] ShowCommentsInlineP acs-developer-support 0] } { + append out "Comments: On | Off
" + if { [nsv_exists ds_request "$ad_conn(request).comment"] } { + foreach comment [nsv_get ds_request "$ad_conn(request).comment"] { + append out "Comment: $comment
\n" + } + } + } else { + append out "Comments: On | Off
" + } + } -ad_proc -private ds_collect_connection_info {} { - Collects information about the current connection. - Should be called only at the very beginning of the request processor handler. -} { - # JCD: check recursion_count to ensure adding headers only one time. - if { [ds_enabled_p] && [ds_collection_enabled_p] && ![ad_conn recursion_count]} { - ##This is expensive, but easy. Otherwise we need to do it in every interpreter - ds_replace_get_user_procs [ds_user_switching_enabled_p] + if { [ds_user_switching_enabled_p] } { + append out "[ds_user_select_widget]
" + } - ds_add start [ns_time] - ds_add conn startclicks [ad_conn start_clicks] - for { set i 0 } { $i < [ns_set size [ad_conn headers]] } { incr i } { - ds_add headers [ns_set key [ad_conn headers] $i] [ns_set value [ad_conn headers] $i] - } - foreach param { method url query request peeraddr } { - ds_add conn $param [ad_conn $param] - } - } -} + return $out -ad_proc -private ds_collect_db_call { db command statement_name sql start_time errno error } { - if { [ds_enabled_p] && [ds_collection_enabled_p] && [ds_database_enabled_p] } { - set bound_sql $sql + } - # It is very useful to be able to see the bind variable values displayed in the - # ds output. For postgresql we have a way of doing this with the proc db_bind_var_substitution - # but this proc does not work for Oracle + ad_proc ds_show_p {} { + Should we show developer-support on the current connection. + } { + if { [ds_enabled_p] && [ds_permission_p] } { + return 1 + } + return 0 + } - # JCD: don't bind if there was an error since this can potentially mess up the traceback - # making bugs much harder to track down - if { ($errno == 0 || $errno == 2) && [string equal [db_type] "postgresql"] } { - upvar bind bind - set errno [catch { - if { [info exists bind] && [llength $bind] != 0 } { - if { [llength $bind] == 1 } { - set bind_vars [list] - set len [ns_set size $bind] - for {set i 0} {$i < $len} {incr i} { - lappend bind_vars [ns_set key $bind $i] \ - [ns_set value $bind $i] - } - set bound_sql [db_bind_var_substitution $sql $bind_vars] - } else { - set bound_sql [db_bind_var_substitution $sql $bind] - } - } else { - set bound_sql [uplevel 4 [list db_bind_var_substitution $sql]] - } - } error] - if { $errno } { - ns_log Warning "ds_collect_db_call: $error\nStatement: $statement_name\nSQL: $sql" - set bound_sql $sql - } - } - - ds_add db $db $command $statement_name $bound_sql $start_time [clock clicks -milliseconds] $errno $error - } -} + ad_proc -public ds_get_page_serve_time_ms {} { + Returns the number of miliseconds passed since this request thread was started. -ad_proc -private ds_add { name args } { - Sets a developer-support property for the current request. - Should never be used except by elements of the request processor (e.g., security filters or abstract URLs). -} { - - if { [ds_enabled_p] && [ds_collection_enabled_p] } { - if { [catch { nsv_exists ds_request . }] } { - ns_log "Warning" "ds_request NSVs not initialized" - return - } + Returns the empty string if this information is not available. + } { + set result {} + if { [ds_enabled_p] && [ds_collection_enabled_p] } { + global ad_conn + if { [nsv_exists ds_request "$ad_conn(request).conn"] } { + array set conn [nsv_get ds_request "$ad_conn(request).conn"] + if { [info exists conn(startclicks)] } { + set result [format "%.f" [expr { ([clock clicks -milliseconds] - $conn(startclicks)) }]] + } + } + } + return $result + } - global ad_conn - if { ![info exists ad_conn(request)] } { - set ad_conn(request) [nsv_incr rp_properties request_count] - } - eval [concat [list nsv_lappend ds_request "$ad_conn(request).$name"] $args] - } -} + ad_proc -public ds_get_db_command_info {} { + Get a Tcl list with { num_commands total_ms } for the database commands for the request. -ad_proc -public ds_comment { value } { Adds a comment to the developer-support information for the current request. } { + Returns the empty string if the information is not available. + } { + set result {} + if { [ds_enabled_p] && [ds_collection_enabled_p] } { + global ad_conn + if { [nsv_exists ds_request "$ad_conn(request).db"] } { + set total 0 + set counter 0 + foreach { handle command statement_name sql start end errno error } [nsv_get ds_request "$ad_conn(request).db"] { + incr total [expr { $end - $start }] + if { [lsearch { dml exec 1row 0or1row select } [lindex $command 0]] >= 0 } { + incr counter + } + } + set result [list $counter $total] + } + } + return $result + } - if { [ds_enabled_p] } { - ds_add comment $value + ad_proc -private ds_collect_connection_info {} { + Collects information about the current connection. + Should be called only at the very beginning of the request processor handler. + } { + # JCD: check recursion_count to ensure adding headers only one time. + if { [ds_enabled_p] && [ds_collection_enabled_p] && ![ad_conn recursion_count]} { + ##This is expensive, but easy. Otherwise we need to do it in every interpreter + ds_replace_get_user_procs [ds_user_switching_enabled_p] + + ds_add start [ns_time] + ds_add conn startclicks [ad_conn start_clicks] + for { set i 0 } { $i < [ns_set size [ad_conn headers]] } { incr i } { + ds_add headers [ns_set key [ad_conn headers] $i] [ns_set value [ad_conn headers] $i] + } + foreach param { method url query request peeraddr } { + ds_add conn $param [ad_conn $param] + } } -} + } -ad_proc -private ds_sweep_data {} { - set now [ns_time] - set lifetime [ad_parameter -package_id [ds_instance_id] DataLifetime acs-developer-support 900] + ad_proc -private ds_collect_db_call { db command statement_name sql start_time errno error } { + if { [ds_enabled_p] && [ds_collection_enabled_p] && [ds_database_enabled_p] } { + set bound_sql $sql - # Find the last request before the DataLifetime cutoff + # It is very useful to be able to see the bind variable values displayed in the + # ds output. For postgresql we have a way of doing this with the proc db_bind_var_substitution + # but this proc does not work for Oracle - set names [nsv_array names ds_request] - set max_request 0 - foreach name $names { - if { [regexp {^([0-9]+)\.start$} $name match request] - && $now - [lindex [nsv_get ds_request $name] 0] > $lifetime } { - if {[expr {$request > $max_request}]} { - set max_request $request - } - } - } + # JCD: don't bind if there was an error since this can potentially mess up the traceback + # making bugs much harder to track down + if { ($errno == 0 || $errno == 2) && [string equal [db_type] "postgresql"] } { + upvar bind bind + set errno [catch { + if { [info exists bind] && [llength $bind] != 0 } { + if { [llength $bind] == 1 } { + set bind_vars [list] + set len [ns_set size $bind] + for {set i 0} {$i < $len} {incr i} { + lappend bind_vars [ns_set key $bind $i] \ + [ns_set value $bind $i] + } + set bound_sql [db_bind_var_substitution $sql $bind_vars] + } else { + set bound_sql [db_bind_var_substitution $sql $bind] + } + } else { + set bound_sql [uplevel 4 [list db_bind_var_substitution $sql]] + } + } error] + if { $errno } { + ns_log Warning "ds_collect_db_call: $error\nStatement: $statement_name\nSQL: $sql" + set bound_sql $sql + } + } - # kill any request older than last request. + ds_add db $db $command $statement_name $bound_sql $start_time [clock clicks -milliseconds] $errno $error + } + } - set kill_count 0 - foreach name $names { - if { [regexp {^([0-9]+)\.} $name "" request] - && [expr {$request <= $max_request}] } { - incr kill_count - nsv_unset ds_request $name - } - } - - ns_log "Debug" "Swept developer support information for [array size kill_requests] requests ($kill_count nsv elements)" -} + ad_proc -private ds_add { name args } { + Sets a developer-support property for the current request. + Should never be used except by elements of the request processor (e.g., security filters or abstract URLs). + } { -ad_proc -private ds_trace_filter { conn args why } { Adds developer-support information about the end of sessions.} { - if { [ds_enabled_p] && [ds_collection_enabled_p] } { - ds_add conn end [ns_time] endclicks [clock clicks -milliseconds] + if { [ds_enabled_p] && [ds_collection_enabled_p] } { + if { [catch { nsv_exists ds_request . }] } { + ns_log "Warning" "ds_request NSVs not initialized" + return + } - for { set i 0 } { $i < [ns_set size [ad_conn outputheaders]] } { incr i } { - ds_add oheaders [ns_set key [ad_conn outputheaders] $i] [ns_set value [ad_conn outputheaders] $i] - } + global ad_conn + if { ![info exists ad_conn(request)] } { + set ad_conn(request) [nsv_incr rp_properties request_count] + } + eval [concat [list nsv_lappend ds_request "$ad_conn(request).$name"] $args] + } + } - foreach param { browser_id validated session_id user_id } { - global ad_sec_$param - if { [info exists ad_sec_$param] } { - ds_add conn $param [set "ad_sec_$param"] - } - } - } + ad_proc -public ds_comment { value } { Adds a comment to the developer-support information for the current request. } { - return "filter_ok" -} + if { [ds_enabled_p] } { + ds_add comment $value + } + } -ad_proc -public ds_user_select_widget {} { - set user_id [ad_get_user_id] - set real_user_id [ds_get_real_user_id] + ad_proc -private ds_sweep_data {} { + set now [ns_time] + set lifetime [ad_parameter -package_id [ds_instance_id] DataLifetime acs-developer-support 900] - set return_url [ad_conn url] - if { ![empty_string_p [ad_conn query]] } { - append return_url "?[ad_conn query]" - } + # Find the last request before the DataLifetime cutoff - set you_are {} + set names [nsv_array names ds_request] + set max_request 0 + foreach name $names { + if { [regexp {^([0-9]+)\.start$} $name match request] + && $now - [lindex [nsv_get ds_request $name] 0] > $lifetime } { + if {[expr {$request > $max_request}]} { + set max_request $request + } + } + } - if { $user_id == 0 } { - set selected " selected" - set you_are "You are currently not logged in
" - set you_are_really "You are really not logged in
" - } else { - set selected {} - } - set options "" + # kill any request older than last request. - db_foreach users { - select u.user_id as user_id_from_db, - acs_object.name(user_id) as name, - p.email - from users u, - parties p - where u.user_id = p.party_id - order by name - } { - if { $user_id == $user_id_from_db } { - set selected " selected" - set you_are "You are testing as $name ($email)
" - } else { - set selected {} - } - if { $real_user_id == $user_id_from_db } { - set you_are_really "You are really $name ($email)
" - } - append options "" - } + set kill_count 0 + foreach name $names { + if { [regexp {^([0-9]+)\.} $name "" request] + && [expr {$request <= $max_request}] } { + incr kill_count + nsv_unset ds_request $name + } + } - set ds_url [ds_support_url] - if {![empty_string_p $ds_url]} { - return "
- $you_are - $you_are_really - Change user: [export_form_vars return_url]
" - } else { - ns_log Error "ACS-Developer-Support: Unable to offer link to Developer Support \ - because it is not mounted anywhere." - return "" - } -} + ns_log "Debug" "Swept developer support information for [array size kill_requests] requests ($kill_count nsv elements)" + } -ad_proc -private ds_get_real_user_id {} { - Get the "real" user id. -} { - return [ds_ad_conn user_id] -} + ad_proc -private ds_trace_filter { conn args why } { Adds developer-support information about the end of sessions.} { + if { [ds_enabled_p] && [ds_collection_enabled_p] } { + ds_add conn end [ns_time] endclicks [clock clicks -milliseconds] -ad_proc -private ds_ad_conn { args } { - Get the "real" user id. -} { - if { [llength [info proc orig_ad_conn]] == 1 } { - return [eval orig_ad_conn $args] - } else { - return [eval ad_conn $args] + for { set i 0 } { $i < [ns_set size [ad_conn outputheaders]] } { incr i } { + ds_add oheaders [ns_set key [ad_conn outputheaders] $i] [ns_set value [ad_conn outputheaders] $i] + } + + foreach param { browser_id validated session_id user_id } { + global ad_sec_$param + if { [info exists ad_sec_$param] } { + ds_add conn $param [set "ad_sec_$param"] + } + } + } + + return "filter_ok" + } + + ad_proc -public ds_user_select_widget {} { + set user_id [ad_get_user_id] + set real_user_id [ds_get_real_user_id] + + set return_url [ad_conn url] + if { ![empty_string_p [ad_conn query]] } { + append return_url "?[ad_conn query]" + } + + set you_are {} + + if { $user_id == 0 } { + set selected " selected" + set you_are "You are currently not logged in
" + set you_are_really "You are really not logged in
" + } else { + set selected {} + } + set options "" + + db_foreach users { + select u.user_id as user_id_from_db, + acs_object.name(user_id) as name, + p.email + from users u, + parties p + where u.user_id = p.party_id + order by name + } { + if { $user_id == $user_id_from_db } { + set selected " selected" + set you_are "You are testing as $name ($email)
" + } else { + set selected {} + } + if { $real_user_id == $user_id_from_db } { + set you_are_really "You are really $name ($email)
" + } + append options "" + } + + set ds_url [ds_support_url] + if {![empty_string_p $ds_url]} { + return "
+ $you_are + $you_are_really + Change user: [export_form_vars return_url]
" + } else { + ns_log Error "ACS-Developer-Support: Unable to offer link to Developer Support \ + because it is not mounted anywhere." + return "" + } + } + + ad_proc -private ds_get_real_user_id {} { + Get the "real" user id. + } { + return [ds_ad_conn user_id] + } + + ad_proc -private ds_ad_conn { args } { + Get the "real" user id. + } { + if { [llength [info proc orig_ad_conn]] == 1 } { + return [eval orig_ad_conn $args] + } else { + return [eval ad_conn $args] } } @@ -502,7 +502,7 @@ return [ds_get_user_id] } } - return [eval "orig_ad_conn [join $args]"] + return [eval orig_ad_conn $args] } ad_proc -public ds_set_user_switching_enabled { enabled_p } { @@ -551,7 +551,7 @@ rename ad_verify_and_get_user_id orig_ad_verify_and_get_user_id proc ad_conn { args } { - eval "ds_conn [join $args]" + eval ds_conn $args } proc ad_get_user_id {} { ds_get_user_id