diff options
Diffstat (limited to 'Master/tlpkg/tltcl/lib/thread2.8.5/ttrace.tcl')
-rw-r--r-- | Master/tlpkg/tltcl/lib/thread2.8.5/ttrace.tcl | 942 |
1 files changed, 942 insertions, 0 deletions
diff --git a/Master/tlpkg/tltcl/lib/thread2.8.5/ttrace.tcl b/Master/tlpkg/tltcl/lib/thread2.8.5/ttrace.tcl new file mode 100644 index 00000000000..679d4eedc23 --- /dev/null +++ b/Master/tlpkg/tltcl/lib/thread2.8.5/ttrace.tcl @@ -0,0 +1,942 @@ +# +# 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.5 + + # 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 == -1} { + variable epoch [_set ttrace lastepoch] + } else { + if {[lsearch [_set ttrace epochlist] $from] == -1} { + error "no such epoch: $from" + } + variable epoch $from + } + uplevel [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 $cmd $args + } + } + + proc preload {cmd} { + variable preloads + if {[lsearch $preloads $cmd] == -1} { + lappend preloads $cmd + } + } + + proc atenable {cmd arglist body} { + variable enables + if {[lsearch $enables $cmd] == -1} { + 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] == -1} { + 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] == -1} { + 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] == -1} { + 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] == -1} { + 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 ttrace::_resolve [list $cmd]]} { + set c [catch {uplevel $cmd [lrange $args 1 end]} r] + } else { + set c [catch {::eval ::tcl::unknown $args} r] + } + return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $r + } + + proc _resolve {cmd} { + variable resolvers + foreach resolver $resolvers { + if {[uplevel [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 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 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 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 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 ::tcl::info $args}]} { + uplevel ttrace::_resolve [list [lindex $args 1]] + } + return [uplevel ::tcl::info $args] + } + if {$hit == -1} { + return [uplevel ::tcl::info $args] + } + set cns [uplevel 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 ::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 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 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 [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: |