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 -N -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 -N
--- /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 -N
--- /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"}
+ }
+ }
+}
+
+
+
+
+