'''traceproc''', by [David Easton], is a simple procedure that accepts a list
of procedures, and sets up traces that display the actual arguments passed each
time one of the procedures is called, as well as the result of each procedure
call. 

[JBR] 2014-02-19:  I often use this when I'm scratched my head and cannot
understand why the code does what it does.



** Usage **

Use the plus and minus options to add and exclude procs you would like to trace
to the debugging printout.   Use the equals option to add procs that are
defined in the future to debugging print out.

======none
traceproc + <add pattern> - <exclude pattern>
traceproc = <proc pattern>
======



** Code **


======
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 (8.6.1)
        # is likely to become unstable.
        if {[namespace which $proc] ne {}} {
            trace add execution $proc {enter leave} traceproc-print
        }
    }
}

proc traceproc {args} {
   set procs {}

   foreach {op pattern} $args {
       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} 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 {} 
    set in2 {} 
    set inB {} 
 
    set list1 [lsort $list1]
    set list2 [lsort $list2]

    set equal 1
    foreach item1 $list1 item2 $list2 {
        if {item1 ne $item2} {
            set equal 0
            break
        }
    }
 
    # Shortcut for identical lists is faster
    if {$equal} {
        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
======

categories debugging