Tcl Source Code

Artifact 8f3fa7e2593cd1552f452d336da851aa4488794a:

Attachment "infoframedebug.tcl" to ticket [2910094fff] added by andreas_kupries 2009-12-08 02:18:23.

---

proc debugframes {} {
    set res {}
    set level [info frame]
    while {$level} {
	puts FRAME\t[list $level [debugframereduce [info frame $level]]]
	incr level -1
    }
    return
}

proc debugframereduce {frame} {
    set  pos [lsearch -exact $frame cmd]
    incr pos
    set  cmd [lindex $frame $pos]
    if {[regexp \n $cmd]} {
	set first [string range [lindex [split $cmd \n] 0] 0 end-4]
	set frame [lreplace $frame $pos $pos $first]
    }
    set pos [lsearch -exact $frame file]
    if {$pos >=0} {
	incr pos
	set tail  [file tail [lindex $frame $pos]]
	set frame [lreplace $frame $pos $pos $tail]
    }
    set frame
}