Initial class construction
This commit is contained in:
João Narciso
68
Git/mingw64/lib/thread2.8.4/pkgIndex.tcl
Normal file
68
Git/mingw64/lib/thread2.8.4/pkgIndex.tcl
Normal file
@ -0,0 +1,68 @@
|
||||
# -*- 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.4
|
||||
#
|
||||
# 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.4 [list load [file join $dir thread284.dll]]
|
||||
|
||||
# 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.4 "
|
||||
[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.4 [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]
|
||||
|
||||
|
||||
|
||||
BIN
Git/mingw64/lib/thread2.8.4/thread284.dll
Normal file
BIN
Git/mingw64/lib/thread2.8.4/thread284.dll
Normal file
Binary file not shown.
942
Git/mingw64/lib/thread2.8.4/ttrace.tcl
Normal file
942
Git/mingw64/lib/thread2.8.4/ttrace.tcl
Normal file
@ -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.4
|
||||
|
||||
# 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:
|
||||
Reference in New Issue
Block a user