Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/thread2.8.8/ttrace.tcl @ 68:5028fdace37b

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