summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tltcl/lib/thread2.8.6
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tltcl/lib/thread2.8.6')
-rw-r--r--Master/tlpkg/tltcl/lib/thread2.8.6/pkgIndex.tcl68
-rwxr-xr-xMaster/tlpkg/tltcl/lib/thread2.8.6/thread286.dllbin157198 -> 0 bytes
-rw-r--r--Master/tlpkg/tltcl/lib/thread2.8.6/ttrace.tcl942
3 files changed, 0 insertions, 1010 deletions
diff --git a/Master/tlpkg/tltcl/lib/thread2.8.6/pkgIndex.tcl b/Master/tlpkg/tltcl/lib/thread2.8.6/pkgIndex.tcl
deleted file mode 100644
index e8923611342..00000000000
--- a/Master/tlpkg/tltcl/lib/thread2.8.6/pkgIndex.tcl
+++ /dev/null
@@ -1,68 +0,0 @@
-# -*- tcl -*-
-# Tcl package index file, version 1.1
-#
-
-if {![package vsatisfies [package provide Tcl] 8.4]} {
- # Pre-8.4 Tcl interps we dont support at all. Bye!
- # 9.0+ Tcl interps are only supported on 32-bit platforms.
- if {![package vsatisfies [package provide Tcl] 9.0]
- || ($::tcl_platform(pointerSize) != 4)} {
- return
- }
-}
-
-# All Tcl 8.4+ interps can [load] Thread 2.8.6
-#
-# For interps that are not thread-enabled, we still call [package ifneeded].
-# This is contrary to the usual convention, but is a good idea because we
-# cannot imagine any other version of Thread that might succeed in a
-# thread-disabled interp. There's nothing to gain by yielding to other
-# competing callers of [package ifneeded Thread]. On the other hand,
-# deferring the error has the advantage that a script calling
-# [package require Thread] in a thread-disabled interp gets an error message
-# about a thread-disabled interp, instead of the message
-# "can't find package Thread".
-
-package ifneeded Thread 2.8.6 [list load [file join $dir thread286.dll] [string totitle thread]]
-
-# package Ttrace uses some support machinery.
-
-# In Tcl 8.4 interps we use some older interfaces
-if {![package vsatisfies [package provide Tcl] 8.5]} {
- package ifneeded Ttrace 2.8.6 "
- [list proc thread_source {dir} {
- if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
- [file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
- source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
- } elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
- source [file join $dir .. lib ttrace.tcl]
- } elseif {[file readable [file join $dir ttrace.tcl]]} {
- source [file join $dir ttrace.tcl]
- }
- if {[namespace which ::ttrace::update] ne ""} {
- ::ttrace::update
- }
- }]
- [list thread_source $dir]
- [list rename thread_source {}]"
- return
-}
-
-# In Tcl 8.5+ interps; use [::apply]
-
-package ifneeded Ttrace 2.8.6 [list ::apply {{dir} {
- if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
- [file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
- source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
- } elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
- source [file join $dir .. lib ttrace.tcl]
- } elseif {[file readable [file join $dir ttrace.tcl]]} {
- source [file join $dir ttrace.tcl]
- }
- if {[namespace which ::ttrace::update] ne ""} {
- ::ttrace::update
- }
-}} $dir]
-
-
-
diff --git a/Master/tlpkg/tltcl/lib/thread2.8.6/thread286.dll b/Master/tlpkg/tltcl/lib/thread2.8.6/thread286.dll
deleted file mode 100755
index eae33d82126..00000000000
--- a/Master/tlpkg/tltcl/lib/thread2.8.6/thread286.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/tltcl/lib/thread2.8.6/ttrace.tcl b/Master/tlpkg/tltcl/lib/thread2.8.6/ttrace.tcl
deleted file mode 100644
index 0834596a566..00000000000
--- a/Master/tlpkg/tltcl/lib/thread2.8.6/ttrace.tcl
+++ /dev/null
@@ -1,942 +0,0 @@
-#
-# 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.6
-
- # 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: