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