#===============================================================================
#  This is an extension to the 'idebug' command in tkcon.tcl.
#  Please source this script into your tkcon session.
#===============================================================================

#-------------------------------------------------------------------------------
#  bpadd
#  add a breakpoint for calls to 'procname'
#-------------------------------------------------------------------------------
proc bpadd { procname } {
    global BP
    set BP($procname,step) 0
    trace add execution $procname enter     "BREAKPOINT $procname"
    trace add execution $procname enterstep "BREAKPOINT $procname"
    trace add execution $procname leave "BREAKPOINT $procname"
    idebug on
}

#-------------------------------------------------------------------------------
#  bplist
#  return a list of active breakpoints
#-------------------------------------------------------------------------------
proc bplist { } {
    global BP
    set procs ""
    foreach item [array names BP "*,step"] {
        regsub {,step$} $item "" procname
        lappend procs $procname
    }
    return [lsort $procs]
}

#-------------------------------------------------------------------------------
#  bpdel
#  delete breakpoint from calls to 'procname'
#  if procname is not given, it defaults to the 'current' breakpoint
#-------------------------------------------------------------------------------
proc bpdel { { procname "" } } {
    global BP
    if { $procname == "" } { set procname $BP(procname) }
    trace remove execution $procname enter     "BREAKPOINT $procname"
    trace remove execution $procname enterstep "BREAKPOINT $procname"
    trace remove execution $procname leave "BREAKPOINT $procname"
    catch { unset BP($procname,step) }
}

#-------------------------------------------------------------------------------
#  dbgStep
#  step into procname, i.e. call idebug at trace 'enterstep'
#-------------------------------------------------------------------------------
proc dbgStep { { procname "" } } {
    global BP IDEBUG
    if { $procname == "" } { set procname $BP(procname) }
    set BP($procname,step) 2
    # The following statement causes idebug to continue, but this requires
    # a small modification in tkcon.tcl (line 4287 in Tkcon 2.5):
    # in proc 'idebug' in the switch handling $opt="break", replace
    # 'while 1' for the input loop with 'while { $IDEBUG(debugging) }'
    set IDEBUG(debugging) 0
    return ""
}

#-------------------------------------------------------------------------------
#  dbgReturn
#  return from procname
#-------------------------------------------------------------------------------
proc dbgReturn { { procname "" } } {
    global BP IDEBUG
    if { $procname == "" } { set procname $BP(procname) }
    set BP($procname,step) 1
    set IDEBUG(debugging) 0
    return ""
}

#-------------------------------------------------------------------------------
#  shortcuts for use within 'idebug':
#  s - step into proc
#  r - return from proc
#-------------------------------------------------------------------------------
proc s { args } { dbgStep {*}$args }
proc r { args } { dbgReturn {*}$args }

#-------------------------------------------------------------------------------
#  dumpstr - dump str in the most readable way,
#  replacing non-printable characters with their hex-code written as "\xXX"
#-------------------------------------------------------------------------------
proc dumpstr { str } {
    set result ""
    while { $str != "" } {
        if { [regexp -indices {^[-+*/%<=>.,:;|~^°`´!$&@(){}\[\]#'"A-Z_a-z0-9]+} $str igood] } {
            # " readable characters, excluding backslash
            append result [string range $str 0 [lindex $igood 1]]
            set str [string range $str [lindex $igood 1]+1 end]
        }
        if { $str != "" } {
            set char [string index $str 0]
            set str  [string range $str 1 end]
            if { $char == "\\" } {
                append result {\\}
            } else {
                binary scan $char c hex
                append result [format "\\x%02X" [expr $hex & 0xff]]
            }
        }
    }
    append result $str
    return $result
}

#-------------------------------------------------------------------------------
#  BREAKPOINT handler
#-------------------------------------------------------------------------------
proc BREAKPOINT { procname cmd args } {
    global BP
    set BP(procname) $procname

    set op [lindex $args end]

    set dbg 1
    if { $op == "enter" } {
        puts stderr "# $cmd\nBREAKPOINT @ $procname $op"

    } elseif { $op == "enterstep"  && $BP($procname,step) >= 2 } {
        puts stderr "# $cmd\nBREAKPOINT @ $procname step"

    } elseif { $op == "leave"      && $BP($procname,step) >= 1 } {
        set code   [lindex $args 0]
        set result [lindex $args 1]
        puts stderr "# $cmd\nBREAKPOINT @ $procname leave (code $code, result \"[dumpstr $result]\")"

    } else {
        set dbg 0
    }

    if { $dbg } {
        set BP($procname,step) 0
        uplevel idebug break
    }
}

#===============================================================================
#  end of file
#===============================================================================