#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/debug.tcl,v $
# $Date: 2001/06/13 07:20:28 $
# $Revision: 1.18.1.47 $
#
# ----------------------------------------------------------------------
#   AUTHOR:  Lindsay Marshall <lindsay.marshall@newcastle.ac.uk>
# ----------------------------------------------------------------------
# Copyright 2000 The University of Newcastle upon Tyne (see COPYRIGHT)
# ======================================================================
#
package provide Debug 1.18
#
proc zshow {line} {
    if {[winfo exists .@dbgctl.dbg.bdy.txt]} {
	global zscr
	set w .@dbgctl.dbg.bdy.txt
	$w configure -state normal
	$w insert end ">> $line\n"
	$w configure -state disabled
	if {$zscr(dbg)} { $w see end }
	update idletasks
    }
}
#
proc zKill {} { exit }
#
proc zWClear {txt} {
    $txt configure -state normal
    $txt delete 1.0 end
    $txt configure -state disabled
}
#
proc zDbgHist {inc txt ent} {
    global DBGPos
    $ent delete 0 end
    set rng [$txt tag ranges input]
    set foo [lindex $rng $DBGPos]
    switch end $DBGPos {
	switch {} $foo return
	set DBGPos [expr {[llength $rng] - 1}]
    }
    incr DBGPos $inc
    if {$DBGPos <= 0} { set DBGPos end }
    if {$DBGPos >= [llength $rng]} { set DBGPos 1 }
    set idx [lindex [split $foo .] 0]
    $ent insert insert [$txt get $idx.2 "$idx.0 lineend"]
}
#
proc zDbgDo {} {
    global DBGPos zscr errorInfo
    set w .@dbgctl.dbg.bdy
    set cmd [$w.entry get]
    set res [catch {uplevel #0 $cmd} msg]
    $w.txt configure -state normal
    $w.txt insert end {% }
    $w.txt insert end $cmd input
    $w.txt insert end "\n"
    switch {} $msg {} default {$w.txt insert end "$msg\n" output}
    if {$res} {$w.txt insert end "$errorInfo\n" }
    $w.txt configure -state disabled
    if {$zscr(dbg)} { $w.txt see end }
    $w.entry delete 0 end
    set DBGPos end
}
#
proc zError {msg cmd prefix param rest} {
    switch -glob -- $msg {
    {grab failed*} { bell ; return }
    }
    global errorInfo tk_patchLevel zircon tcl_platform currentNet
    set file [file join [tmpdir] zirc[pid]]
    set foo [open $file a]
    catch {puts $foo "------Error: zircon $zircon(version) $zircon(patchlevel) tcl [info patchlevel] tk $tk_patchLevel"}
    catch {puts $foo [array get tcl_platform]}
    puts $foo "Nickname: [$currentNet nickname]
Server: [$currentNet host]
Net: [$currentNet name]
Message: $msg
Processing: $prefix $cmd $rest :$param
$errorInfo"
    close $foo
    set msg  "Zircon has detected an internal error \"$msg\" when processing\
      \"$cmd\" from \"$prefix\" ($param $rest). The stack trace has\
      been saved in file \"$file\". Please send this information to\
      Lindsay.Marshall@newcastle.ac.uk."
      tellError $currentNet {Internal Error} $msg ZERROR
}
#
proc tkerror {err} { zError $err INTERNAL {} {} {} }
#
proc bgerror {err} { zError $err INTERNAL {} {} {} }
#
proc zIn {line net} {
    if {![winfo exists .@dbgctl]} return
    if {![$net monitorIn]} return
    global zscr DBStamp DBGL
    set w .@dbgctl.$net.bdy
    $w.txt configure -state normal
    if {$DBStamp($net)} { $w.txt insert end [clock format [clock seconds]] }
    $w.txt insert end ">$line" input "\n"
    $w.txt configure -state disabled
    if {$zscr($net)} { $w.txt see end }
    if {[info exists DBGL($net)]} {
        puts $DBGL($net) ">$line"
	flush $DBGL($net)
    }
    update idletasks
}
#
proc zOut {line net} {
    if {![winfo exists .@dbgctl]} return
    if {![$net monitorOut]} return 
    global zscr DBStamp DBGL
    set w .@dbgctl.$net.bdy
    $w.txt configure -state normal
    if {$DBStamp($net)} { $w.txt insert end [clock format [clock seconds]] }
    $w.txt insert end "<$line" output "\n"
    $w.txt configure -state disabled
    if {$zscr($net)} { $w.txt see end }
    if {[info exists DBGL($net)]} {
        puts $DBGL($net) "<$line"
	flush $DBGL($net)
    }
    update idletasks
}
#
proc zDump {file} {
    set fd [open $file w]
    foreach x [lsort [info globals]] {
	if {[string match auto_* $x]} continue
	upvar #0 $x xvar
	if {[array exists xvar]} {
	    foreach v [lsort [array names xvar]] {
		puts $fd "$xvar($v) : [list $xvar($v)]"
	    }
	} {
	    puts $fd "$x : [list $xvar]"
	}
    }
    close $fd
}
#
proc zDCSave {net txt} {
    mkFileBox .@sdb$net ${net}(sdbg) .* {Save Log} \
      "File:" {} "append {zSOpen $net $txt a}"\
      "save {zSOpen $net $txt w}" "cancel {}"
}
#
proc zSOpen {net txt mode file} {
    switch {} $file {return 0}
    switch absolute [file pathtype $file] {} default {
	set file [file join [pwd] $file]
    }
    if {[catch {open $file $mode} fd]} {
	$net errmsg "Cannot open file $file : $fd"
	return 0
    }
    puts $fd [$txt get 1.0 end]
    close $fd
    return 1
}
#
proc zCtlQuit {} {
    global DBGL
    foreach {x y} [array get DBGL] {
	puts $y "*** Logging stopped [clock format [clock seconds]]"
	close $y
    }
    safeUnset DBGL zscr
    destroy .@dbgctl
}
#
proc zDBGRet {net} {
    if {[winfo exists .@dbgctl]} {
	if {[$net active]} { set op host } { set op name }
	retitleFrame .@dbgctl $net "Trace of [$net $op]" $net 1
    }
}
#
proc zDBGCsw {ctl net title tr ent} {
    zDBRegion [switchFrame $ctl $net $title 0 -handles] $tr $net $ent
}
#
proc zDBIn {net} {
    if {[$net monitorIn]} {
	.@dbgctl.$net.bdy.f3.tracein configure -text "Show In"
	set x 0
    } {
	.@dbgctl.$net.bdy.f3.tracein configure -text "Hide In"
	set x 1
    }
    $net configure -monitorIn $x
}
#
proc zDBOut {net} {
    if {[$net monitorOut]} {
	.@dbgctl.$net.bdy.f3.traceout configure -text "Show Out"
	set x 0
    } {
	.@dbgctl.$net.bdy.f3.traceout configure -text "Hide Out"
	set x 1
    }
    $net configure -monitorOut $x
}
#
proc zDBStamp {net} {
    global DBStamp
    if {$DBStamp($net)} {
	.@dbgctl.$net.bdy.f3.tstamp configure -text {Timestamp}
	set x 0
    } {
	.@dbgctl.$net.bdy.f3.tstamp configure -text {No Time}
	set x 1
    }
    set DBStamp($net) $x
}
#
proc zNScroll {net btn} {
    global zscr zLock zUnlock
    if {$zscr($net)} {
	set zscr($net) 0
	$btn configure -image $zLock
    } {
	set zscr($net) 1
	$btn configure -image $zUnlock
    }
}
#
proc zDBGControl {} {
    global zscr zircon zlayout
    if {[winfo exists [set ctl .@dbgctl]]} { popup $ctl ; return }
    [MainControl].helpFrm.info.menu entryconfigure end -state normal
    makeToplevel $ctl "Zircon Debugger" {safeUnset zscr} {}
    grid columnconfigure $ctl 0 -weight 1 -minsize 100
    set f [frame $ctl.btn]
    evenGrid $f column 0 3
    button $f.close -text [trans dismiss] -command zCtlQuit -width 8
    button $f.dump -text [trans dump] -width 8 \
      -command "zDump [file join [tmpdir] zircon.dump]"
    button $f.kill -text [trans kill] -width 8 -command  zKill
    button $f.srv -text [trans server] -width 8 -command "DebugServer $f.srv"
    button $f.rdb -text [trans remote] -width 8 -command RDBG
    grid $f.close $f.dump $f.kill $f.srv $f.rdb -sticky ew
    grid $f -sticky ew
    zDBGCsw $ctl dbg {Command Interpreter} 0 1
    if {[llength [set nets [Net :: list]]] == 1} {
	zDBGCsw $ctl $nets "Trace of [$nets name]" 1 0
    } {
	foreach x $nets {
	    switch default [$x name] continue
	    zDBGCsw $ctl $x "Trace of [$x name]" 1 0
	}
    }
    catch {wm geometry $ctl $zlayout(default,debug)}
    set zscr(dbg) 1
}
#
proc RDBG {} {
    mkEntryBox .@rdb {Remote Exec} {Enter user and netspace:} \
      [list [list user {}] [list netspace {}]] \
      [list ok doRDBG] [list cancel {}]
}
#
proc doRDBG {usr net} {
    foreach x [Net :: list] {
        switch -- [$x name] $net {
	   switch nil [set r [User :: find $usr $x]] return
	   zDBGRemote $x $r
	   return
	}
    }
}
#
proc zDBGRemote {net usr} {
    global zscr zircon zlayout rdbg
    if {![winfo exists [set ctl .@dbgrem]]} {
        makeToplevel $ctl "Zircon Remote Debugger" {safeUnset zscr} {}
        grid columnconfigure $ctl 0 -weight 1 -minsize 100
        set f [frame $ctl.btn]
        button $f.close -text [trans dismiss] \
	  -command "destroy $ctl ; catch {unset rdbg}" -width 8
        grid $f.close -sticky ew
        grid $f -sticky ew
    }
    if {[winfo exists $ctl.$net$usr]} { raise $ctl ; return }
    set rdbg($net$usr) [list $net $usr]
    zDBGCsw $ctl $net$usr "[$usr name] on [$net name]" 0 2
}
#
proc zWLog {net btn} {
    global DBGL
    if {[info exists DBGL($net)]} {
        $btn configure -text Log
	puts $DBGL($net) "*** Logging stopped [clock format [clock seconds]]"
	close $DBGL($net)
	unset DBGL($net)
    } {
        $btn configure -text Unlog
	set DBGL($net) [open [file join [tmpdir] [$net name].log] a]
	puts $DBGL($net) "*** Logging started [clock format [clock seconds]]"
    }
}
#
proc zDBRegion {f tr net ent} {
    global zscr
    set zscr($net) 1
    grid rowconfigure $f 0 -weight 1
    grid columnconfigure $f 0 -weight
    grid [frame $f.f3 -borderwidth 0] -column 2 -rowspan 2 -row 0 -sticky ns
    zDBGText $f $net
    if {$tr} {
	uplevel #0 set DBStamp($net) 0
	set x Show
	if {[$net monitorIn]} { set x Hide }
	grid [button $f.f3.tracein -text "$x In" -width 8 \
	  -command "zDBIn $net" -foreground red]
	set x Show
	if {[$net monitorOut]} { set x Hide }
	grid [button $f.f3.traceout -text "$x Out" -width 8 \
	  -command "zDBOut $net" -foreground blue]
	grid [button $f.f3.tstamp -text "Timestamp" -width 8 -command "zDBStamp $net"]
    }
    grid [button $f.f3.save -text [trans save] -width 8 -command "zDCSave $net $f.txt"]
    grid [button $f.f3.log -text [trans log] -width 8 -command "zWLog $net $f.f3.log"]
    grid [button $f.f3.clear -text [trans clear] -width 8 -command "zWClear $f.txt"]
    if {!$ent} return
    emacsEntry $f.entry -relief sunken
    grid $f.entry -row 2 -columnspan 3 -column 0 -sticky ew
    bind $f.entry <Return> zDbgDo
    bind $f.entry <Control-p> "zDbgHist 2 $f.txt %W"
    bind $f.entry <Up> [bind $f.entry <Control-p>]
    bind $f.entry <Control-n> "zDbgHist -2 $f.txt %W"
    bind $f.entry <Down> [bind $f.entry <Control-n>]
    bind $f <Enter> "focus $f.entry"
   switch $ent 1 {
	bind $f.entry <Return> zDbgDo
    } 2 {
	bind $f.entry <Return> "zDbgRx $net"
    }
}
#
proc zDbgRx {dbg} {
    global DBGPos zscr errorInfo rdbg
    set w .@dbgrem.$dbg.bdy
    set cmd [$w.entry get]
    foreach {net usr} [set rdbg($dbg)] break
    $net CTCP ZIRCON [$usr name] "EVAL $cmd"
    $w.txt configure -state normal
    $w.txt insert end {% }
    $w.txt insert end $cmd input
    $w.txt insert end "\n"
    $w.txt configure -state disabled
    if {$zscr($dbg)} { $w.txt see end }
    $w.entry delete 0 end
}
#
proc zDBGText {f net} {
    global zLock
    grid columnconfigure $f 0 -weight 1
    grid rowconfigure $f 0 -weight 1
    scrollbar $f.vs -command "$f.txt yview"
    scrollbar $f.hs -command "$f.txt xview" -orient horizontal
    text $f.txt -yscrollcommand "$f.vs set" -xscrollcommand "$f.hs set" \
      -state disabled -takefocus 0 -height 10 -width 40
    button $f.jump -command "zNScroll $net $f.jump" -image $zLock
    bindtags $f.txt ROText
    $f.txt tag configure input -foreground red
    $f.txt tag configure output -foreground blue
    grid $f.txt -row 0 -column 0 -sticky nsew
    grid $f.vs -row 0 -column 1 -sticky ns
    grid $f.hs -row 1 -column 0 -sticky ew
    grid $f.jump -row 1 -column 1
}
#
proc zDBGAdd {net} {
    if {[winfo exists .@dbgctl]} {
	zDBGCsw .@dbgctl $net "Trace of [$net name]" 1 0
    }
}
#
proc zAfter {} {
    foreach x [after info] {
        zshow [after info $x]
    }
}
