Mercurial > repos > rliterman > csp2

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