|
|
# |
|
|
# ttrace.tcl -- |
|
|
# |
|
|
# Copyright (C) 2003 Zoran Vasiljevic, Archiware GmbH. All Rights Reserved. |
|
|
# |
|
|
# See the file "license.terms" for information on usage and redistribution of |
|
|
# this file, and for a DISCLAIMER OF ALL WARRANTIES. |
|
|
# ---------------------------------------------------------------------------- |
|
|
# |
|
|
# User level commands: |
|
|
# |
|
|
# ttrace::eval top-level wrapper (ttrace-savvy eval) |
|
|
# ttrace::enable activates registered Tcl command traces |
|
|
# ttrace::disable terminates tracing of Tcl commands |
|
|
# ttrace::isenabled returns true if ttrace is enabled |
|
|
# ttrace::cleanup bring the interp to a pristine state |
|
|
# ttrace::update update interp to the latest trace epoch |
|
|
# ttrace::config setup some configuration options |
|
|
# ttrace::getscript returns a script for initializing interps |
|
|
# |
|
|
# Commands used for/from trace callbacks: |
|
|
# |
|
|
# ttrace::atenable register callback to be done at trace enable |
|
|
# ttrace::atdisable register callback to be done at trace disable |
|
|
# ttrace::addtrace register user-defined tracer callback |
|
|
# ttrace::addscript register user-defined script generator |
|
|
# ttrace::addresolver register user-defined command resolver |
|
|
# ttrace::addcleanup register user-defined cleanup procedures |
|
|
# ttrace::addentry adds one entry into the named trace store |
|
|
# ttrace::getentry returns the entry value from the named store |
|
|
# ttrace::delentry removes the entry from the named store |
|
|
# ttrace::getentries returns all entries from the named store |
|
|
# ttrace::preload register procedures to be preloaded always |
|
|
# |
|
|
# |
|
|
# Limitations: |
|
|
# |
|
|
# o. [namespace forget] is still not implemented |
|
|
# o. [namespace origin cmd] breaks if cmd is not already defined |
|
|
# |
|
|
# I left this deliberately. I didn't want to override the [namespace] |
|
|
# command in order to avoid potential slowdown. |
|
|
# |
|
|
|
|
|
namespace eval ttrace { |
|
|
|
|
|
# Setup some compatibility wrappers |
|
|
if {[info commands nsv_set] != ""} { |
|
|
variable tvers 0 |
|
|
variable mutex ns_mutex |
|
|
variable elock [$mutex create traceepochmutex] |
|
|
# Import the underlying API; faster than recomputing |
|
|
interp alias {} [namespace current]::_array {} nsv_array |
|
|
interp alias {} [namespace current]::_incr {} nsv_incr |
|
|
interp alias {} [namespace current]::_lappend {} nsv_lappend |
|
|
interp alias {} [namespace current]::_names {} nsv_names |
|
|
interp alias {} [namespace current]::_set {} nsv_set |
|
|
interp alias {} [namespace current]::_unset {} nsv_unset |
|
|
} elseif {![catch { |
|
|
variable tvers [package require Thread] |
|
|
}]} { |
|
|
variable mutex thread::mutex |
|
|
variable elock [$mutex create] |
|
|
# Import the underlying API; faster than recomputing |
|
|
interp alias {} [namespace current]::_array {} tsv::array |
|
|
interp alias {} [namespace current]::_incr {} tsv::incr |
|
|
interp alias {} [namespace current]::_lappend {} tsv::lappend |
|
|
interp alias {} [namespace current]::_names {} tsv::names |
|
|
interp alias {} [namespace current]::_set {} tsv::set |
|
|
interp alias {} [namespace current]::_unset {} tsv::unset |
|
|
} else { |
|
|
error "requires NaviServer/AOLserver or Tcl threading extension" |
|
|
} |
|
|
|
|
|
# Keep in sync with the Thread package |
|
|
package provide Ttrace 2.8.12 |
|
|
|
|
|
# Package variables |
|
|
variable resolvers "" ; # List of registered resolvers |
|
|
variable tracers "" ; # List of registered cmd tracers |
|
|
variable scripts "" ; # List of registered script makers |
|
|
variable enables "" ; # List of trace-enable callbacks |
|
|
variable disables "" ; # List of trace-disable callbacks |
|
|
variable preloads "" ; # List of procedure names to preload |
|
|
variable enabled 0 ; # True if trace is enabled |
|
|
variable config ; # Array with config options |
|
|
|
|
|
variable epoch -1 ; # The initialization epoch |
|
|
variable cleancnt 0 ; # Counter of registered cleaners |
|
|
|
|
|
# Package private namespaces |
|
|
namespace eval resolve "" ; # Commands for resolving commands |
|
|
namespace eval trace "" ; # Commands registered for tracing |
|
|
namespace eval enable "" ; # Commands invoked at trace enable |
|
|
namespace eval disable "" ; # Commands invoked at trace disable |
|
|
namespace eval script "" ; # Commands for generating scripts |
|
|
|
|
|
# Exported commands |
|
|
namespace export unknown |
|
|
|
|
|
# Initialize ttrace shared state |
|
|
if {[_array exists ttrace] == 0} { |
|
|
_set ttrace lastepoch $epoch |
|
|
_set ttrace epochlist "" |
|
|
} |
|
|
|
|
|
# Initially, allow creation of epochs |
|
|
set config(-doepochs) 1 |
|
|
|
|
|
proc eval {cmd args} { |
|
|
enable |
|
|
set code [catch {uplevel 1 [concat $cmd $args]} result] |
|
|
disable |
|
|
if {$code == 0} { |
|
|
if {[llength [info commands ns_ictl]]} { |
|
|
ns_ictl save [getscript] |
|
|
} else { |
|
|
thread::broadcast { |
|
|
package require Ttrace |
|
|
ttrace::update |
|
|
} |
|
|
} |
|
|
} |
|
|
return -code $code \ |
|
|
-errorinfo $::errorInfo -errorcode $::errorCode $result |
|
|
} |
|
|
|
|
|
proc config {args} { |
|
|
variable config |
|
|
if {[llength $args] == 0} { |
|
|
array get config |
|
|
} elseif {[llength $args] == 1} { |
|
|
set opt [lindex $args 0] |
|
|
set config($opt) |
|
|
} else { |
|
|
set opt [lindex $args 0] |
|
|
set val [lindex $args 1] |
|
|
set config($opt) $val |
|
|
} |
|
|
} |
|
|
|
|
|
proc enable {} { |
|
|
variable config |
|
|
variable tracers |
|
|
variable enables |
|
|
variable enabled |
|
|
incr enabled 1 |
|
|
if {$enabled > 1} { |
|
|
return |
|
|
} |
|
|
if {$config(-doepochs) != 0} { |
|
|
variable epoch [_newepoch] |
|
|
} |
|
|
set nsp [namespace current] |
|
|
foreach enabler $enables { |
|
|
enable::_$enabler |
|
|
} |
|
|
foreach trace $tracers { |
|
|
if {[info commands $trace] != ""} { |
|
|
trace add execution $trace leave ${nsp}::trace::_$trace |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
proc disable {} { |
|
|
variable enabled |
|
|
variable tracers |
|
|
variable disables |
|
|
incr enabled -1 |
|
|
if {$enabled > 0} { |
|
|
return |
|
|
} |
|
|
set nsp [namespace current] |
|
|
foreach disabler $disables { |
|
|
disable::_$disabler |
|
|
} |
|
|
foreach trace $tracers { |
|
|
if {[info commands $trace] != ""} { |
|
|
trace remove execution $trace leave ${nsp}::trace::_$trace |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
proc isenabled {} { |
|
|
variable enabled |
|
|
expr {$enabled > 0} |
|
|
} |
|
|
|
|
|
proc update {{from -1}} { |
|
|
if {$from < 0} { |
|
|
variable epoch [_set ttrace lastepoch] |
|
|
} else { |
|
|
if {[lsearch [_set ttrace epochlist] $from] < 0} { |
|
|
error "no such epoch: $from" |
|
|
} |
|
|
variable epoch $from |
|
|
} |
|
|
uplevel 1 [getscript] |
|
|
} |
|
|
|
|
|
proc getscript {} { |
|
|
variable preloads |
|
|
variable epoch |
|
|
variable scripts |
|
|
append script [_serializensp] \n |
|
|
append script "::namespace eval [namespace current] {" \n |
|
|
append script "::namespace export unknown" \n |
|
|
append script "_useepoch $epoch" \n |
|
|
append script "}" \n |
|
|
foreach cmd $preloads { |
|
|
append script [_serializeproc $cmd] \n |
|
|
} |
|
|
foreach maker $scripts { |
|
|
append script [script::_$maker] |
|
|
} |
|
|
return $script |
|
|
} |
|
|
|
|
|
proc cleanup {args} { |
|
|
foreach cmd [info commands resolve::cleaner_*] { |
|
|
uplevel 1 $cmd $args |
|
|
} |
|
|
} |
|
|
|
|
|
proc preload {cmd} { |
|
|
variable preloads |
|
|
if {[lsearch $preloads $cmd] < 0} { |
|
|
lappend preloads $cmd |
|
|
} |
|
|
} |
|
|
|
|
|
proc atenable {cmd arglist body} { |
|
|
variable enables |
|
|
if {[lsearch $enables $cmd] < 0} { |
|
|
lappend enables $cmd |
|
|
set cmd [namespace current]::enable::_$cmd |
|
|
proc $cmd $arglist $body |
|
|
return $cmd |
|
|
} |
|
|
} |
|
|
|
|
|
proc atdisable {cmd arglist body} { |
|
|
variable disables |
|
|
if {[lsearch $disables $cmd] < 0} { |
|
|
lappend disables $cmd |
|
|
set cmd [namespace current]::disable::_$cmd |
|
|
proc $cmd $arglist $body |
|
|
return $cmd |
|
|
} |
|
|
} |
|
|
|
|
|
proc addtrace {cmd arglist body} { |
|
|
variable tracers |
|
|
if {[lsearch $tracers $cmd] < 0} { |
|
|
lappend tracers $cmd |
|
|
set tracer [namespace current]::trace::_$cmd |
|
|
proc $tracer $arglist $body |
|
|
if {[isenabled]} { |
|
|
trace add execution $cmd leave $tracer |
|
|
} |
|
|
return $tracer |
|
|
} |
|
|
} |
|
|
|
|
|
proc addscript {cmd body} { |
|
|
variable scripts |
|
|
if {[lsearch $scripts $cmd] < 0} { |
|
|
lappend scripts $cmd |
|
|
set cmd [namespace current]::script::_$cmd |
|
|
proc $cmd args $body |
|
|
return $cmd |
|
|
} |
|
|
} |
|
|
|
|
|
proc addresolver {cmd arglist body} { |
|
|
variable resolvers |
|
|
if {[lsearch $resolvers $cmd] < 0} { |
|
|
lappend resolvers $cmd |
|
|
set cmd [namespace current]::resolve::$cmd |
|
|
proc $cmd $arglist $body |
|
|
return $cmd |
|
|
} |
|
|
} |
|
|
|
|
|
proc addcleanup {body} { |
|
|
variable cleancnt |
|
|
set cmd [namespace current]::resolve::cleaner_[incr cleancnt] |
|
|
proc $cmd args $body |
|
|
return $cmd |
|
|
} |
|
|
|
|
|
proc addentry {cmd var val} { |
|
|
variable epoch |
|
|
_set ${epoch}-$cmd $var $val |
|
|
} |
|
|
|
|
|
proc delentry {cmd var} { |
|
|
variable epoch |
|
|
set ei $::errorInfo |
|
|
set ec $::errorCode |
|
|
catch {_unset ${epoch}-$cmd $var} |
|
|
set ::errorInfo $ei |
|
|
set ::errorCode $ec |
|
|
} |
|
|
|
|
|
proc getentry {cmd var} { |
|
|
variable epoch |
|
|
set ei $::errorInfo |
|
|
set ec $::errorCode |
|
|
if {[catch {_set ${epoch}-$cmd $var} val]} { |
|
|
set ::errorInfo $ei |
|
|
set ::errorCode $ec |
|
|
set val "" |
|
|
} |
|
|
return $val |
|
|
} |
|
|
|
|
|
proc getentries {cmd {pattern *}} { |
|
|
variable epoch |
|
|
_array names ${epoch}-$cmd $pattern |
|
|
} |
|
|
|
|
|
proc unknown {args} { |
|
|
set cmd [lindex $args 0] |
|
|
if {[uplevel 1 ttrace::_resolve [list $cmd]]} { |
|
|
set c [catch {uplevel 1 $cmd [lrange $args 1 end]} r] |
|
|
} else { |
|
|
set c [catch {uplevel 1 ::tcl::unknown $args} r] |
|
|
} |
|
|
return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $r |
|
|
} |
|
|
|
|
|
proc _resolve {cmd} { |
|
|
variable resolvers |
|
|
foreach resolver $resolvers { |
|
|
if {[uplevel 1 [info comm resolve::$resolver] [list $cmd]]} { |
|
|
return 1 |
|
|
} |
|
|
} |
|
|
return 0 |
|
|
} |
|
|
|
|
|
proc _getthread {} { |
|
|
if {[info commands ns_thread] == ""} { |
|
|
thread::id |
|
|
} else { |
|
|
ns_thread getid |
|
|
} |
|
|
} |
|
|
|
|
|
proc _getthreads {} { |
|
|
if {[info commands ns_thread] == ""} { |
|
|
return [thread::names] |
|
|
} else { |
|
|
foreach entry [ns_info threads] { |
|
|
lappend threads [lindex $entry 2] |
|
|
} |
|
|
return $threads |
|
|
} |
|
|
} |
|
|
|
|
|
proc _newepoch {} { |
|
|
variable elock |
|
|
variable mutex |
|
|
$mutex lock $elock |
|
|
set old [_set ttrace lastepoch] |
|
|
set new [_incr ttrace lastepoch] |
|
|
_lappend ttrace $new [_getthread] |
|
|
if {$old >= 0} { |
|
|
_copyepoch $old $new |
|
|
_delepochs |
|
|
} |
|
|
_lappend ttrace epochlist $new |
|
|
$mutex unlock $elock |
|
|
return $new |
|
|
} |
|
|
|
|
|
proc _copyepoch {old new} { |
|
|
foreach var [_names $old-*] { |
|
|
set cmd [lindex [split $var -] 1] |
|
|
_array reset $new-$cmd [_array get $var] |
|
|
} |
|
|
} |
|
|
|
|
|
proc _delepochs {} { |
|
|
set tlist [_getthreads] |
|
|
set elist "" |
|
|
foreach epoch [_set ttrace epochlist] { |
|
|
if {[_dropepoch $epoch $tlist] == 0} { |
|
|
lappend elist $epoch |
|
|
} else { |
|
|
_unset ttrace $epoch |
|
|
} |
|
|
} |
|
|
_set ttrace epochlist $elist |
|
|
} |
|
|
|
|
|
proc _dropepoch {epoch threads} { |
|
|
set self [_getthread] |
|
|
foreach tid [_set ttrace $epoch] { |
|
|
if {$tid != $self && [lsearch $threads $tid] >= 0} { |
|
|
lappend alive $tid |
|
|
} |
|
|
} |
|
|
if {[info exists alive]} { |
|
|
_set ttrace $epoch $alive |
|
|
return 0 |
|
|
} else { |
|
|
foreach var [_names $epoch-*] { |
|
|
_unset $var |
|
|
} |
|
|
return 1 |
|
|
} |
|
|
} |
|
|
|
|
|
proc _useepoch {epoch} { |
|
|
if {$epoch >= 0} { |
|
|
set tid [_getthread] |
|
|
if {[lsearch [_set ttrace $epoch] $tid] == -1} { |
|
|
_lappend ttrace $epoch $tid |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
proc _serializeproc {cmd} { |
|
|
set dargs [info args $cmd] |
|
|
set pbody [info body $cmd] |
|
|
set pargs "" |
|
|
foreach arg $dargs { |
|
|
if {![info default $cmd $arg def]} { |
|
|
lappend pargs $arg |
|
|
} else { |
|
|
lappend pargs [list $arg $def] |
|
|
} |
|
|
} |
|
|
set nsp [namespace qual $cmd] |
|
|
if {$nsp == ""} { |
|
|
set nsp "::" |
|
|
} |
|
|
append res [list ::namespace eval $nsp] " {" \n |
|
|
append res [list ::proc [namespace tail $cmd] $pargs $pbody] \n |
|
|
append res "}" \n |
|
|
} |
|
|
|
|
|
proc _serializensp {{nsp ""} {result _}} { |
|
|
upvar $result res |
|
|
if {$nsp == ""} { |
|
|
set nsp [namespace current] |
|
|
} |
|
|
append res [list ::namespace eval $nsp] " {" \n |
|
|
foreach var [info vars ${nsp}::*] { |
|
|
set vname [namespace tail $var] |
|
|
if {[array exists $var] == 0} { |
|
|
append res [list ::variable $vname [set $var]] \n |
|
|
} else { |
|
|
append res [list ::variable $vname] \n |
|
|
append res [list ::array set $vname [array get $var]] \n |
|
|
} |
|
|
} |
|
|
foreach cmd [info procs ${nsp}::*] { |
|
|
append res [_serializeproc $cmd] \n |
|
|
} |
|
|
append res "}" \n |
|
|
foreach nn [namespace children $nsp] { |
|
|
_serializensp $nn res |
|
|
} |
|
|
return $res |
|
|
} |
|
|
} |
|
|
|
|
|
# |
|
|
# The code below is ment to be run once during the application start. It |
|
|
# provides implementation of tracing callbacks for some Tcl commands. Users |
|
|
# can supply their own tracer implementations on-the-fly. |
|
|
# |
|
|
# The code below will create traces for the following Tcl commands: |
|
|
# "namespace", "variable", "load", "proc" and "rename" |
|
|
# |
|
|
# Also, the Tcl object extension XOTcl 1.1.0 is handled and all XOTcl related |
|
|
# things, like classes and objects are traced (many thanks to Gustaf Neumann |
|
|
# from XOTcl for his kind help and support). |
|
|
# |
|
|
|
|
|
eval { |
|
|
|
|
|
# |
|
|
# Register the "load" trace. This will create the following key/value pair |
|
|
# in the "load" store: |
|
|
# |
|
|
# --- key ---- --- value --- |
|
|
# <path_of_loaded_image> <name_of_the_init_proc> |
|
|
# |
|
|
# We normally need only the name_of_the_init_proc for being able to load |
|
|
# the package in other interpreters, but we store the path to the image |
|
|
# file as well. |
|
|
# |
|
|
|
|
|
ttrace::addtrace load {cmdline code args} { |
|
|
if {$code != 0} { |
|
|
return |
|
|
} |
|
|
set image [lindex $cmdline 1] |
|
|
set initp [lindex $cmdline 2] |
|
|
if {$initp == ""} { |
|
|
foreach pkg [info loaded] { |
|
|
if {[lindex $pkg 0] == $image} { |
|
|
set initp [lindex $pkg 1] |
|
|
} |
|
|
} |
|
|
} |
|
|
ttrace::addentry load $image $initp |
|
|
} |
|
|
|
|
|
ttrace::addscript load { |
|
|
append res "\n" |
|
|
foreach entry [ttrace::getentries load] { |
|
|
set initp [ttrace::getentry load $entry] |
|
|
append res "::load {} $initp" \n |
|
|
} |
|
|
return $res |
|
|
} |
|
|
|
|
|
# |
|
|
# Register the "namespace" trace. This will create the following key/value |
|
|
# entry in "namespace" store: |
|
|
# |
|
|
# --- key ---- --- value --- |
|
|
# ::fully::qualified::namespace 1 |
|
|
# |
|
|
# It will also fill the "proc" store for procedures and commands imported |
|
|
# in this namespace with following: |
|
|
# |
|
|
# --- key ---- --- value --- |
|
|
# ::fully::qualified::proc [list <ns> "" ""] |
|
|
# |
|
|
# The <ns> is the name of the namespace where the command or procedure is |
|
|
# imported from. |
|
|
# |
|
|
|
|
|
ttrace::addtrace namespace {cmdline code args} { |
|
|
if {$code != 0} { |
|
|
return |
|
|
} |
|
|
set nop [lindex $cmdline 1] |
|
|
set cns [uplevel 1 namespace current] |
|
|
if {$cns == "::"} { |
|
|
set cns "" |
|
|
} |
|
|
switch -glob $nop { |
|
|
eva* { |
|
|
set nsp [lindex $cmdline 2] |
|
|
if {![string match "::*" $nsp]} { |
|
|
set nsp ${cns}::$nsp |
|
|
} |
|
|
ttrace::addentry namespace $nsp 1 |
|
|
} |
|
|
imp* { |
|
|
# - parse import arguments (skip opt "-force") |
|
|
set opts [lrange $cmdline 2 end] |
|
|
if {[string match "-fo*" [lindex $opts 0]]} { |
|
|
set opts [lrange $cmdline 3 end] |
|
|
} |
|
|
# - register all imported procs and commands |
|
|
foreach opt $opts { |
|
|
if {![string match "::*" [::namespace qual $opt]]} { |
|
|
set opt ${cns}::$opt |
|
|
} |
|
|
# - first import procs |
|
|
foreach entry [ttrace::getentries proc $opt] { |
|
|
set cmd ${cns}::[::namespace tail $entry] |
|
|
set nsp [::namespace qual $entry] |
|
|
set done($cmd) 1 |
|
|
set entry [list 0 $nsp "" ""] |
|
|
ttrace::addentry proc $cmd $entry |
|
|
} |
|
|
|
|
|
# - then import commands |
|
|
foreach entry [info commands $opt] { |
|
|
set cmd ${cns}::[::namespace tail $entry] |
|
|
set nsp [::namespace qual $entry] |
|
|
if {[info exists done($cmd)] == 0} { |
|
|
set entry [list 0 $nsp "" ""] |
|
|
ttrace::addentry proc $cmd $entry |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
ttrace::addscript namespace { |
|
|
append res \n |
|
|
foreach entry [ttrace::getentries namespace] { |
|
|
append res "::namespace eval $entry {}" \n |
|
|
} |
|
|
return $res |
|
|
} |
|
|
|
|
|
# |
|
|
# Register the "variable" trace. This will create the following key/value |
|
|
# entry in the "variable" store: |
|
|
# |
|
|
# --- key ---- --- value --- |
|
|
# ::fully::qualified::variable 1 |
|
|
# |
|
|
# The variable value itself is ignored at the time of |
|
|
# trace/collection. Instead, we take the real value at the time of script |
|
|
# generation. |
|
|
# |
|
|
|
|
|
ttrace::addtrace variable {cmdline code args} { |
|
|
if {$code != 0} { |
|
|
return |
|
|
} |
|
|
set opts [lrange $cmdline 1 end] |
|
|
if {[llength $opts]} { |
|
|
set cns [uplevel 1 namespace current] |
|
|
if {$cns == "::"} { |
|
|
set cns "" |
|
|
} |
|
|
foreach {var val} $opts { |
|
|
if {![string match "::*" $var]} { |
|
|
set var ${cns}::$var |
|
|
} |
|
|
ttrace::addentry variable $var 1 |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
ttrace::addscript variable { |
|
|
append res \n |
|
|
foreach entry [ttrace::getentries variable] { |
|
|
set cns [namespace qual $entry] |
|
|
set var [namespace tail $entry] |
|
|
append res "::namespace eval $cns {" \n |
|
|
append res "::variable $var" |
|
|
if {[array exists $entry]} { |
|
|
append res "\n::array set $var [list [array get $entry]]" \n |
|
|
} elseif {[info exists $entry]} { |
|
|
append res " [list [set $entry]]" \n |
|
|
} else { |
|
|
append res \n |
|
|
} |
|
|
append res "}" \n |
|
|
} |
|
|
return $res |
|
|
} |
|
|
|
|
|
|
|
|
# |
|
|
# Register the "rename" trace. It will create the following key/value pair |
|
|
# in "rename" store: |
|
|
# |
|
|
# --- key ---- --- value --- |
|
|
# ::fully::qualified::old ::fully::qualified::new |
|
|
# |
|
|
# The "new" value may be empty, for commands that have been deleted. In |
|
|
# such cases we also remove any traced procedure definitions. |
|
|
# |
|
|
|
|
|
ttrace::addtrace rename {cmdline code args} { |
|
|
if {$code != 0} { |
|
|
return |
|
|
} |
|
|
set cns [uplevel 1 namespace current] |
|
|
if {$cns == "::"} { |
|
|
set cns "" |
|
|
} |
|
|
set old [lindex $cmdline 1] |
|
|
if {![string match "::*" $old]} { |
|
|
set old ${cns}::$old |
|
|
} |
|
|
set new [lindex $cmdline 2] |
|
|
if {$new != ""} { |
|
|
if {![string match "::*" $new]} { |
|
|
set new ${cns}::$new |
|
|
} |
|
|
ttrace::addentry rename $old $new |
|
|
} else { |
|
|
ttrace::delentry proc $old |
|
|
} |
|
|
} |
|
|
|
|
|
ttrace::addscript rename { |
|
|
append res \n |
|
|
foreach old [ttrace::getentries rename] { |
|
|
set new [ttrace::getentry rename $old] |
|
|
append res "::rename $old {$new}" \n |
|
|
} |
|
|
return $res |
|
|
} |
|
|
|
|
|
# |
|
|
# Register the "proc" trace. This will create the following key/value pair |
|
|
# in the "proc" store: |
|
|
# |
|
|
# --- key ---- --- value --- |
|
|
# ::fully::qualified::proc [list <epoch> <ns> <arglist> <body>] |
|
|
# |
|
|
# The <epoch> chages anytime one (re)defines a proc. The <ns> is the |
|
|
# namespace where the command was imported from. If empty, the <arglist> |
|
|
# and <body> will hold the actual procedure definition. See the |
|
|
# "namespace" tracer implementation also. |
|
|
# |
|
|
|
|
|
ttrace::addtrace proc {cmdline code args} { |
|
|
if {$code != 0} { |
|
|
return |
|
|
} |
|
|
set cns [uplevel 1 namespace current] |
|
|
if {$cns == "::"} { |
|
|
set cns "" |
|
|
} |
|
|
set cmd [lindex $cmdline 1] |
|
|
if {![string match "::*" $cmd]} { |
|
|
set cmd ${cns}::$cmd |
|
|
} |
|
|
set dargs [info args $cmd] |
|
|
set pbody [info body $cmd] |
|
|
set pargs "" |
|
|
foreach arg $dargs { |
|
|
if {![info default $cmd $arg def]} { |
|
|
lappend pargs $arg |
|
|
} else { |
|
|
lappend pargs [list $arg $def] |
|
|
} |
|
|
} |
|
|
set pdef [ttrace::getentry proc $cmd] |
|
|
if {$pdef == ""} { |
|
|
set epoch -1 ; # never traced before |
|
|
} else { |
|
|
set epoch [lindex $pdef 0] |
|
|
} |
|
|
ttrace::addentry proc $cmd [list [incr epoch] "" $pargs $pbody] |
|
|
} |
|
|
|
|
|
ttrace::addscript proc { |
|
|
return { |
|
|
if {[info command ::tcl::unknown] == ""} { |
|
|
rename ::unknown ::tcl::unknown |
|
|
namespace import -force ::ttrace::unknown |
|
|
} |
|
|
if {[info command ::tcl::info] == ""} { |
|
|
rename ::info ::tcl::info |
|
|
} |
|
|
proc ::info args { |
|
|
set cmd [lindex $args 0] |
|
|
set hit [lsearch -glob {commands procs args default body} $cmd*] |
|
|
if {$hit > 1} { |
|
|
if {[catch {uplevel 1 ::tcl::info $args}]} { |
|
|
uplevel 1 ttrace::_resolve [list [lindex $args 1]] |
|
|
} |
|
|
return [uplevel 1 ::tcl::info $args] |
|
|
} |
|
|
if {$hit == -1} { |
|
|
return [uplevel 1 ::tcl::info $args] |
|
|
} |
|
|
set cns [uplevel 1 namespace current] |
|
|
if {$cns == "::"} { |
|
|
set cns "" |
|
|
} |
|
|
set pat [lindex $args 1] |
|
|
if {![string match "::*" $pat]} { |
|
|
set pat ${cns}::$pat |
|
|
} |
|
|
set fns [ttrace::getentries proc $pat] |
|
|
if {[string match $cmd* commands]} { |
|
|
set fns [concat $fns [ttrace::getentries xotcl $pat]] |
|
|
} |
|
|
foreach entry $fns { |
|
|
if {$cns != [namespace qual $entry]} { |
|
|
set lazy($entry) 1 |
|
|
} else { |
|
|
set lazy([namespace tail $entry]) 1 |
|
|
} |
|
|
} |
|
|
foreach entry [uplevel 1 ::tcl::info $args] { |
|
|
set lazy($entry) 1 |
|
|
} |
|
|
array names lazy |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
# |
|
|
# Register procedure resolver. This will try to resolve the command in the |
|
|
# current namespace first, and if not found, in global namespace. It also |
|
|
# handles commands imported from other namespaces. |
|
|
# |
|
|
|
|
|
ttrace::addresolver resolveprocs {cmd {export 0}} { |
|
|
set cns [uplevel 1 namespace current] |
|
|
set name [namespace tail $cmd] |
|
|
if {$cns == "::"} { |
|
|
set cns "" |
|
|
} |
|
|
if {![string match "::*" $cmd]} { |
|
|
set ncmd ${cns}::$cmd |
|
|
set gcmd ::$cmd |
|
|
} else { |
|
|
set ncmd $cmd |
|
|
set gcmd $cmd |
|
|
} |
|
|
set pdef [ttrace::getentry proc $ncmd] |
|
|
if {$pdef == ""} { |
|
|
set pdef [ttrace::getentry proc $gcmd] |
|
|
if {$pdef == ""} { |
|
|
return 0 |
|
|
} |
|
|
set cmd $gcmd |
|
|
} else { |
|
|
set cmd $ncmd |
|
|
} |
|
|
set epoch [lindex $pdef 0] |
|
|
set pnsp [lindex $pdef 1] |
|
|
if {$pnsp != ""} { |
|
|
set nsp [namespace qual $cmd] |
|
|
if {$nsp == ""} { |
|
|
set nsp :: |
|
|
} |
|
|
set cmd ${pnsp}::$name |
|
|
if {[resolveprocs $cmd 1] == 0 && [info commands $cmd] == ""} { |
|
|
return 0 |
|
|
} |
|
|
namespace eval $nsp "namespace import -force $cmd" |
|
|
} else { |
|
|
uplevel 0 [list ::proc $cmd [lindex $pdef 2] [lindex $pdef 3]] |
|
|
if {$export} { |
|
|
set nsp [namespace qual $cmd] |
|
|
if {$nsp == ""} { |
|
|
set nsp :: |
|
|
} |
|
|
namespace eval $nsp "namespace export $name" |
|
|
} |
|
|
} |
|
|
variable resolveproc |
|
|
set resolveproc($cmd) $epoch |
|
|
return 1 |
|
|
} |
|
|
|
|
|
# |
|
|
# For XOTcl, the entire item introspection/tracing is delegated to XOTcl |
|
|
# itself. The xotcl store is filled with this: |
|
|
# |
|
|
# --- key ---- --- value --- |
|
|
# ::fully::qualified::item <body> |
|
|
# |
|
|
# The <body> is the script used to generate the entire item (class, |
|
|
# object). Note that we do not fill in this during code tracing. It is |
|
|
# done during the script generation. In this step, only the placeholder is |
|
|
# set. |
|
|
# |
|
|
# NOTE: we assume all XOTcl commands are imported in global namespace |
|
|
# |
|
|
|
|
|
ttrace::atenable XOTclEnabler {args} { |
|
|
if {[info commands ::xotcl::Class] == ""} { |
|
|
return |
|
|
} |
|
|
if {[info commands ::xotcl::_creator] == ""} { |
|
|
::xotcl::Class create ::xotcl::_creator -instproc create {args} { |
|
|
set result [next] |
|
|
if {![string match ::xotcl::_* $result]} { |
|
|
ttrace::addentry xotcl $result "" |
|
|
} |
|
|
return $result |
|
|
} |
|
|
} |
|
|
::xotcl::Class instmixin ::xotcl::_creator |
|
|
} |
|
|
|
|
|
ttrace::atdisable XOTclDisabler {args} { |
|
|
if { [info commands ::xotcl::Class] == "" |
|
|
|| [info commands ::xotcl::_creator] == ""} { |
|
|
return |
|
|
} |
|
|
::xotcl::Class instmixin "" |
|
|
::xotcl::_creator destroy |
|
|
} |
|
|
|
|
|
set resolver [ttrace::addresolver resolveclasses {classname} { |
|
|
set cns [uplevel 1 namespace current] |
|
|
set script [ttrace::getentry xotcl $classname] |
|
|
if {$script == ""} { |
|
|
set name [namespace tail $classname] |
|
|
if {$cns == "::"} { |
|
|
set script [ttrace::getentry xotcl ::$name] |
|
|
} else { |
|
|
set script [ttrace::getentry xotcl ${cns}::$name] |
|
|
if {$script == ""} { |
|
|
set script [ttrace::getentry xotcl ::$name] |
|
|
} |
|
|
} |
|
|
if {$script == ""} { |
|
|
return 0 |
|
|
} |
|
|
} |
|
|
uplevel 1 [list namespace eval $cns $script] |
|
|
return 1 |
|
|
}] |
|
|
|
|
|
ttrace::addscript xotcl [subst -nocommands { |
|
|
if {![catch {Serializer new} ss]} { |
|
|
foreach entry [ttrace::getentries xotcl] { |
|
|
if {[ttrace::getentry xotcl \$entry] == ""} { |
|
|
ttrace::addentry xotcl \$entry [\$ss serialize \$entry] |
|
|
} |
|
|
} |
|
|
\$ss destroy |
|
|
return {::xotcl::Class proc __unknown name {$resolver \$name}} |
|
|
} |
|
|
}] |
|
|
|
|
|
# |
|
|
# Register callback to be called on cleanup. This will trash lazily loaded |
|
|
# procs which have changed since. |
|
|
# |
|
|
|
|
|
ttrace::addcleanup { |
|
|
variable resolveproc |
|
|
foreach cmd [array names resolveproc] { |
|
|
set def [ttrace::getentry proc $cmd] |
|
|
if {$def != ""} { |
|
|
set new [lindex $def 0] |
|
|
set old $resolveproc($cmd) |
|
|
if {[info command $cmd] != "" && $new != $old} { |
|
|
catch {rename $cmd ""} |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
# EOF |
|
|
return |
|
|
|
|
|
# Local Variables: |
|
|
# mode: tcl |
|
|
# fill-column: 78 |
|
|
# tab-width: 8 |
|
|
# indent-tabs-mode: nil |
|
|
# End:
|
|
|
|
