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 -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 <jsalz@mit.edu>
-# Date: 22 Apr 2000
-# Description: Provides routines used to aggregate request/response information for debugging.
+ # $Id$
+ # File: developer-support-procs.tcl
+ # Author: Jon Salz <jsalz@mit.edu>
+ # 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" "<blockquote>
- <p>You don't have permission to $privilege [db_string name {select acs_object.name(:object_id) from dual}].</p>
- </blockquote>"
- }
- 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" "<blockquote>
+ <p>You don't have permission to $privilege [db_string name {select acs_object.name(:object_id) from dual}].</p>
+ </blockquote>"
+ }
+ 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 \"<div class=\\\"\[::ds_adp_box_class\]\\\"><span class=\\\"\[::ds_adp_file_class\]\\\"><a href=\\\"/api-doc/content-page-view?source_p=1&path=\$__apidoc_path\\\" style=\\\"text-decoration: none;\\\">\$__stub_path</a></span><div class=\\\"\[::ds_adp_output_class\]\\\">\""
- 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 \"<div class=\\\"\[::ds_adp_box_class\]\\\"><span class=\\\"\[::ds_adp_file_class\]\\\"><a href=\\\"/api-doc/content-page-view?source_p=1&path=\$__apidoc_path\\\" style=\\\"text-decoration: none;\\\">\$__stub_path</a></span><div class=\\\"\[::ds_adp_output_class\]\\\">\""
+ 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 \"</div></div><!-- END\n$stub (lvl \[info level\])-->\""
- 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 \"</div></div><!-- END\n$stub (lvl \[info level\])-->\""
+ 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 "<div class=\"developer-support\">"
- 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 "<a href=\"${ds_url}\">Developer Support Home</a> - <a href=\"${ds_url}request-info?request=$ad_conn(request)\">Request Information</a><br />"
- } 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<br />"
- }
- }
-
- 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<br />\n"
- }
- }
-
- if { [ad_parameter -package_id [ds_instance_id] ShowCommentsInlineP acs-developer-support 0] } {
- append out "Comments: <b>On</b> | <a href=\"[export_vars -base "${ds_url}comments-toggle" { { return_url [ad_return_url] } }]\">Off</a><br />"
- if { [nsv_exists ds_request "$ad_conn(request).comment"] } {
- foreach comment [nsv_get ds_request "$ad_conn(request).comment"] {
- append out "<b>Comment:</b> $comment<br />\n"
- }
- }
- } else {
- append out "Comments: <a href=\"[export_vars -base "${ds_url}comments-toggle" { { return_url [ad_return_url] } }]\">On</a> | <b>Off</b><br />"
- }
- }
-
- if { [ds_user_switching_enabled_p] } {
- append out "[ds_user_select_widget]<br />"
- }
-
- return $out
+ if { ![ds_permission_p] } {
+ return ""
+ }
-}
+ set out "<div class=\"developer-support\">"
+ 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 "<a href=\"${ds_url}\">Developer Support Home</a> - <a href=\"${ds_url}request-info?request=$ad_conn(request)\">Request Information</a><br />"
+ } 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<br />"
+ }
+ }
- 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<br />\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: <b>On</b> | <a href=\"[export_vars -base "${ds_url}comments-toggle" { { return_url [ad_return_url] } }]\">Off</a><br />"
+ if { [nsv_exists ds_request "$ad_conn(request).comment"] } {
+ foreach comment [nsv_get ds_request "$ad_conn(request).comment"] {
+ append out "<b>Comment:</b> $comment<br />\n"
+ }
+ }
+ } else {
+ append out "Comments: <a href=\"[export_vars -base "${ds_url}comments-toggle" { { return_url [ad_return_url] } }]\">On</a> | <b>Off</b><br />"
+ }
+ }
-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]<br />"
+ }
- 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 "<small>You are currently <strong>not logged in</strong></small><br />"
- set you_are_really "<small>You are really <strong>not logged in</strong></small><br />"
- } else {
- set selected {}
- }
- set options "<option value=\"0\"$selected>--Logged out--</option>"
+ # 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 "<small>You are testing as <strong>$name ($email)</strong></small><br />"
- } else {
- set selected {}
- }
- if { $real_user_id == $user_id_from_db } {
- set you_are_really "<small>You are really <strong>$name ($email)</strong></small><br />"
- }
- append options "<option value=\"$user_id_from_db\"$selected>$name ($email)</option>"
- }
+ 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 "<form action=\"${ds_url}/set-user\" method=\"get\">
- $you_are
- $you_are_really
- Change user: <select name=\"user_id\">
- $options
- </select>[export_form_vars return_url]<input type=submit value=\"Go\" /></form>"
- } 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 "<small>You are currently <strong>not logged in</strong></small><br />"
+ set you_are_really "<small>You are really <strong>not logged in</strong></small><br />"
+ } else {
+ set selected {}
+ }
+ set options "<option value=\"0\"$selected>--Logged out--</option>"
+
+ 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 "<small>You are testing as <strong>$name ($email)</strong></small><br />"
+ } else {
+ set selected {}
+ }
+ if { $real_user_id == $user_id_from_db } {
+ set you_are_really "<small>You are really <strong>$name ($email)</strong></small><br />"
+ }
+ append options "<option value=\"$user_id_from_db\"$selected>$name ($email)</option>"
+ }
+
+ set ds_url [ds_support_url]
+ if {![empty_string_p $ds_url]} {
+ return "<form action=\"${ds_url}/set-user\" method=\"get\">
+ $you_are
+ $you_are_really
+ Change user: <select name=\"user_id\">
+ $options
+ </select>[export_form_vars return_url]<input type=submit value=\"Go\" /></form>"
+ } 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