jbr.tcl/trace.tcl at main · jbroll/jbr.tcl · GitHub

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

 proc traceproc-print { args } { puts $args }

 # Seed the excludes list with items that are annoying
 #
 set traceprocExclude [list ::tcl::clock::* msgcat::* ConvertLocale]

 proc traceproc-add   { patt proc op args } {
    lassign $proc type proc args body

    if { [string match $patt $proc] } {
	foreach excl $::traceprocExclude {
	    if { [string match $excl $proc] } {
		return
	    }
	}

	# If we cannot look up the command name and try to trace, Tcl is likely to
	# become unstable.
	#
	if { [info commands $proc] ne {} } {
	    trace add execution $proc { enter leave } traceproc-print
	}
    }
 }

 proc traceproc { args } {
    set procs {}

    foreach { op patterns } $args {
	foreach pattern $patterns {
	    switch $op {
	     + { lappend procs {*}[info commands $pattern] }
	     - {
		intersect3 $procs [info commands $pattern] in1 in2 inB
		set procs $in1

		lappend ::traceprocExclude $pattern
	     }

	     = {	trace add execution proc leave "traceproc-add $pattern" }
	    }
	}
    }

    intersect3 $procs "trace traceproc-print puts ::puts set ::set" in1 in2 inB
    set procs $in1

    foreach proc $procs {
	trace add execution $proc { enter leave } traceproc-print
    }
 }

 # Modified to combine the call by name and returned list of 3 lists API.
 #
 proc intersect3 { list1 list2 { inList1 {} } { inList2 {} } { inBoth {} } } {
    if { $inList1 ne {} } {
	upvar $inList1 in1
	upvar $inList2 in2
	upvar $inBoth  inB
    }

    set in1 [list]
    set in2 [list]
    set inB [list]

    set list1 [lsort $list1]
    set list2 [lsort $list2]

    # Shortcut for identical lists is faster
    if { $list1 == $list2 } {
	set inB $list1
    } else {
	set i 0
	    foreach element $list1 {
		if {[set p [lsearch [lrange $list2 $i end] $element]] == -1} {
		    lappend in1 $element
		} else {
		    if { $p > 0 } {
			set e [expr {$i + $p -1}]
			    foreach entry [lrange $list2 $i $e] {
				lappend in2 $entry
			    }
			incr i $p
		    }
		    incr i
			lappend inB $element
		}
	    }
	foreach entry [lrange $list2 $i end] {
	    lappend in2 $entry
	}
    }

    return [list $in1 $in2 $inB]
 } ;# David Easton