Attachment "logger-trace.patch" to
ticket [1530725fff]
added by
muonics
2006-07-29 09:02:10.
Index: logger.man
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/log/logger.man,v
retrieving revision 1.17
diff -u -p -r1.17 logger.man
--- logger.man 28 Apr 2006 06:07:20 -0000 1.17
+++ logger.man 23 Jun 2006 22:16:49 -0000
@@ -176,6 +176,37 @@ to a database, or anything else. For ex
${log}::logproc notice logtoserver
}]
+Trace logs are slightly different: instead of a plain text argument,
+the argument provided to the logproc is a dictionary consisting of the
+[const enter] or [const leave] keyword along with another dictionary of
+details about the trace. These include:
+
+[list_begin bullet]
+
+[bullet] [const proc] - Name of the procedure being traced.
+
+[bullet] [const level] - The stack level for the procedure invocation
+(from [cmd info] [cmd level]).
+
+[bullet] [const script] - The name of the file in which the procedure is
+defined, or an empty string if defined in interactive mode.
+
+[bullet] [const caller] - The name of the procedure calling the procedure
+being traced, or an empty string if the procedure was called from the
+global scope (stack level 0).
+
+[bullet] [const procargs] - A dictionary consisting of the names of arguments
+to the procedure paired with values given for those arguments ([const enter]
+traces only).
+
+[bullet] [const status] - The Tcl return code (e.g. [const ok],
+[const continue], etc.) ([const leave] traces only).
+
+[bullet] [const result] - The value returned by the procedure ([const leave]
+traces only).
+
+[list_end]
+
[call [cmd \${log}::services]]
Returns a list of the registered logging services which are children of this service.
@@ -204,6 +235,97 @@ For example:
This command deletes a particular logging service, and its children.
You must call this to clean up the resources used by a service.
+[call [cmd \${log}::trace] [arg command]]
+
+This command controls logging of enter/leave traces for specified procedures.
+It is used to enable and disable tracing, query tracing status, and
+specify procedures are to be traced. Trace handlers are unregistered when
+tracing is disabled. As a result, there is not performance impact to a
+library when tracing is disabled, just as with other log level commands.
+
+[example {
+ proc tracecmd { dict } {
+ puts $dict
+ }
+
+ set log [::logger::init example]
+ ${log}::logproc trace tracecmd
+
+ proc foo { args } {
+ puts "In foo"
+ bar 1
+ return "foo_result"
+ }
+
+ proc bar { x } {
+ puts "In bar"
+ return "bar_result"
+ }
+
+ ${log}::trace add foo bar
+ ${log}::trace on
+
+ foo
+
+# Output:
+enter {proc ::foo level 1 script {} caller {} procargs {args {}}}
+In foo
+enter {proc ::bar level 2 script {} caller ::foo procargs {x 1}}
+In bar
+leave {proc ::bar level 2 script {} caller ::foo status ok result bar_result}
+leave {proc ::foo level 1 script {} caller {} status ok result foo_result}
+}]
+
+[call [cmd \${log}::trace] [cmd on]]
+
+Turns on trace logging for procedures registered through the [cmd trace]
+[cmd add] command. This is similar to the [cmd enable] command for other
+logging levels, but allows trace logging to take place at any level.
+
+The trace logging mechanism takes advantage of the execution trace feature
+of Tcl 8.4 and later. The [cmd trace] [cmd on] command will return an
+error if called from earlier versions of Tcl.
+
+[call [cmd \${log}::trace] [cmd off]]
+
+Turns off trace logging for procedures registered for trace logging
+through the [cmd trace] [cmd add] command. This is similar to the
+[cmd disable] command for other logging levels, but allows trace logging
+to take place at any level.
+
+Procedures are not unregistered, so logging for them can be turned back
+on with the [cmd trace] [cmd on] command. There is no overhead imposed
+by trace registration when trace logging is disabled.
+
+[call [cmd \${log}::trace] [cmd status] [opt procName] [opt ...]]
+
+This command returns a list of the procedures currently registered for
+trace logging, or a flag indicating whether or not a trace is registered
+for one or more specified procedures.
+
+[call [cmd \${log}::trace] [cmd add] [arg procName] [opt ...]]
+[call [cmd \${log}::trace] [cmd add] [opt -ns] [arg nsName] [opt ...]]
+
+This command registers one or more procedures for logging of entry/exit
+traces. Procedures can be specified via a list of procedure names or
+namespace names (in which case all procedure within the namespace
+are targeted by the operation). By default, each name is first
+interpreted as a procedure name or glob-style search pattern, and if
+not found its interpreted as a namespace name. The [arg -ns] option can
+be used to force interpretation of all provided arguments as namespace names.
+
+Procedures must be defined prior to registering them for tracing
+through the [cmd trace] [cmd add] command. Any procedure or namespace
+names/patterns that don't match any existing procedures will be
+silently ignored.
+
+[call [cmd \${log}::trace] [cmd remove] [arg procName] [opt ...]]
+[call [cmd \${log}::trace] [cmd remove] [opt -ns] [arg nsName] [opt ...]]
+
+This command unregisters one or more procedures so that they will no
+longer have trace logging performed, with the same matching rules as
+that of the [cmd trace] [cmd add] command.
+
[list_end]
[section IMPLEMENTATION]
Index: logger.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/log/logger.tcl,v
retrieving revision 1.28
diff -u -p -r1.28 logger.tcl
--- logger.tcl 28 Apr 2006 06:07:20 -0000 1.28
+++ logger.tcl 23 Jun 2006 22:16:49 -0000
@@ -28,6 +28,9 @@ namespace eval ::logger {
# The default global log level used for new logging services
variable enabled "debug"
+
+ # Tcl return codes (in numeric order)
+ variable RETURN_CODES [list "ok" "error" "return" "break" "continue"]
}
# ::logger::_nsExists --
@@ -127,6 +130,13 @@ proc ::logger::init {service} {
# The currently configured levelcommands
variable lvlcmds
array set lvlcmds {}
+
+ # List of procedures registered via the trace command
+ variable traceList ""
+
+ # Flag indicating whether or not tracing is currently enabled
+ variable tracingEnabled 0
+
# We use this to disable a service completely. In Tcl 8.4
# or greater, by using this, disabled log calls are a
# no-op!
@@ -375,7 +385,7 @@ proc ::logger::init {service} {
variable lvlcmds
set lvnum [lsearch -exact $levels $lv]
- if { $lvnum == -1 } {
+ if { ($lvnum == -1) && ($lv != "trace") } {
return -code error "Invalid level '$lv' - levels are $levels"
}
switch -exact -- [llength $args] {
@@ -505,6 +515,60 @@ proc ::logger::init {service} {
return
}
+ proc trace { action args } {
+ variable service
+
+ # Allow other boolean values (true, false, yes, no, 0, 1) to be used
+ # as synonymns for "on" and "off".
+
+ if {[string is boolean $action]} {
+ set xaction [expr {($action && 1) ? "on" : "off"}]
+ } else {
+ set xaction $action
+ }
+
+ # Check for required arguments for actions/subcommands and dispatch
+ # to the appropriate procedure.
+
+ switch -- $xaction {
+ "status" {
+ return [uplevel 1 [list logger::_trace_status $service $args]]
+ }
+ "on" {
+ if {[llength $args]} {
+ return -code error "wrong # args: should be \"trace on\""
+ }
+ return [logger::_trace_on $service]
+ }
+ "off" {
+ if {[llength $args]} {
+ return -code error "wrong # args: should be \"trace off\""
+ }
+ return [logger::_trace_off $service]
+ }
+ "add" {
+ if {![llength $args]} {
+ return -code error \
+ "wrong # args: should be \"trace add ?-ns? <proc> ...\""
+ }
+ return [uplevel 1 [list ::logger::_trace_add $service $args]]
+ }
+ "remove" {
+ if {![llength $args]} {
+ return -code error \
+ "wrong # args: should be \"trace remove ?-ns? <proc> ...\""
+ }
+ return [uplevel 1 [list ::logger::_trace_remove $service $args]]
+ }
+
+ default {
+ return -code error \
+ "Invalid action \"$action\": must be status, add, remove,\
+ on, or off"
+ }
+ }
+ }
+
# Walk the parent service namespaces to see first, if they
# exist, and if any are enabled, and then, as a
# consequence, enable this one
@@ -545,7 +609,7 @@ proc ::logger::init {service} {
setlevel [${parent}::currentloglevel]
} else {
- foreach lvl [::logger::levels] {
+ foreach lvl [concat [::logger::levels] "trace"] {
proc ${lvl}cmd {args} "_setservicename \$args ;
set val \[stdoutcmd $lvl \[lindex \$args end\]\] ;
_restoreservice; set val"
@@ -728,6 +792,7 @@ proc ::logger::import {args} {
#
set cmds [logger::levels]
+ lappend cmds "trace"
if {$import_all} {
lappend cmds setlevel enable disable logproc delproc services
lappend cmds servicename currentloglevel delete
@@ -807,3 +872,335 @@ proc ::logger::initNamespace {ns {level
namespace eval $ns [list log::setlevel $level]
return
}
+
+# This procedure handles the "logger::trace status" command. Given no
+# arguments, returns a list of all procedures that have been registered
+# via "logger::trace add". Given one or more procedure names, it will
+# return 1 if all were registered, or 0 if any were not.
+
+proc ::logger::_trace_status { service procList } {
+ upvar #0 ::logger::tree::${service}::traceList traceList
+
+ # If no procedure names were given, just return the registered list
+
+ if {![llength $procList]} {
+ return $traceList
+ }
+
+ # Get caller's namespace for qualifying unqualified procedure names
+
+ set caller_ns [uplevel 1 namespace current]
+ set caller_ns [string trimright $caller_ns ":"]
+
+ # Search for any specified proc names that are *not* registered
+
+ foreach procName $procList {
+ # Make sure the procedure namespace is qualified
+
+ if {![string match "::*" $procName]} {
+ set procName ${caller_ns}::$procName
+ }
+
+ # Check if the procedure has been registered for tracing
+
+ if {[lsearch -exact $traceList $procName] == -1} {
+ return 0
+ }
+ }
+
+ return 1
+}
+
+# This procedure handles the "logger::trace on" command. If tracing
+# is turned off, it will enable Tcl trace handlers for all of the procedures
+# registered via "logger::trace add". Does nothing if tracing is already
+# turned on.
+
+proc ::logger::_trace_on { service } {
+ set tcl_version [package provide Tcl]
+
+ if {[package vcompare $tcl_version "8.4"] < 0} {
+ return -code error \
+ "execution tracing is not available in Tcl $tcl_version"
+ }
+
+ namespace eval ::logger::tree::${service} {
+ if {!$tracingEnabled} {
+ set tracingEnabled 1
+ ::logger::_enable_traces $service $traceList
+ }
+ }
+
+ return 1
+}
+
+# This procedure handles the "logger::trace off" command. If tracing
+# is turned on, it will disable Tcl trace handlers for all of the procedures
+# registered via "logger::trace add", leaving them in the list so they
+# tracing on all of them can be enabled again with "logger::trace on".
+# Does nothing if tracing is already turned off.
+
+proc ::logger::_trace_off { service } {
+ namespace eval ::logger::tree::${service} {
+ if {$tracingEnabled} {
+ ::logger::_disable_traces $service $traceList
+ set tracingEnabled 0
+ }
+ }
+
+ return 1
+}
+
+# This procedure is used by the logger::trace add and remove commands to
+# process the arguments in a common fashion. If the -ns switch is given
+# first, this procedure will return a list of all existing procedures in
+# all of the namespaces given in remaining arguments. Otherwise, each
+# argument is taken to be either a pattern for a glob-style search of
+# procedure names or, failing that, a namespace, in which case this
+# procedure returns a list of all the procedures matching the given
+# pattern (or all in the named namespace, if no procedures match).
+
+proc ::logger::_trace_get_proclist { inputList } {
+ set procList ""
+
+ if {[lindex $inputList 0] == "-ns"} {
+ # Verify that at least one target namespace was supplied
+
+ set inputList [lrange $inputList 1 end]
+ if {![llength $inputList]} {
+ return -code error "Must specify at least one namespace target"
+ }
+
+ # Rebuild the argument list to contain namespace procedures
+
+ foreach namespace $inputList {
+ # Don't allow tracing of the logger (or child) namespaces
+
+ if {![string match "::logger::*" $namespace]} {
+ set nsProcList [::info procs ${namespace}::*]
+ set procList [concat $procList $nsProcList]
+ }
+ }
+ } else {
+ # Search for procs or namespaces matching each of the specified
+ # patterns.
+
+ foreach pattern $inputList {
+ set matches [uplevel 1 ::info proc $pattern]
+
+ if {![llength $matches]} {
+ if {[uplevel 1 namespace exists $pattern]} {
+ set matches [::info procs ${pattern}::*]
+ }
+
+ # Matched procs will be qualified due to above pattern
+
+ set procList [concat $procList $matches]
+ } elseif {[string match "::*" $pattern]} {
+ # Patterns were pre-qualified - add them directly
+
+ set procList [concat $procList $matches]
+ } else {
+ # Qualify each proc with the namespace it was in
+
+ set ns [uplevel 1 namespace current]
+ if {$ns == "::"} {
+ set ns ""
+ }
+ foreach proc $matches {
+ lappend procList ${ns}::$proc
+ }
+ }
+ }
+ }
+
+ return $procList
+}
+
+# This procedure handles the "logger::trace add" command. If the tracing
+# feature is enabled, it will enable the Tcl entry and leave trace handlers
+# for each procedure specified that isn't already being traced. Each
+# procedure is added to the list of procedures that the logger trace feature
+# should log when tracing is enabled.
+
+proc ::logger::_trace_add { service procList } {
+ upvar #0 ::logger::tree::${service}::traceList traceList
+
+ # Handle -ns switch and glob search patterns for procedure names
+
+ set procList [uplevel 1 [list logger::_trace_get_proclist $procList]]
+
+ # Enable tracing for each procedure that has not previously been
+ # specified via logger::trace add. If tracing is off, this will just
+ # store the name of the procedure for later when tracing is turned on.
+
+ foreach procName $procList {
+ if {[lsearch -exact $traceList $procName] == -1} {
+ lappend traceList $procName
+ ::logger::_enable_traces $service [list $procName]
+ }
+ }
+}
+
+# This procedure handles the "logger::trace remove" command. If the tracing
+# feature is enabled, it will remove the Tcl entry and leave trace handlers
+# for each procedure specified. Each procedure is removed from the list
+# of procedures that the logger trace feature should log when tracing is
+# enabled.
+
+proc ::logger::_trace_remove { service procList } {
+ upvar #0 ::logger::tree::${service}::traceList traceList
+
+ # Handle -ns switch and glob search patterns for procedure names
+
+ set procList [uplevel 1 [list logger::_trace_get_proclist $procList]]
+
+ # Disable tracing for each proc that previously had been specified
+ # via logger::trace add. If tracing is off, this will just
+ # remove the name of the procedure from the trace list so that it
+ # will be excluded when tracing is turned on.
+
+ foreach procName $procList {
+ set index [lsearch -exact $traceList $procName]
+ if {$index != -1} {
+ set traceList [lreplace $traceList $index $index]
+ ::logger::_disable_traces $service [list $procName]
+ }
+ }
+}
+
+# This procedure enables Tcl trace handlers for all procedures specified.
+# It is used both to enable Tcl's tracing for a single procedure when
+# removed via "logger::trace add", as well as to enable all traces
+# via "logger::trace on".
+
+proc ::logger::_enable_traces { service procList } {
+ upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled
+
+ if {$tracingEnabled} {
+ foreach procName $procList {
+ ::trace add execution $procName enter \
+ [list ::logger::_trace_enter $service]
+ ::trace add execution $procName leave \
+ [list ::logger::_trace_leave $service]
+ }
+ }
+}
+
+# This procedure disables Tcl trace handlers for all procedures specified.
+# It is used both to disable Tcl's tracing for a single procedure when
+# removed via "logger::trace remove", as well as to disable all traces
+# via "logger::trace off".
+
+proc ::logger::_disable_traces { service procList } {
+ upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled
+
+ if {$tracingEnabled} {
+ foreach procName $procList {
+ ::trace remove execution $procName enter \
+ [list ::logger::_trace_enter $service]
+ ::trace remove execution $procName leave \
+ [list ::logger::_trace_leave $service]
+ }
+ }
+}
+
+########################################################################
+# Trace Handlers
+########################################################################
+
+# This procedure is invoked upon entry into a procedure being traced
+# via "logger::trace add" when tracing is enabled via "logger::trace on"
+# to log information about how the procedure was called.
+
+proc ::logger::_trace_enter { service cmd op } {
+ # Parse the command
+ set procName [uplevel 1 namespace origin [lindex $cmd 0]]
+ set args [lrange $cmd 1 end]
+
+ # Display the message prefix
+ set callerLvl [expr {[::info level] - 1}]
+ set calledLvl [::info level]
+
+ lappend message "proc" $procName
+ lappend message "level" $calledLvl
+ lappend message "script" [uplevel ::info script]
+
+ # Display the caller information
+ set caller ""
+ if {$callerLvl >= 1} {
+ # Display the name of the caller proc w/prepended namespace
+ catch {
+ set callerProcName [lindex [::info level $callerLvl] 0]
+ set caller [uplevel 2 namespace origin $callerProcName]
+ }
+ }
+
+ lappend message "caller" $caller
+
+ # Display the argument names and values
+ set argSpec [uplevel 1 ::info args $procName]
+ set argList ""
+ if {[llength $argSpec]} {
+ foreach argName $argSpec {
+ lappend argList $argName
+
+ if {$argName == "args"} {
+ lappend argList $args
+ break
+ } else {
+ lappend argList [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ }
+ }
+
+ lappend message "procargs" $argList
+ set message [list $op $message]
+
+ ::logger::tree::${service}::tracecmd $message
+}
+
+# This procedure is invoked upon leaving into a procedure being traced
+# via "logger::trace add" when tracing is enabled via "logger::trace on"
+# to log information about the result of the procedure call.
+
+proc ::logger::_trace_leave { service cmd status rc op } {
+ variable RETURN_CODES
+
+ # Parse the command
+ set procName [uplevel 1 namespace origin [lindex $cmd 0]]
+
+ # Gather the caller information
+ set callerLvl [expr {[::info level] - 1}]
+ set calledLvl [::info level]
+
+ lappend message "proc" $procName "level" $calledLvl
+ lappend message "script" [uplevel ::info script]
+
+ # Get the name of the proc being returned to w/prepended namespace
+ set caller ""
+ catch {
+ set callerProcName [lindex [::info level $callerLvl] 0]
+ set caller [uplevel 2 namespace origin $callerProcName]
+ }
+
+ lappend message "caller" $caller
+
+ # Convert the return code from numeric to verbal
+
+ if {$status < [llength $RETURN_CODES]} {
+ set status [lindex $RETURN_CODES $status]
+ }
+
+ lappend message "status" $status
+ lappend message "result" $rc
+
+ # Display the leave message
+
+ set message [list $op $message]
+ ::logger::tree::${service}::tracecmd $message
+
+ return 1
+}
+
Index: logger.test
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/log/logger.test,v
retrieving revision 1.25
diff -u -p -r1.25 logger.test
--- logger.test 29 Jan 2006 05:58:20 -0000 1.25
+++ logger.test 23 Jun 2006 22:16:49 -0000
@@ -1210,5 +1210,336 @@ test logger-15.13 {test for namespace wi
list $::gotcalled $code $msg
} {0 1 {Invalid cmd '::logtest::*::test' - does not exist}}
+proc traceproc0 { } {
+ traceproc1
+}
+
+proc traceproc1 { args } {
+ return "procresult1"
+}
+
+proc traceproc2 { args } {
+ return "procresult2"
+}
+
+proc traceproc3 { args } {
+ return "procresult3"
+}
+
+test logger-trace-1.1 {
+ Test <service>::trace with no arguments.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace
+} -returnCodes 1 -result {wrong # args: should be "::logger::tree::tracetest::trace action args"}
+
+test logger-trace-1.2 {
+ Test <service>::trace with an unknown action
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace foo
+} -returnCodes 1 -result \
+ {Invalid action "foo": must be status, add, remove, on, or off}
+
+test logger-trace-on-1.1 {
+ Verify that tracing is disabled by default.
+} -body {
+ set l [::logger::init tracetest]
+ set ${l}::tracingEnabled
+} -result 0
+
+test logger-trace-on-1.2 {
+ Test <service>::trace on with extra arguments
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace on 1
+} -returnCodes 1 -result {wrong # args: should be "trace on"}
+
+test logger-trace-on-1.3 {
+ Test <service>::trace on with no extra arguments and verify that
+ the tracing state flag is enabled afterward.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace on
+ set ${l}::tracingEnabled
+} -cleanup {
+ ${l}::trace off
+} -result 1
+
+test logger-trace-on-1.4 {
+ Verify <service>::trace on enables tracing only for the one service
+ and not for any of its children.
+} -body {
+ set l1 [::logger::init tracetest]
+ set l2 [::logger::init tracetest::child]
+ ${l1}::trace on
+ set ${l2}::tracingEnabled
+} -cleanup {
+ ${l1}::trace off
+} -result 0
+
+test logger-trace-off-1.1 {
+ Test <service>::trace off with extra arguments
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace off 1
+} -returnCodes 1 -result {wrong # args: should be "trace off"}
+
+test logger-trace-off-1.2 {
+ Test <service>::trace off with no extra arguments and verify that
+ tracing state flag is disabled afterward.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace off
+ set ${l}::tracingEnabled
+} -result 0
+
+test logger-trace-off-1.3 {
+ Verify that <service>::trace on followed by off leaves tracing disabled.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace on
+ ${l}::trace off
+ set ${l}::tracingEnabled
+} -result 0
+
+test logger-trace-remove-1.1 {
+ Test <service>::trace remove with no targets specified.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace remove
+} -returnCodes 1 -result \
+ {wrong # args: should be "trace remove ?-ns? <proc> ..."}
+
+test logger-trace-remove-1.2 {
+ Test <service>::trace remove with procedure names that don't exist.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace remove nosuchproc1 nosuchproc2
+} -result {}
+
+test logger-trace-remove-1.3 {
+ Test <service>::trace remove with -ns switch and namespace names
+ that don't exist.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace remove -ns nosuchns
+} -result {}
+
+test logger-trace-remove-1.4 {
+ Verify that <service>::trace remove does glob pattern matching
+ on procedure names.
+} -body {
+ namespace eval ::tracetest {
+ proc foo1 {} {}
+ proc foo2 {} {}
+ proc bar1 {} {}
+ proc bar2 {} {}
+ proc bar3 {} {}
+ }
+ set l [::logger::init tracetest]
+ ${l}::trace add ::tracetest::bar1
+ ${l}::trace add ::tracetest::bar2
+ ${l}::trace add ::tracetest::bar3
+ ${l}::trace remove ::tracetest::bar*
+ ${l}::trace status
+} -cleanup {
+ namespace delete ::tracetest
+} -result {}
+
+test logger-trace-add-1.1 {
+ Test <service>::trace add with no targets specified.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add
+} -returnCodes 1 -result \
+ {wrong # args: should be "trace add ?-ns? <proc> ..."}
+
+test logger-trace-add-1.2 {
+ Test <service>::trace add with procedure names that don't exist, and
+ verify that they are not listed in <service>::trace status.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add nosuchproc1 nosuchproc2
+ ${l}::trace status
+} -cleanup {
+ ${l}::trace remove nosuchproc1 nosuchproc2
+} -result {}
+
+test logger-trace-add-1.3 {
+ Verify that <service>::trace add with the -ns switch followed by
+ <service>::trace remove with the -ns switch, both with the same
+ namespace, leaves no traces for the namespace remaining.
+} -body {
+ namespace eval ::tracetest {
+ proc test1 {} {}
+ proc test2 {} {}
+ proc test3 {} {}
+ }
+ set l [::logger::init tracetest]
+ ${l}::trace add -ns ::tracetest
+ ${l}::trace remove -ns ::tracetest
+ ${l}::trace status
+} -cleanup {
+ namespace delete ::tracetest
+} -result {}
+
+test logger-trace-add-1.4 {
+ Verify that <service>::trace add with the -ns switch registers
+ traces for all of the procedures in that namespace.
+} -body {
+ namespace eval ::tracetest {
+ proc test1 {} {}
+ proc test2 {} {}
+ proc test3 {} {}
+ }
+ set l [::logger::init tracetest]
+ ${l}::trace add -ns ::tracetest
+ lsort -dictionary [${l}::trace status]
+} -cleanup {
+ ${l}::trace remove -ns ::tracetest
+ namespace delete ::tracetest
+} -result {::tracetest::test1 ::tracetest::test2 ::tracetest::test3}
+
+test logger-trace-add-1.5 {
+ Verify that <service>::trace add does glob pattern matching
+ on procedure names.
+} -body {
+ namespace eval ::tracetest {
+ proc foo1 {} {}
+ proc foo2 {} {}
+ proc bar1 {} {}
+ proc bar2 {} {}
+ proc bar3 {} {}
+ }
+ set l [::logger::init tracetest]
+ ${l}::trace add ::tracetest::bar*
+ lsort -dictionary [${l}::trace status]
+} -cleanup {
+ ${l}::trace remove -ns ::tracetest
+ namespace delete ::tracetest
+} -result {::tracetest::bar1 ::tracetest::bar2 ::tracetest::bar3}
+
+test logger-trace-status-1.1 {
+ Verify that <service>::trace status with no argument returns an empty
+ list when no traces are currently active.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace status
+} -result {}
+
+test logger-trace-status-1.2 {
+ Verify that <service>::trace status returns 0 when given the name of a
+ procedure that is not currently being traced.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace status foo
+} -result 0
+
+test logger-trace-status-1.3 {
+ Verify that <service>::trace status returns 0 when given the name of a
+ procedure that was, but is no longer, being traced.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add foo
+ ${l}::trace remove foo
+ ${l}::trace status foo
+} -result 0
+
+test logger-trace-status-1.4 {
+ Verify that <service>::trace status returns 0 when given the name of a
+ procedure that doesn't exist, but was passed to <service>::trace add.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add nosuchproc
+ ${l}::trace status nosuchproc
+} -cleanup {
+ ${l}::trace remove nosuchproc
+} -result 0
+
+test logger-trace-status-1.5 {
+ Verify that <service>::trace status returns 1 when given the name of an
+ existing procedure that is currently registered via <service>::trace add.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add traceproc1
+ ${l}::trace status traceproc1
+} -cleanup {
+ ${l}::trace remove traceproc1
+} -result 1
+
+test logger-trace-log-1.1 {
+ Verify that invoking a procedure that has been registered for tracing
+ via <service>::trace add does NOT generate a log message when tracing is
+ turned off.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace off ;# Should already be off. Just in case.
+ ${l}::trace add traceproc1
+ traceproc1
+} -cleanup {
+ ${l}::trace remove traceproc1
+} -result "procresult1" -output {}
+
+test logger-trace-log-1.2 {
+ Verify that invoking a procedure that has been registered for tracing
+ via <service>::trace add DOES generate a log message when tracing is
+ turned on BEFORE registration.
+
+ This test calls the traced function through another function, which
+ should result in a non-empty caller string.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace on
+ ${l}::trace add traceproc1
+ traceproc0
+} -cleanup {
+ ${l}::trace remove traceproc1
+ ${l}::trace off
+} -result "procresult1" -match regexp -output \
+{\[.*\] \[tracetest\] \[trace\] 'enter {proc ::traceproc1 level 2 script logger.test caller ::traceproc0 procargs {args {}}}'
+\[.*\] \[tracetest\] \[trace\] 'leave {proc ::traceproc1 level 2 script logger.test caller ::traceproc0 status ok result procresult1}'
+}
+
+test logger-trace-log-1.3 {
+ Verify that invoking a procedure that has been registered for tracing
+ via <service>::trace add DOES generate a log message when tracing is
+ turned on AFTER registration.
+
+ This test calls the traced function directly, which should result in
+ the caller being an empty string.
+} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add traceproc2
+ ${l}::trace on
+ traceproc2
+} -cleanup {
+ ${l}::trace remove traceproc2
+ ${l}::trace off
+} -result "procresult2" -match regexp -output \
+{\[.*\] \[tracetest\] \[trace\] 'enter {proc ::traceproc2 level 1 script logger.test caller {} procargs {args {}}}'
+\[.*\] \[tracetest\] \[trace\] 'leave {proc ::traceproc2 level 1 script logger.test caller {} status ok result procresult2}'
+}
+
+test logger-trace-logproc-1.1 {
+ Verify that a logproc can be specified for trace logging.
+} -body {
+ set l [::logger::init tracetest]
+ proc ::tracelog { message } {
+ puts $message
+ }
+ ${l}::logproc trace ::tracelog
+ ${l}::trace add traceproc2
+ ${l}::trace on
+ traceproc2
+} -cleanup {
+ ${l}::trace remove traceproc2
+ ${l}::trace off
+ rename ::tracelog {}
+} -result "procresult2" -output \
+{enter {proc ::traceproc2 level 1 script logger.test caller {} procargs {args {}}}
+leave {proc ::traceproc2 level 1 script logger.test caller {} status ok result procresult2}
+}
+
::tcltest::cleanupTests
-return
\ No newline at end of file
+return
