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