Attachment "profiler0.2.1.diff" to
ticket [575376ffff]
added by
hemanglavana
2002-06-29 21:23:27.
? test.tcl
? profiler0.2.1.diff
Index: pkgIndex.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/profiler/pkgIndex.tcl,v
retrieving revision 1.3
diff -r1.3 pkgIndex.tcl
12c12
< package ifneeded profiler 0.2 [list source [file join $dir profiler.tcl]]
---
> package ifneeded profiler 0.2.1 [list source [file join $dir profiler.tcl]]
Index: profiler.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/profiler/profiler.tcl,v
retrieving revision 1.17
diff -r1.17 profiler.tcl
13c13
< package provide profiler 0.2
---
> package provide profiler 0.2.1
109,112c109,113
< # Profile a function. This function works together with profProc, which
< # replaces the proc command. When a new procedure is defined, it creates
< # and alias to this function; when that procedure is called, it calls
< # this handler first, which gathers profiling information from the call.
---
> # Profile a function (tcl8.3). This function works together with
> # profProc, which replaces the proc command. When a new procedure
> # is defined, it creates and alias to this function; when that
> # procedure is called, it calls this handler first, which gathers
> # profiling information from the call.
123,135c124,131
< if { $enabled($name) } {
< if { [info level] == 1 } {
< set caller GLOBAL
< } else {
< # Get the name of the calling procedure
< set caller [lindex [info level -1] 0]
< # Remove the ORIG suffix
< set caller [string range $caller 0 end-4]
< }
< if { [catch {incr ::profiler::callers($name,$caller)}] } {
< set ::profiler::callers($name,$caller) 1
< }
< ::profiler::tZero $name.$caller
---
>
> if { [info level] == 1 } {
> set caller GLOBAL
> } else {
> # Get the name of the calling procedure
> set caller [lindex [info level -1] 0]
> # Remove the ORIG suffix
> set caller [string range $caller 0 end-4]
137a134
> ::profiler::enterHandler $name $caller
139,141c136,138
< if { $enabled($name) } {
< set t [::profiler::tMark $name.$caller]
< lappend ::profiler::statTime($name) $t
---
> ::profiler::leaveHandler $name $caller
> return $CODE
> }
143,152c140,228
< if { [incr ::profiler::callCount($name)] == 1 } {
< set ::profiler::compileTime($name) $t
< }
< incr ::profiler::totalRuntime($name) $t
< if { [catch {incr ::profiler::descendantTime($caller) $t}] } {
< set ::profiler::descendantTime($caller) $t
< }
< if { [catch {incr ::profiler::descendants($caller,$name)}] } {
< set ::profiler::descendants($caller,$name) 1
< }
---
> # ::profiler::TraceHandler --
> #
> # Profile a function (tcl8.4+). This function works together with
> # profProc, which replaces the proc command. When a new procedure
> # is defined, it creates an execution trace on the function; when
> # that function is called, 'enter' and 'leave' traces invoke this
> # handler first, which gathers profiling information from the call.
> #
> # Arguments:
> # name name of the function to profile.
> # cmd command name and its expanded arguments.
> # args for 'enter' operation, value of args is "enter"
> # for 'leave' operation, args is list of
> # 3 elements: <code> <result> "leave"
> #
> # Results:
> # None
>
> proc ::profiler::TraceHandler {name cmd args} {
>
> if { [info level] == 1 } {
> set caller GLOBAL
> } else {
> # Get the name of the calling procedure
> set caller [lindex [info level -1] 0]
> }
>
> set type [lindex $args end]
> ::profiler::${type}Handler $name $caller
> }
>
> # ::profiler::enterHandler --
> #
> # Profile a function. This function works together with Handler and
> # TraceHandler to collect profiling information just before it invokes
> # the function.
> #
> # Arguments:
> # name name of the function to profile.
> # caller name of the function that calls the profiled function.
> #
> # Results:
> # None
>
> proc ::profiler::enterHandler {name caller} {
> variable enabled
>
> if { !$enabled($name) } {
> return
> }
>
> if { [catch {incr ::profiler::callers($name,$caller)}] } {
> set ::profiler::callers($name,$caller) 1
> }
> ::profiler::tZero $name.$caller
> }
>
> # ::profiler::leaveHandler --
> #
> # Profile a function. This function works together with Handler and
> # TraceHandler to collect profiling information just after it invokes
> # the function.
> #
> # Arguments:
> # name name of the function to profile.
> # caller name of the function that calls the profiled function.
> #
> # Results:
> # None
>
> proc ::profiler::leaveHandler {name caller} {
> variable enabled
>
> if { !$enabled($name) } {
> return
> }
>
> set t [::profiler::tMark $name.$caller]
> lappend ::profiler::statTime($name) $t
>
> if { [incr ::profiler::callCount($name)] == 1 } {
> set ::profiler::compileTime($name) $t
> }
> incr ::profiler::totalRuntime($name) $t
> if { [catch {incr ::profiler::descendantTime($caller) $t}] } {
> set ::profiler::descendantTime($caller) $t
> }
> if { [catch {incr ::profiler::descendants($caller,$name)}] } {
> set ::profiler::descendants($caller,$name) 1
154d229
< return $CODE
201,202c276,283
< uplevel 1 [list ::_oldProc ${name}ORIG $arglist $body]
< uplevel 1 [list interp alias {} $name {} ::profiler::Handler $name]
---
> if {[package vsatisfies [package provide Tcl] 8.4]} {
> uplevel 1 [list ::_oldProc $name $arglist $body]
> trace add execution $name {enter leave} \
> [list ::profiler::TraceHandler $name]
> } else {
> uplevel 1 [list ::_oldProc ${name}ORIG $arglist $body]
> uplevel 1 [list interp alias {} $name {} ::profiler::Handler $name]
> }
Index: profiler.test
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/profiler/profiler.test,v
retrieving revision 1.10
diff -r1.10 profiler.test
15a16,26
> # This constraint restricts certain tests to run on tcl8.3 version only
> if {[package vsatisfies [package provide tcltest] 2.0]} {
> # tcltest2.0+ has an API to specify a test constraint
> ::tcltest::testConstraint tcl8.3only \
> [expr {![package vsatisfies [package provide Tcl] 8.4]}]
> } else {
> # In tcltest1.0, a global variable needs to be set directly.
> set ::tcltest::testConstraints(tcl8.3only) \
> [expr {![package vsatisfies [package provide Tcl] 8.4]}]
> }
>
33c44
< test profiler-2.0 {profiler creates two wrapper proc and real proc} {
---
> test profiler-2.0 {profiler creates two wrapper proc and real proc} {tcl8.3only} {
48c59
< test profiler-2.1 {profiler creates procs in correct scope} {
---
> test profiler-2.1 {profiler creates procs in correct scope} {tcl8.3only} {
64c75
< test profiler-2.2 {profiler creates procs in correct scope} {
---
> test profiler-2.2 {profiler creates procs in correct scope} {tcl8.3only} {
81c92
< test profiler-2.3 {profiler creates procs in correct scope} {
---
> test profiler-2.3 {profiler creates procs in correct scope} {tcl8.3only} {
100c111
< test profiler-2.4 {profiler creates procs in correct scope} {
---
> test profiler-2.4 {profiler creates procs in correct scope} {tcl8.3only} {
