util/X86LINUX64/lib/thread2.7.2/ttrace.tcl

   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 \f
  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.7.2
  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 \f
 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 \f
 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: