Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/thread2.8.8/ttrace.tcl @ 69:33d812a61356

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