summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tltcl/lib/thread2.8.5/ttrace.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tltcl/lib/thread2.8.5/ttrace.tcl')
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/thread2.8.5/ttrace.tcl942
1 files changed, 942 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/thread2.8.5/ttrace.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/thread2.8.5/ttrace.tcl
new file mode 100644
index 0000000000..679d4eedc2
--- /dev/null
+++ b/systems/texlive/tlnet/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: