#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/debug.tcl,v $
# $Date: 1997/03/03 09:24:11 $
# $Revision: 1.18.1.24 $
#
# ----------------------------------------------------------------------
#   AUTHOR:  Lindsay Marshall <lindsay.marshall@newcastle.ac.uk>
# ----------------------------------------------------------------------
# Copyright 1995 The University of Newcastle upon Tyne (see COPYRIGHT)
# ======================================================================
#
package provide Debug 1.18
#
proc zshow {line} {
    if [winfo exists .@dbgctl] {
	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 ent} {
    global DBGPos
    $ent delete 0 end
    set rng [.@dbgctl.dbg.bdy.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 [.@dbgctl.dbg.bdy.txt get $idx.2 "$idx.0 lineend"]
}
#
proc zDbgDo {} {
    global DBGPos zscr
    set w .@dbgctl.dbg.bdy
    set cmd [$w.entry get]
    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}
    $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\
      zircon@catless.ncl.ac.uk."
    switch 7.5 [info tclversion] {
	mkInfoBox ZERROR .@zrun {Internal Error} $msg
    } default {
	tk_messageBox -icon error -title {Internal Error} -message $msg -type ok
    }
}
#
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
    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 }
    update idletasks
}
#
proc zOut {line net} {
    if ![winfo exists .@dbgctl] return
    if ![$net monitorOut] return 
    global zscr DBStamp
    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 }
    update idletasks
}
#
proc zDump {file} {
    set fd [open $file w]
    foreach _x [lsort [info globals]] {
	global $_x
	if [string match auto_* $_x] continue
	if [array exists $_x] {
	    foreach _v [lsort [array names $_x]] {
		puts $fd "${_x}($_v) : {[set ${_x}($_v)]}"
	    }
	} {
	    puts $fd "$_x : {[set $_x]}"
	}
    }
    close $fd
}
#
proc zDCSave {net txt} {
    global ztrans $net
    mkFileBox .@sdb$net ${net}(sdbg) .* {Save Log} \
      "File:" {} "$ztrans(append) {zSOpen $net $txt a}"\
      "$ztrans(save) {zSOpen $net $txt w}" "$ztrans(cancel) {}"
}
#
proc zSOpen {net txt mode file} {
    switch {} $file {return 0}
    switch absolute [file path $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
}
#
proc zCtlQuit {} { catch {uplevel #0 unset 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]" 1
    }
}
#
proc zDBGCsw {ctl net title tr ent} {
    zDBRegion [switchFrame $ctl $net $title -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} {
    global zscr ztrans
    if $zscr($net) {
	set zscr($net) 0
	.@dbgctl.$net.bdy.f3.noscroll configure -text $ztrans(scroll)
    } {
	set zscr($net) 1
	.@dbgctl.$net.bdy.f3.noscroll configure -text {No Scroll}
    }
}
#
proc zDBGControl {} {
    global ztrans zscr zircon zlayout
    if [winfo exists .@dbgctl] { popup .@dbgctl ; return }
    .@ctl.helpFrm.info.menu entryconfigure end -state normal
    toplevel [set ctl .@dbgctl] -class Zircon
    wm title $ctl "Zircon Debugger"
    wm resizable $ctl 1 1
    wm protocol $ctl WM_DELETE_WINDOW {catch {uplevel #0 unset zscr}}
    grid columnconfigure $ctl 0 -weight 1 -minsize 100
    set f [frame $ctl.btn]
    button $f.close -text $ztrans(dismiss) -command zCtlQuit -width 8
    button $f.dump -text $ztrans(dump) -width 8 \
      -command "zDump [file join [tmpdir] zircon.dump]"
    button $f.kill -text $ztrans(kill) -width 8 -command  zKill
    button $f.srv -text $ztrans(server) -width 8 -command "DebugServer $f.srv"
    pack $f.close $f.dump $f.kill $f.srv -expand 1 -side left
    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)}
}
#
proc zDBRegion {f tr net ent} {
    global ztrans 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
    if $tr {
	set x Show
	if [$net monitorIn] { set x Hide }
	button $f.f3.tracein -text "$x In" -width 8 \
	  -command "zDBIn $net" -foreground red
	set x Show
	if [$net monitorOut] { set x Hide }
	button $f.f3.traceout -text "$x Out" -width 8 \
	  -command "zDBOut $net" -foreground blue
	button $f.f3.tstamp -text "Timestamp" -width 8 -command "zDBStamp $net"
	uplevel #0 set DBStamp($net) 0
	pack $f.f3.tracein $f.f3.traceout $f.f3.tstamp
    }
    button $f.f3.save -text $ztrans(save) -width 8 -command "zDCSave $net $f.txt"
    button $f.f3.clear -text $ztrans(clear) -width 8 -command "zWClear $f.txt"
    button $f.f3.noscroll -text {No Scroll} -width 8 -command "zNScroll $net"
    pack $f.f3.save $f.f3.clear $f.f3.noscroll
    if $ent {
	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 %W"
	bind $f.entry <Up> [bind $f.entry <Control-p>]
	bind $f.entry <Control-n> "zDbgHist -2 %W"
	bind $f.entry <Down> [bind $f.entry <Control-n>]
	bind $f <Enter> "focus $f.entry"
    }
}
#
proc zDBGText {f} {
    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
    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
}
#
proc zDBGAdd {net} {
    if [winfo exists .@dbgctl] {
	zDBGCsw .@dbgctl $net "Trace of [$net name]" 1 0
    }
}
