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