"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tltcl/lib/thread2.8.5/ttrace.tcl" (17 Mar 2020, 29530 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 #
    2 # ttrace.tcl --
    3 #
    4 # Copyright (C) 2003 Zoran Vasiljevic, Archiware GmbH. All Rights Reserved.
    5 #
    6 # See the file "license.terms" for information on usage and redistribution of
    7 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
    8 # ----------------------------------------------------------------------------
    9 #
   10 # User level commands:
   11 #
   12 #   ttrace::eval           top-level wrapper (ttrace-savvy eval)
   13 #   ttrace::enable         activates registered Tcl command traces
   14 #   ttrace::disable        terminates tracing of Tcl commands
   15 #   ttrace::isenabled      returns true if ttrace is enabled
   16 #   ttrace::cleanup        bring the interp to a pristine state
   17 #   ttrace::update         update interp to the latest trace epoch
   18 #   ttrace::config         setup some configuration options
   19 #   ttrace::getscript      returns a script for initializing interps
   20 #
   21 # Commands used for/from trace callbacks:
   22 #
   23 #   ttrace::atenable       register callback to be done at trace enable
   24 #   ttrace::atdisable      register callback to be done at trace disable
   25 #   ttrace::addtrace       register user-defined tracer callback
   26 #   ttrace::addscript      register user-defined script generator
   27 #   ttrace::addresolver    register user-defined command resolver
   28 #   ttrace::addcleanup     register user-defined cleanup procedures
   29 #   ttrace::addentry       adds one entry into the named trace store
   30 #   ttrace::getentry       returns the entry value from the named store
   31 #   ttrace::delentry       removes the entry from the named store
   32 #   ttrace::getentries     returns all entries from the named store
   33 #   ttrace::preload        register procedures to be preloaded always
   34 #
   35 #
   36 # Limitations:
   37 #
   38 #   o. [namespace forget] is still not implemented
   39 #   o. [namespace origin cmd] breaks if cmd is not already defined
   40 #
   41 #      I left this deliberately. I didn't want to override the [namespace]
   42 #      command in order to avoid potential slowdown.
   43 #
   44 
   45 namespace eval ttrace {
   46 
   47     # Setup some compatibility wrappers
   48     if {[info commands nsv_set] != ""} {
   49         variable tvers 0
   50         variable mutex ns_mutex
   51         variable elock [$mutex create traceepochmutex]
   52         # Import the underlying API; faster than recomputing
   53         interp alias {} [namespace current]::_array   {} nsv_array
   54         interp alias {} [namespace current]::_incr    {} nsv_incr
   55         interp alias {} [namespace current]::_lappend {} nsv_lappend
   56         interp alias {} [namespace current]::_names   {} nsv_names
   57         interp alias {} [namespace current]::_set     {} nsv_set
   58         interp alias {} [namespace current]::_unset   {} nsv_unset
   59     } elseif {![catch {
   60         variable tvers [package require Thread]
   61     }]} {
   62         variable mutex thread::mutex
   63         variable elock [$mutex create]
   64         # Import the underlying API; faster than recomputing
   65         interp alias {} [namespace current]::_array   {} tsv::array
   66         interp alias {} [namespace current]::_incr    {} tsv::incr
   67         interp alias {} [namespace current]::_lappend {} tsv::lappend
   68         interp alias {} [namespace current]::_names   {} tsv::names
   69         interp alias {} [namespace current]::_set     {} tsv::set
   70         interp alias {} [namespace current]::_unset   {} tsv::unset
   71     } else {
   72         error "requires NaviServer/AOLserver or Tcl threading extension"
   73     }
   74 
   75     # Keep in sync with the Thread package
   76     package provide Ttrace 2.8.5
   77 
   78     # Package variables
   79     variable resolvers ""     ; # List of registered resolvers
   80     variable tracers   ""     ; # List of registered cmd tracers
   81     variable scripts   ""     ; # List of registered script makers
   82     variable enables   ""     ; # List of trace-enable callbacks
   83     variable disables  ""     ; # List of trace-disable callbacks
   84     variable preloads  ""     ; # List of procedure names to preload
   85     variable enabled   0      ; # True if trace is enabled
   86     variable config           ; # Array with config options
   87 
   88     variable epoch     -1     ; # The initialization epoch
   89     variable cleancnt   0     ; # Counter of registered cleaners
   90 
   91     # Package private namespaces
   92     namespace eval resolve "" ; # Commands for resolving commands
   93     namespace eval trace   "" ; # Commands registered for tracing
   94     namespace eval enable  "" ; # Commands invoked at trace enable
   95     namespace eval disable "" ; # Commands invoked at trace disable
   96     namespace eval script  "" ; # Commands for generating scripts
   97 
   98     # Exported commands
   99     namespace export unknown
  100 
  101     # Initialize ttrace shared state
  102     if {[_array exists ttrace] == 0} {
  103         _set ttrace lastepoch $epoch
  104         _set ttrace epochlist ""
  105     }
  106 
  107     # Initially, allow creation of epochs
  108     set config(-doepochs) 1
  109 
  110     proc eval {cmd args} {
  111         enable
  112         set code [catch {uplevel 1 [concat $cmd $args]} result]
  113         disable
  114         if {$code == 0} {
  115             if {[llength [info commands ns_ictl]]} {
  116                 ns_ictl save [getscript]
  117             } else {
  118                 thread::broadcast {
  119                     package require Ttrace
  120                     ttrace::update
  121                 }
  122             }
  123         }
  124         return -code $code \
  125             -errorinfo $::errorInfo -errorcode $::errorCode $result
  126     }
  127 
  128     proc config {args} {
  129         variable config
  130         if {[llength $args] == 0} {
  131             array get config
  132         } elseif {[llength $args] == 1} {
  133             set opt [lindex $args 0]
  134             set config($opt)
  135         } else {
  136             set opt [lindex $args 0]
  137             set val [lindex $args 1]
  138             set config($opt) $val
  139         }
  140     }
  141 
  142     proc enable {} {
  143         variable config
  144         variable tracers
  145         variable enables
  146         variable enabled
  147         incr enabled 1
  148         if {$enabled > 1} {
  149             return
  150         }
  151         if {$config(-doepochs) != 0} {
  152             variable epoch [_newepoch]
  153         }
  154         set nsp [namespace current]
  155         foreach enabler $enables {
  156             enable::_$enabler
  157         }
  158         foreach trace $tracers {
  159             if {[info commands $trace] != ""} {
  160                 trace add execution $trace leave ${nsp}::trace::_$trace
  161             }
  162         }
  163     }
  164 
  165     proc disable {} {
  166         variable enabled
  167         variable tracers
  168         variable disables
  169         incr enabled -1
  170         if {$enabled > 0} {
  171             return
  172         }
  173         set nsp [namespace current]
  174         foreach disabler $disables {
  175             disable::_$disabler
  176         }
  177         foreach trace $tracers {
  178             if {[info commands $trace] != ""} {
  179                 trace remove execution $trace leave ${nsp}::trace::_$trace
  180             }
  181         }
  182     }
  183 
  184     proc isenabled {} {
  185         variable enabled
  186         expr {$enabled > 0}
  187     }
  188 
  189     proc update {{from -1}} {
  190         if {$from == -1} {
  191             variable epoch [_set ttrace lastepoch]
  192         } else {
  193             if {[lsearch [_set ttrace epochlist] $from] == -1} {
  194                 error "no such epoch: $from"
  195             }
  196             variable epoch $from
  197         }
  198         uplevel [getscript]
  199     }
  200 
  201     proc getscript {} {
  202         variable preloads
  203         variable epoch
  204         variable scripts
  205         append script [_serializensp] \n
  206         append script "::namespace eval [namespace current] {" \n
  207         append script "::namespace export unknown" \n
  208         append script "_useepoch $epoch" \n
  209         append script "}" \n
  210         foreach cmd $preloads {
  211             append script [_serializeproc $cmd] \n
  212         }
  213         foreach maker $scripts {
  214             append script [script::_$maker]
  215         }
  216         return $script
  217     }
  218 
  219     proc cleanup {args} {
  220         foreach cmd [info commands resolve::cleaner_*] {
  221             uplevel $cmd $args
  222         }
  223     }
  224 
  225     proc preload {cmd} {
  226         variable preloads
  227         if {[lsearch $preloads $cmd] == -1} {
  228             lappend preloads $cmd
  229         }
  230     }
  231 
  232     proc atenable {cmd arglist body} {
  233         variable enables
  234         if {[lsearch $enables $cmd] == -1} {
  235             lappend enables $cmd
  236             set cmd [namespace current]::enable::_$cmd
  237             proc $cmd $arglist $body
  238             return $cmd
  239         }
  240     }
  241 
  242     proc atdisable {cmd arglist body} {
  243         variable disables
  244         if {[lsearch $disables $cmd] == -1} {
  245             lappend disables $cmd
  246             set cmd [namespace current]::disable::_$cmd
  247             proc $cmd $arglist $body
  248             return $cmd
  249         }
  250     }
  251 
  252     proc addtrace {cmd arglist body} {
  253         variable tracers
  254         if {[lsearch $tracers $cmd] == -1} {
  255             lappend tracers $cmd
  256             set tracer [namespace current]::trace::_$cmd
  257             proc $tracer $arglist $body
  258             if {[isenabled]} {
  259                 trace add execution $cmd leave $tracer
  260             }
  261             return $tracer
  262         }
  263     }
  264 
  265     proc addscript {cmd body} {
  266         variable scripts
  267         if {[lsearch $scripts $cmd] == -1} {
  268             lappend scripts $cmd
  269             set cmd [namespace current]::script::_$cmd
  270             proc $cmd args $body
  271             return $cmd
  272         }
  273     }
  274 
  275     proc addresolver {cmd arglist body} {
  276         variable resolvers
  277         if {[lsearch $resolvers $cmd] == -1} {
  278             lappend resolvers $cmd
  279             set cmd [namespace current]::resolve::$cmd
  280             proc $cmd $arglist $body
  281             return $cmd
  282         }
  283     }
  284 
  285     proc addcleanup {body} {
  286         variable cleancnt
  287         set cmd [namespace current]::resolve::cleaner_[incr cleancnt]
  288         proc $cmd args $body
  289         return $cmd
  290     }
  291 
  292     proc addentry {cmd var val} {
  293         variable epoch
  294         _set ${epoch}-$cmd $var $val
  295     }
  296 
  297     proc delentry {cmd var} {
  298         variable epoch
  299         set ei $::errorInfo
  300         set ec $::errorCode
  301         catch {_unset ${epoch}-$cmd $var}
  302         set ::errorInfo $ei
  303         set ::errorCode $ec
  304     }
  305 
  306     proc getentry {cmd var} {
  307         variable epoch
  308         set ei $::errorInfo
  309         set ec $::errorCode
  310         if {[catch {_set ${epoch}-$cmd $var} val]} {
  311             set ::errorInfo $ei
  312             set ::errorCode $ec
  313             set val ""
  314         }
  315         return $val
  316     }
  317 
  318     proc getentries {cmd {pattern *}} {
  319         variable epoch
  320         _array names ${epoch}-$cmd $pattern
  321     }
  322 
  323     proc unknown {args} {
  324         set cmd [lindex $args 0]
  325         if {[uplevel ttrace::_resolve [list $cmd]]} {
  326             set c [catch {uplevel $cmd [lrange $args 1 end]} r]
  327         } else {
  328             set c [catch {::eval ::tcl::unknown $args} r]
  329         }
  330         return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $r
  331     }
  332 
  333     proc _resolve {cmd} {
  334         variable resolvers
  335         foreach resolver $resolvers {
  336             if {[uplevel [info comm resolve::$resolver] [list $cmd]]} {
  337                 return 1
  338             }
  339         }
  340         return 0
  341     }
  342 
  343     proc _getthread {} {
  344         if {[info commands ns_thread] == ""} {
  345             thread::id
  346         } else {
  347             ns_thread getid
  348         }
  349     }
  350 
  351     proc _getthreads {} {
  352         if {[info commands ns_thread] == ""} {
  353             return [thread::names]
  354         } else {
  355             foreach entry [ns_info threads] {
  356                 lappend threads [lindex $entry 2]
  357             }
  358             return $threads
  359         }
  360     }
  361 
  362     proc _newepoch {} {
  363         variable elock
  364         variable mutex
  365         $mutex lock $elock
  366         set old [_set ttrace lastepoch]
  367         set new [_incr ttrace lastepoch]
  368         _lappend ttrace $new [_getthread]
  369         if {$old >= 0} {
  370             _copyepoch $old $new
  371             _delepochs
  372         }
  373         _lappend ttrace epochlist $new
  374         $mutex unlock $elock
  375         return $new
  376     }
  377 
  378     proc _copyepoch {old new} {
  379         foreach var [_names $old-*] {
  380             set cmd [lindex [split $var -] 1]
  381             _array reset $new-$cmd [_array get $var]
  382         }
  383     }
  384 
  385     proc _delepochs {} {
  386         set tlist [_getthreads]
  387         set elist ""
  388         foreach epoch [_set ttrace epochlist] {
  389             if {[_dropepoch $epoch $tlist] == 0} {
  390                 lappend elist $epoch
  391             } else {
  392                 _unset ttrace $epoch
  393             }
  394         }
  395         _set ttrace epochlist $elist
  396     }
  397 
  398     proc _dropepoch {epoch threads} {
  399         set self [_getthread]
  400         foreach tid [_set ttrace $epoch] {
  401             if {$tid != $self && [lsearch $threads $tid] >= 0} {
  402                 lappend alive $tid
  403             }
  404         }
  405         if {[info exists alive]} {
  406             _set ttrace $epoch $alive
  407             return 0
  408         } else {
  409             foreach var [_names $epoch-*] {
  410                 _unset $var
  411             }
  412             return 1
  413         }
  414     }
  415 
  416     proc _useepoch {epoch} {
  417         if {$epoch >= 0} {
  418             set tid [_getthread]
  419             if {[lsearch [_set ttrace $epoch] $tid] == -1} {
  420                 _lappend ttrace $epoch $tid
  421             }
  422         }
  423     }
  424 
  425     proc _serializeproc {cmd} {
  426         set dargs [info args $cmd]
  427         set pbody [info body $cmd]
  428         set pargs ""
  429         foreach arg $dargs {
  430             if {![info default $cmd $arg def]} {
  431                 lappend pargs $arg
  432             } else {
  433                 lappend pargs [list $arg $def]
  434             }
  435         }
  436         set nsp [namespace qual $cmd]
  437         if {$nsp == ""} {
  438             set nsp "::"
  439         }
  440         append res [list ::namespace eval $nsp] " {" \n
  441         append res [list ::proc [namespace tail $cmd] $pargs $pbody] \n
  442         append res "}" \n
  443     }
  444 
  445     proc _serializensp {{nsp ""} {result _}} {
  446         upvar $result res
  447         if {$nsp == ""} {
  448             set nsp [namespace current]
  449         }
  450         append res [list ::namespace eval $nsp] " {" \n
  451         foreach var [info vars ${nsp}::*] {
  452             set vname [namespace tail $var]
  453             if {[array exists $var] == 0} {
  454                 append res [list ::variable $vname [set $var]] \n
  455             } else {
  456                 append res [list ::variable $vname] \n
  457                 append res [list ::array set $vname [array get $var]] \n
  458             }
  459         }
  460         foreach cmd [info procs ${nsp}::*] {
  461             append res [_serializeproc $cmd] \n
  462         }
  463         append res "}" \n
  464         foreach nn [namespace children $nsp] {
  465             _serializensp $nn res
  466         }
  467         return $res
  468     }
  469 }
  470 
  471 #
  472 # The code below is ment to be run once during the application start.  It
  473 # provides implementation of tracing callbacks for some Tcl commands.  Users
  474 # can supply their own tracer implementations on-the-fly.
  475 #
  476 # The code below will create traces for the following Tcl commands:
  477 #    "namespace", "variable", "load", "proc" and "rename"
  478 #
  479 # Also, the Tcl object extension XOTcl 1.1.0 is handled and all XOTcl related
  480 # things, like classes and objects are traced (many thanks to Gustaf Neumann
  481 # from XOTcl for his kind help and support).
  482 #
  483 
  484 eval {
  485 
  486     #
  487     # Register the "load" trace. This will create the following key/value pair
  488     # in the "load" store:
  489     #
  490     #  --- key ----              --- value ---
  491     #  <path_of_loaded_image>    <name_of_the_init_proc>
  492     #
  493     # We normally need only the name_of_the_init_proc for being able to load
  494     # the package in other interpreters, but we store the path to the image
  495     # file as well.
  496     #
  497 
  498     ttrace::addtrace load {cmdline code args} {
  499         if {$code != 0} {
  500             return
  501         }
  502         set image [lindex $cmdline 1]
  503         set initp [lindex $cmdline 2]
  504         if {$initp == ""} {
  505             foreach pkg [info loaded] {
  506                 if {[lindex $pkg 0] == $image} {
  507                     set initp [lindex $pkg 1]
  508                 }
  509             }
  510         }
  511         ttrace::addentry load $image $initp
  512     }
  513 
  514     ttrace::addscript load {
  515         append res "\n"
  516         foreach entry [ttrace::getentries load] {
  517             set initp [ttrace::getentry load $entry]
  518             append res "::load {} $initp" \n
  519         }
  520         return $res
  521     }
  522 
  523     #
  524     # Register the "namespace" trace. This will create the following key/value
  525     # entry in "namespace" store:
  526     #
  527     #  --- key ----                   --- value ---
  528     #  ::fully::qualified::namespace  1
  529     #
  530     # It will also fill the "proc" store for procedures and commands imported
  531     # in this namespace with following:
  532     #
  533     #  --- key ----                   --- value ---
  534     #  ::fully::qualified::proc       [list <ns>  "" ""]
  535     #
  536     # The <ns> is the name of the namespace where the command or procedure is
  537     # imported from.
  538     #
  539 
  540     ttrace::addtrace namespace {cmdline code args} {
  541         if {$code != 0} {
  542             return
  543         }
  544         set nop [lindex $cmdline 1]
  545         set cns [uplevel namespace current]
  546         if {$cns == "::"} {
  547             set cns ""
  548         }
  549         switch -glob $nop {
  550             eva* {
  551                 set nsp [lindex $cmdline 2]
  552                 if {![string match "::*" $nsp]} {
  553                     set nsp ${cns}::$nsp
  554                 }
  555                 ttrace::addentry namespace $nsp 1
  556             }
  557             imp* {
  558                 # - parse import arguments (skip opt "-force")
  559                 set opts [lrange $cmdline 2 end]
  560                 if {[string match "-fo*" [lindex $opts 0]]} {
  561                     set opts [lrange $cmdline 3 end]
  562                 }
  563                 # - register all imported procs and commands
  564                 foreach opt $opts {
  565                     if {![string match "::*" [::namespace qual $opt]]} {
  566                         set opt ${cns}::$opt
  567                     }
  568                     # - first import procs
  569                     foreach entry [ttrace::getentries proc $opt] {
  570                         set cmd ${cns}::[::namespace tail $entry]
  571                         set nsp [::namespace qual $entry]
  572                         set done($cmd) 1
  573                         set entry [list 0 $nsp "" ""]
  574                         ttrace::addentry proc $cmd $entry
  575                     }
  576 
  577                     # - then import commands
  578                     foreach entry [info commands $opt] {
  579                         set cmd ${cns}::[::namespace tail $entry]
  580                         set nsp [::namespace qual $entry]
  581                         if {[info exists done($cmd)] == 0} {
  582                             set entry [list 0 $nsp "" ""]
  583                             ttrace::addentry proc $cmd $entry
  584                         }
  585                     }
  586                 }
  587             }
  588         }
  589     }
  590 
  591     ttrace::addscript namespace {
  592         append res \n
  593         foreach entry [ttrace::getentries namespace] {
  594             append res "::namespace eval $entry {}" \n
  595         }
  596         return $res
  597     }
  598 
  599     #
  600     # Register the "variable" trace. This will create the following key/value
  601     # entry in the "variable" store:
  602     #
  603     #  --- key ----                   --- value ---
  604     #  ::fully::qualified::variable   1
  605     #
  606     # The variable value itself is ignored at the time of
  607     # trace/collection. Instead, we take the real value at the time of script
  608     # generation.
  609     #
  610 
  611     ttrace::addtrace variable {cmdline code args} {
  612         if {$code != 0} {
  613             return
  614         }
  615         set opts [lrange $cmdline 1 end]
  616         if {[llength $opts]} {
  617             set cns [uplevel namespace current]
  618             if {$cns == "::"} {
  619                 set cns ""
  620             }
  621             foreach {var val} $opts {
  622                 if {![string match "::*" $var]} {
  623                     set var ${cns}::$var
  624                 }
  625                 ttrace::addentry variable $var 1
  626             }
  627         }
  628     }
  629 
  630     ttrace::addscript variable {
  631         append res \n
  632         foreach entry [ttrace::getentries variable] {
  633             set cns [namespace qual $entry]
  634             set var [namespace tail $entry]
  635             append res "::namespace eval $cns {" \n
  636             append res "::variable $var"
  637             if {[array exists $entry]} {
  638                 append res "\n::array set $var [list [array get $entry]]" \n
  639             } elseif {[info exists $entry]} {
  640                 append res " [list [set $entry]]" \n
  641             } else {
  642                 append res \n
  643             }
  644             append res "}" \n
  645         }
  646         return $res
  647     }
  648 
  649 
  650     #
  651     # Register the "rename" trace. It will create the following key/value pair
  652     # in "rename" store:
  653     #
  654     #  --- key ----              --- value ---
  655     #  ::fully::qualified::old  ::fully::qualified::new
  656     #
  657     # The "new" value may be empty, for commands that have been deleted. In
  658     # such cases we also remove any traced procedure definitions.
  659     #
  660 
  661     ttrace::addtrace rename {cmdline code args} {
  662         if {$code != 0} {
  663             return
  664         }
  665         set cns [uplevel namespace current]
  666         if {$cns == "::"} {
  667             set cns ""
  668         }
  669         set old [lindex $cmdline 1]
  670         if {![string match "::*" $old]} {
  671             set old ${cns}::$old
  672         }
  673         set new [lindex $cmdline 2]
  674         if {$new != ""} {
  675             if {![string match "::*" $new]} {
  676                 set new ${cns}::$new
  677             }
  678             ttrace::addentry rename $old $new
  679         } else {
  680             ttrace::delentry proc $old
  681         }
  682     }
  683 
  684     ttrace::addscript rename {
  685         append res \n
  686         foreach old [ttrace::getentries rename] {
  687             set new [ttrace::getentry rename $old]
  688             append res "::rename $old {$new}" \n
  689         }
  690         return $res
  691     }
  692 
  693     #
  694     # Register the "proc" trace. This will create the following key/value pair
  695     # in the "proc" store:
  696     #
  697     #  --- key ----              --- value ---
  698     #  ::fully::qualified::proc  [list <epoch> <ns> <arglist> <body>]
  699     #
  700     # The <epoch> chages anytime one (re)defines a proc.  The <ns> is the
  701     # namespace where the command was imported from. If empty, the <arglist>
  702     # and <body> will hold the actual procedure definition. See the
  703     # "namespace" tracer implementation also.
  704     #
  705 
  706     ttrace::addtrace proc {cmdline code args} {
  707         if {$code != 0} {
  708             return
  709         }
  710         set cns [uplevel namespace current]
  711         if {$cns == "::"} {
  712             set cns ""
  713         }
  714         set cmd [lindex $cmdline 1]
  715         if {![string match "::*" $cmd]} {
  716             set cmd ${cns}::$cmd
  717         }
  718         set dargs [info args $cmd]
  719         set pbody [info body $cmd]
  720         set pargs ""
  721         foreach arg $dargs {
  722             if {![info default $cmd $arg def]} {
  723                 lappend pargs $arg
  724             } else {
  725                 lappend pargs [list $arg $def]
  726             }
  727         }
  728         set pdef [ttrace::getentry proc $cmd]
  729         if {$pdef == ""} {
  730             set epoch -1 ; # never traced before
  731         } else {
  732             set epoch [lindex $pdef 0]
  733         }
  734         ttrace::addentry proc $cmd [list [incr epoch] "" $pargs $pbody]
  735     }
  736 
  737     ttrace::addscript proc {
  738         return {
  739             if {[info command ::tcl::unknown] == ""} {
  740                 rename ::unknown ::tcl::unknown
  741                 namespace import -force ::ttrace::unknown
  742             }
  743             if {[info command ::tcl::info] == ""} {
  744                 rename ::info ::tcl::info
  745             }
  746             proc ::info args {
  747                 set cmd [lindex $args 0]
  748                 set hit [lsearch -glob {commands procs args default body} $cmd*]
  749                 if {$hit > 1} {
  750                     if {[catch {uplevel ::tcl::info $args}]} {
  751                         uplevel ttrace::_resolve [list [lindex $args 1]]
  752                     }
  753                     return [uplevel ::tcl::info $args]
  754                 }
  755                 if {$hit == -1} {
  756                     return [uplevel ::tcl::info $args]
  757                 }
  758                 set cns [uplevel namespace current]
  759                 if {$cns == "::"} {
  760                     set cns ""
  761                 }
  762                 set pat [lindex $args 1]
  763                 if {![string match "::*" $pat]} {
  764                     set pat ${cns}::$pat
  765                 }
  766                 set fns [ttrace::getentries proc $pat]
  767                 if {[string match $cmd* commands]} {
  768                     set fns [concat $fns [ttrace::getentries xotcl $pat]]
  769                 }
  770                 foreach entry $fns {
  771                     if {$cns != [namespace qual $entry]} {
  772                         set lazy($entry) 1
  773                     } else {
  774                         set lazy([namespace tail $entry]) 1
  775                     }
  776                 }
  777                 foreach entry [uplevel ::tcl::info $args] {
  778                     set lazy($entry) 1
  779                 }
  780                 array names lazy
  781             }
  782         }
  783     }
  784 
  785     #
  786     # Register procedure resolver. This will try to resolve the command in the
  787     # current namespace first, and if not found, in global namespace.  It also
  788     # handles commands imported from other namespaces.
  789     #
  790 
  791     ttrace::addresolver resolveprocs {cmd {export 0}} {
  792         set cns [uplevel namespace current]
  793         set name [namespace tail $cmd]
  794         if {$cns == "::"} {
  795             set cns ""
  796         }
  797         if {![string match "::*" $cmd]} {
  798             set ncmd ${cns}::$cmd
  799             set gcmd ::$cmd
  800         } else {
  801             set ncmd $cmd
  802             set gcmd $cmd
  803         }
  804         set pdef [ttrace::getentry proc $ncmd]
  805         if {$pdef == ""} {
  806             set pdef [ttrace::getentry proc $gcmd]
  807             if {$pdef == ""} {
  808                 return 0
  809             }
  810             set cmd $gcmd
  811         } else {
  812             set cmd $ncmd
  813         }
  814         set epoch [lindex $pdef 0]
  815         set pnsp  [lindex $pdef 1]
  816         if {$pnsp != ""} {
  817             set nsp [namespace qual $cmd]
  818             if {$nsp == ""} {
  819                 set nsp ::
  820             }
  821             set cmd ${pnsp}::$name
  822             if {[resolveprocs $cmd 1] == 0 && [info commands $cmd] == ""} {
  823                 return 0
  824             }
  825             namespace eval $nsp "namespace import -force $cmd"
  826         } else {
  827             uplevel 0 [list ::proc $cmd [lindex $pdef 2] [lindex $pdef 3]]
  828             if {$export} {
  829                 set nsp [namespace qual $cmd]
  830                 if {$nsp == ""} {
  831                     set nsp ::
  832                 }
  833                 namespace eval $nsp "namespace export $name"
  834             }
  835         }
  836         variable resolveproc
  837         set resolveproc($cmd) $epoch
  838         return 1
  839     }
  840 
  841     #
  842     # For XOTcl, the entire item introspection/tracing is delegated to XOTcl
  843     # itself. The xotcl store is filled with this:
  844     #
  845     #  --- key ----               --- value ---
  846     #  ::fully::qualified::item   <body>
  847     #
  848     # The <body> is the script used to generate the entire item (class,
  849     # object). Note that we do not fill in this during code tracing. It is
  850     # done during the script generation. In this step, only the placeholder is
  851     # set.
  852     #
  853     # NOTE: we assume all XOTcl commands are imported in global namespace
  854     #
  855 
  856     ttrace::atenable XOTclEnabler {args} {
  857         if {[info commands ::xotcl::Class] == ""} {
  858             return
  859         }
  860         if {[info commands ::xotcl::_creator] == ""} {
  861             ::xotcl::Class create ::xotcl::_creator -instproc create {args} {
  862                 set result [next]
  863                 if {![string match ::xotcl::_* $result]} {
  864                     ttrace::addentry xotcl $result ""
  865                 }
  866                 return $result
  867             }
  868         }
  869         ::xotcl::Class instmixin ::xotcl::_creator
  870     }
  871 
  872     ttrace::atdisable XOTclDisabler {args} {
  873         if {   [info commands ::xotcl::Class] == ""
  874             || [info commands ::xotcl::_creator] == ""} {
  875             return
  876         }
  877         ::xotcl::Class instmixin ""
  878         ::xotcl::_creator destroy
  879     }
  880 
  881     set resolver [ttrace::addresolver resolveclasses {classname} {
  882         set cns [uplevel namespace current]
  883         set script [ttrace::getentry xotcl $classname]
  884         if {$script == ""} {
  885             set name [namespace tail $classname]
  886             if {$cns == "::"} {
  887                 set script [ttrace::getentry xotcl ::$name]
  888             } else {
  889                 set script [ttrace::getentry xotcl ${cns}::$name]
  890                 if {$script == ""} {
  891                     set script [ttrace::getentry xotcl ::$name]
  892                 }
  893             }
  894             if {$script == ""} {
  895                 return 0
  896             }
  897         }
  898         uplevel [list namespace eval $cns $script]
  899         return 1
  900     }]
  901 
  902     ttrace::addscript xotcl [subst -nocommands {
  903         if {![catch {Serializer new} ss]} {
  904             foreach entry [ttrace::getentries xotcl] {
  905                 if {[ttrace::getentry xotcl \$entry] == ""} {
  906                     ttrace::addentry xotcl \$entry [\$ss serialize \$entry]
  907                 }
  908             }
  909             \$ss destroy
  910             return {::xotcl::Class proc __unknown name {$resolver \$name}}
  911         }
  912     }]
  913 
  914     #
  915     # Register callback to be called on cleanup. This will trash lazily loaded
  916     # procs which have changed since.
  917     #
  918 
  919     ttrace::addcleanup {
  920         variable resolveproc
  921         foreach cmd [array names resolveproc] {
  922             set def [ttrace::getentry proc $cmd]
  923             if {$def != ""} {
  924                 set new [lindex $def 0]
  925                 set old $resolveproc($cmd)
  926                 if {[info command $cmd] != "" && $new != $old} {
  927                     catch {rename $cmd ""}
  928                 }
  929             }
  930         }
  931     }
  932 }
  933 
  934 # EOF
  935 return
  936 
  937 # Local Variables:
  938 # mode: tcl
  939 # fill-column: 78
  940 # tab-width: 8
  941 # indent-tabs-mode: nil
  942 # End: