Attachment "profiler.diff" to
ticket [828717ffff]
added by
fstockinger
2003-10-23 14:01:14.
--- /usr/local/ActiveTcl-8.4.4/lib/tcllib1.5/profiler/profiler.tcl 2003-07-21 07:16:11.000000000 +0200
+++ ./profiler.tcl 2003-10-23 08:50:03.000000000 +0200
@@ -10,7 +10,7 @@
# RCS: @(#) $Id: profiler.tcl,v 1.23 2003/04/28 23:34:49 patthoyts Exp $
package require Tcl 8.3 ;# uses [clock clicks -milliseconds]
-package provide profiler 0.2.1
+package provide profiler 0.2.2
namespace eval ::profiler {
}
@@ -26,9 +26,9 @@
# None.
proc ::profiler::tZero { { tag "" } } {
+ set tag [string map {: ""} $tag]
set ms [ clock clicks -milliseconds ]
set us [ clock clicks ]
- set tag [string map {: ""} $tag]
# FRINK: nocheck
set ::profiler::T$tag [ list $us $ms ]
return
@@ -164,9 +164,32 @@
} else {
# Get the name of the calling procedure
set caller [lindex [info level -1] 0]
+ if {[string length $caller]} {
+ # the tkInit clause
+ if {[catch {set fqName [uplevel [list namespace origin $caller]]}]} {
+ set caller EMPTY
+ } else {
+ set caller $fqName
+ }
+ } else {
+ # if info level is empty try one more
+ if {[info level] > 2} {
+ set caller [lindex [info level -2] 0]
+ if {[string length $caller]} {
+ set caller [uplevel [list namespace origin $caller]]
+ } else {
+ set caller EMPTY
+ }
+ }
+ }
}
set type [lindex $args end]
+ # get a 'canonical' name
+ if {! [catch {set fqName [uplevel [list namespace origin $name]]}]} {
+ set name $fqName
+ }
+
::profiler::${type}Handler $name $caller
}
@@ -571,12 +594,135 @@
variable callCount
variable enabled
variable paused
-
+
set paused 0
foreach name [array names callCount $pattern] {
+ # allow profiling of set
+ if {[string equal $name "::set"]} {
+ trace remove execution $name {enter leave} [list ::profiler::TraceHandler $name]
+ }
set enabled($name) 1
+ if {[string equal $name "::set"]} {
+ trace add execution $name {enter leave} [list ::profiler::TraceHandler $name]
+ }
+ }
+
+ return
+}
+
+# ::profiler::start --
+#
+# Start arranging procedure for profiling, to be called after init
+#
+# Arguments:
+# None.
+#
+# Results:
+# None. Renames proc the original proc
+
+proc ::profiler::start {} {
+ variable paused 0
+
+ interp alias {} proc {} ::profiler::profProc
+
+ return
+}
+
+
+# ::profiler::stop --
+#
+# Stop arranging procedure for profiling
+#
+# Arguments:
+# None.
+#
+# Results:
+# None. Renames proc the original proc
+
+proc ::profiler::stop {} {
+ variable paused 1
+
+ interp alias {} proc {} _oldProc
+
+ return
+}
+
+
+# ::profiler::removeCmd --
+#
+# Remove the profiling capabilities from a procedure or command
+#
+# Arguments:
+# name name of the procedure
+#
+# Results:
+# None.
+
+proc ::profiler::removeCmd {name} {
+ variable callCount
+ variable compileTime
+ variable totalRuntime
+ variable descendantTime
+ variable statTime
+ variable enabled
+ variable paused
+
+ set name [uplevel [list namespace origin $name]]
+ if {![info exists enabled($name)]} return
+
+ # Remove accounting for this procedure
+ unset callCount($name)
+ unset compileTime($name)
+ unset totalRuntime($name)
+ unset descendantTime($name)
+ unset statTime($name)
+ unset enabled($name)
+
+ if {[package vsatisfies [package provide Tcl] 8.4]} {
+ trace remove execution $name {enter leave} [list ::profiler::TraceHandler $name]
+ } else {
+ error "delete commands from profiling needs tcl 8.4 or higher"
}
+
+ return
+}
+
+
+# ::profiler::addCmd --
+#
+# Add profiling to any command, which are not included before
+#
+# Arguments:
+# name name of the procedure
+#
+# Results:
+# None.
+
+proc ::profiler::addCmd {name} {
+ variable callCount
+ variable compileTime
+ variable totalRuntime
+ variable descendantTime
+ variable statTime
+ variable enabled
+ variable paused
+
+ set name [uplevel [list namespace origin $name]]
+ # Set up accounting for this procedure
+ set callCount($name) 0
+ set compileTime($name) 0
+ set totalRuntime($name) 0
+ set descendantTime($name) 0
+ set statTime($name) {}
+ set enabled($name) [expr {!$paused}]
+
+ if {[package vsatisfies [package provide Tcl] 8.4]} {
+ trace add execution $name {enter leave} [list ::profiler::TraceHandler $name]
+ } else {
+ error "add commands to profiling needs tcl 8.4 or higher"
+ }
+
return
}
