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