2007-09-08 [Sarnold]: I felt the need of a command-line debugger for some console scripts I wrote on Linux.
Visiting the wiki brought me a sort of challenge: create a debugger in pure-Tcl, which, I would like to, would be easy to use, ideally: 
 tcldebug myapp.tcl args...
where myapp.tcl is an unmodified Tcl application.

Well, I could not win the challenge, and myapp.tcl has to be modified (just adding one line) to be inspected for.
Indeed, my debugger tries to put traces on procs and variables, and just as any debugger, these procs and variables need to have been created ''before'' the user put traces.

Now, let the code speak...

----
'''tcldebug'''

You may name it debug.tcl or tcldebug, anyhow...

usage:
 tclsh tcldebug myapp.tcl ?args...?
instead of the classical
 tclsh myapp.tcl ?args...?



 namespace eval ::tcldebug {
    variable break ""
    variable log ""
    variable enter ""
    variable step ""
    variable argv
    variable argv0
    
    set argv $::argv
    set argv0 $::argv0


    proc var {name key} {
	if {$key eq ""} {return $name}
	return $name\($key\)
    }

    proc Log {name1 name2 op} {
	switch -- $op {
	    read - write {
		eputs "$op [var $name1 $name2]=[uplevel 1 set [var $name1 $name2]]"
	    }
	    unset {
		if {[Unlog [var $name1 $name2]]<0} {
		    Unlog $name1
		}
	    }
	    default {error "unknown $op"}
	}
    }

    proc Unlog {name} {
	variable log
	set i [lsearch -exact $log $name]
	if {$i<0} {return -1}
	set log [lreplace $log $i $i]
	catch {
    	    trace remove variable $name read ::tcldebug::Log
    	    trace remove variable $name write ::tcldebug::Log
    	    trace remove variable $name unset ::tcldebug::Log
	}
	return 0
    }

    proc Store {list elt} {
	if {[lsearch -exact $list $elt]>=0} {return $list}
	lappend list $elt
	return $list
    }

    
    proc Break {name1 name2 op} {
	switch -- $op {
	    write {
		eputs "write [var $name1 $name2]=[uplevel 1 set [var $name1 $name2]]"
		uplevel 1 ::tcldebug::Interact
	    }
	    unset {
		if {[Unbreak [var $name1 $name2]]<0} {
		    Unbreak $name1
		}
	    }
	    default {error "unknown $op"}
	}
    }

    proc Unbreak {name} {
	variable break
	set i [lsearch -exact $break $name]
	if {$i<0} {return -1}
	set break [lreplace $break $i $i]
    	catch {
    	    trace remove variable $name write ::tcldebug::Break
    	    trace remove variable $name unset ::tcldebug::Break
	}
	return 0
    }

    proc Enter {cmdstring op} {
	switch -- $op {
	    enter {
		eputs "entering [lindex $cmdstring 0]"
		uplevel 1 ::tcldebug::Interact [list $cmdstring]
	    }
	    default {error "unknown $op"}
	}
    }

    proc Unenter {name} {
	variable enter
	set i [lsearch -exact $enter $name]
	if {$i<0} {return -1}
	set enter [lreplace $enter $i $i]
    	catch {
    	    trace remove variable $name enter ::tcldebug::Enter
    	    trace remove variable $name rename ::tcldebug::Enter
	}
	return 0
    }

 
    proc Step {cmdstring op} {
	switch -- $op {
	    enterstep {
		eputs "stepping"
		uplevel 1 ::tcldebug::Interact [list $cmdstring]
	    }
	    default {error "unknown $op"}
	}
    }

    proc Unstep {name} {
	variable step
	set i [lsearch -exact $step $name]
	if {$i<0} {return -1}
	set step [lreplace $step $i $i]
    	catch {
    	    trace remove variable $name enterstep ::tcldebug::Step
    	    trace remove variable $name rename ::tcldebug::Step
	}
	return 0
    }

    proc assert {expr {message ""}} {
	if {[uplevel 1 expr $expr]} {return}
	if {$message eq ""} {set message "assertion failed: $expr"}
	error $message
    }

    proc p {varname} {
	if {[uplevel 1 array exists $varname]} {
	    uplevel 1 parray $varname
	    return
	}
	if {[uplevel 1 info exists $varname]} {
	    eputs "$varname = [uplevel 1 set $varname]"
	} else {
	    eputs "variable $varname does not exist"
	}
    }

    proc Prompt {} {
	return {TclDebugger by S.Arnold. v0.1 2007-09-08}
    }

    proc eputs {str} {puts stderr $str}

    proc Interact {{cmdstring ""}} {
	set help {Commands are:
    h or ?	prints this message
    a or >	prints the command being executed
    e or !	evals a command
    p		prints the content of each variable name
    var		watchs the modifications of some variables
	    log	    logs all modifications to stderr
	    break   adds breakpoint for writes
	    info    prints all variables being watched for
	    clear   clears logging and breaks
    cmd
	    enter   set a break point for the entering of a command
	    step    steps through the command
	    clear   clear break points (using glob patterns)
    c	    continue execution
    r	    restarts the program
    x or q  exit the debugger}
	set help [Prompt]\n$help
	while 1 {
	    puts -nonewline stderr "dbg> "
	    flush stderr
	    gets stdin line
	    switch -- [lindex $line 0] {
		h - ? {eputs $help}
		e - ! {
		    if {[catch {eputs [uplevel 1 eval [lrange $line 1 end]]} msg} {
			eputs $msg
		    }
		}
		a - > {eputs $cmdstring}
		p {
		    foreach var [lrange $line 1 end] {uplevel 1 ::tcldebug::p $var}
		}
		var {
		    assert {[llength $line]==3} "bad syntax, $line has more than 3 tokens"
		    foreach {subcmd value} [lrange $line 1 end] {break}
		    switch -- $subcmd {
			log {
			    variable log
			    set log [Store $log $value]
			    foreach op {read write unset} {
				trace add variable $value $op ::tcldebug::Log
			    }
		        } break {
			    variable break
			    set break [Store $break $value]
			    foreach op {write unset} {
				trace add variable $value $op ::tcldebug::Break
			    }
			}
			info {
			    foreach {n t} {log Logged break "Breaks at"} {
				variable $n
			        eputs "=== $t: ==="
				eputs [set $n]
				eputs "----"
			    }
			}
			clear {
			    foreach {v t cmd} {log Logged Unlog break "Breaks at" Unbreak} {
				eputs "clearing $t..."
				variable $v
				set temp [set $v]
				set $v ""
				foreach i $temp {
				    if {[string match $i $value]]} {
					eputs $i
					# unlogs or unbreaks the variable
					$cmd $i
				    } else {
					lappend $v $i
				    }
				}
			    }
			}
		        default {
			    error "no such subcommand: $subcmd"
			}
		    }
		}
		cmd {
		    assert {[llength $line]==3} "bad syntax, $line has more than 3 tokens"
		    foreach {subcmd value} [lrange $line 1 end] {break}
		    switch -- $subcmd {
			enter {
			    variable enter
			    set enter [Store $enter $value]
			    trace add execution $value enter ::tcldebug::Enter
			}
			step {
			    variable step
			    set step [Store $step $value]
			    trace add execution $value enterstep ::tcldebug::Step
			}
			info {
			    foreach {n t} {enter Enters step Stepping} {
				variable $n
			        eputs "=== $t: ==="
				eputs [set $n]
				eputs "----"
			    }
			}
		 	clear {
			    foreach {v t cmd} {enter Enters Unenter step Stepping Unstep} {
				eputs "clearing $t..."
				variable $v
				set temp [set $v]
				set $v ""
				foreach i $temp {
				    if {[string match $i [lindex $line 2]]} {
					eputs $i
					# unlogs or unbreaks the variable
					$cmd $i
				    } else {
					lappend $v $i
				    }
				}
			    }
			}
			default {
			    error "no such subcommand: $subcmd"
			}
		    }
		}
		c {
		    return
		}
		r {
		    eval exec [list [info nameofexecutable] $argv0] $argv &
		    exit
		}
		x - q {
		    exit
		}
	    }
	}
    }
 }
 proc tcldebug::debug {} {
    # Prompts
    puts stderr [tcldebug::Prompt]
    puts stderr "type C to run the program"
    # Allow first debugging commands
    ::tcldebug::Interact
 }
 # Start the program!
 set argv0 [lindex $argv 0]
 set argv [lrange $argv 1 end]
 source $argv0


----

''Example usage'':

 # example.tcl
 # let us define all procs
 proc add {a b} {expr {$a+$b}}

 proc main {} {
    set a 1
    set b 2
    puts [add $a $b]
 }
 # this line allows the use of a debugger
 catch {tcldebug::debug}
 main


''Note:'' : as Tcl's [trace]s work on procedures, global-level code is out of the debugging area.
This is common to most Tcl debuggers, and the workaround as usual is to put most if all of your code into procs.

----
[[ [Category Debugging] ]]