Index: openacs-4/packages/acs-tcl/acs-tcl.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/acs-tcl.info,v diff -u -r1.69 -r1.70 --- openacs-4/packages/acs-tcl/acs-tcl.info 27 Oct 2014 16:40:03 -0000 1.69 +++ openacs-4/packages/acs-tcl/acs-tcl.info 13 Jun 2015 20:24:08 -0000 1.70 @@ -6,16 +6,17 @@ Tcl Libraries t t + f + t OpenACS The Kernel Tcl API library. 2013-09-08 - 3 - GPL version 2 OpenACS Contains all the core Tcl API, including the request processor, security and session management, permissions, site-nodes, package management infrastructure, etc. GPL version 2 + 3 @@ -24,11 +25,18 @@ - - - - - + + + + + + + + Index: openacs-4/packages/acs-tcl/tcl/tcltrace-init.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/tcltrace-init.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/acs-tcl/tcl/tcltrace-init.tcl 13 Jun 2015 20:24:09 -0000 1.1 @@ -0,0 +1,26 @@ +# +# Add Tcl traces for asserted tcl commands. +# +# Add the traces only, when the functions are active (i.e. the +# controling package parameter has not the default value), because +# adding the traces has performance impact on potentially frequently +# called tcl commands (such as e.g. ns_log) +# +# Therefore, activating/deactivating requires a server restart. +# +set trace "" +foreach {parameter default cmd} { + TclTraceLogServerities "" {trace add execution ::ns_log enter {::tcltrace::before-ns_log}} + TclTraceSaveNsReturn 0 {trace add execution ::ns_return enter {::tcltrace::before-ns_return}} +} { + if {[::parameter::get_from_package_key \ + -package_key acs-tcl \ + -parameter $parameter \ + -default $default] ne $default} { + append trace \n$cmd + } +} +if {$trace ne ""} { + ns_ictl trace create $trace +} + Index: openacs-4/packages/acs-tcl/tcl/tcltrace-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/tcltrace-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/acs-tcl/tcl/tcltrace-procs.tcl 13 Jun 2015 20:24:08 -0000 1.1 @@ -0,0 +1,71 @@ +ad_library { + + Tcl trace procs, accompanied by tcltrace-init.tcl + + Add Tcl execution traces to asserted Tcl commands + + @author Gustaf Neumann (neumann@wu-wien.ac.at) + @creation-date 2015-06-11 + @cvs-id $Id: tcltrace-procs.tcl,v 1.1 2015/06/13 20:24:08 gustafn Exp $ +} + + +namespace eval ::tcltrace { + + ad_proc -private before-ns_return { cmd op } { + Execute this proc before ns_return is called + + @param cmd the full command as executed by Tcl + @param op the trace operation + } { + lassign $cmd cmdname statuscode mimetype content + + if {[::parameter::get_from_package_key \ + -package_key acs-tcl \ + -parameter TclTraceSaveNsReturn \ + -default 0]} { + if {$statuscode == 200 + && $mimetype eq "text/html"} { + set name [ns_conn url] + regsub {/$} $name /index name + set fullname [ad_tmpdir]/ns_saved$name.html + ns_log notice "before-ns_return: save content of ns_return to file:$fullname" + set dirname [file dirname $fullname] + if {![file isdirectory $dirname]} { + file mkdir $dirname + } + set f [open $fullname w] + puts $f $content + close $f + } else { + ns_log notice "before-ns_return: ignore statuscode $statuscode mime-type $mimetype" + } + } + } + + ad_proc -private before-ns_log { cmd op } { + Execute this proc before ns_log is called + + @param cmd the full command as executed by Tcl + @param op the trace operation + } { + lassign $cmd cmdname severity msg + set severity [string totitle $severity] + if {![info exists ::__log_severities]} { + set ::__log_severities [::parameter::get_from_package_key \ + -package_key acs-tcl \ + -parameter TclTraceLogServerities \ + -default ""] + } + if {$severity in $::__log_severities} { + catch {ds_comment "$cmdname $severity $msg"} + } else { + #catch {ds_comment "ignore $severity $msg"} + } + } +} + + + + +