#!/usr/bin/wish -f
#
# $Id: TdChoose.tcl,v 4.1 1994/01/30 21:02:30 schmid Exp schmid $
#
# TdChoose.tcl - A simple debugger for tcl scripts
# Version 0.3
#
# Copyright (C) 1993 Gregor Schmid 
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software

# Please send bug-reports, suggestions etc. to
#
# 		schmid@fb3-s7.math.tu-berlin.de
#

# This file was written with emacs using Jamie Lokier's folding mode
# That's what the funny # {{{ marks are there for

# {{{ global variables

if {[file exists "~/.tdebugrc"]} {
    source "~/.tdebugrc"
    set td_priv(.tdebugrc) 1
}

set td_priv(choose) prepare

# Setup default values for variables not set from .tdebugrc
# Most variables have only 2 legal alternatives, so we can
# also check for correctness.

foreach i "\
    {send		1	0} \
    {scrollbarside	right	left} \
    {constrainscroll 	1	0} \
    {chooseheight	10	NOCHECK} \
    {choosewidth	20	NOCHECK} \
    {hideownprocs	1	0} \
    {hidetkprocs	0	1} \
    {debugdir		[file dirname [info script]] NOCHECK} \
" {
    if {[lindex $i 2] != "NOCHECK"} {
	if {![info exists td_priv([lindex $i 0])] || \
		$td_priv([lindex $i 0]) != [lindex $i 2]} {
	    set td_priv([lindex $i 0]) [lindex $i 1]
    }   } else {
	if {![info exists td_priv([lindex $i 0])]} {
	    set td_priv([lindex $i 0]) [lindex $i 1]
}   }   }

if {$td_priv(send)} {
    set td_ips [winfo interps]
    if {[llength $td_ips] > 1} {
	foreach i $td_ips {
	    if {$i != [winfo name .]} {
		set td_priv(interp) $i
		break
    }   }   } else {
	set td_priv(interp) <none>
	unset td_ips
}   } else {
    set td_priv(interp) [winfo name .]
}

# }}}
# {{{ procs

# {{{ td_rescanProcs

# Rescan the procs for the currently selected interpreter
# `td_priv(interp)'.
# `td_priv(choose)' should either be set to `prepare' to display all procs
# or to `restore' to display only those procs that have been prepared
# for debugging.

proc td_rescanProcs {} {
    global td_priv td_ChooseBox td_ChooseName

    if {$td_priv(send) && ! [td_loadDebugger $td_priv(interp)]} {
	return
    }
    set names [td_sendOrEval {info procs}]
    set procs [td_sendOrEval td_preparedProcs]
    set names [lsort $names]
    if {$td_priv(choose) == "prepare"} {
	if {$td_priv(hideownprocs)} {
	    # remove all procs belonging to TdDebug.tcl from the list
	    set i1 [lsearch -exact $names td_AAA]
	    set i2 [lsearch -exact $names td_zzz]
	    if {$i1 != -1 && $i2 != -1} {
		set names [lreplace $names $i1 $i2]
	    }
	    set i1 [lsearch -exact $names proc]
	    if {$i1 != -1} {
		set names [lreplace $names $i1 $i1]
	}   }
	if {$td_priv(hidetkprocs)} {
	    set i1 [lsearch -exact $names tk_bindForTraversal]
	    set i2 [lsearch -exact $names tk_traverseWithinMenu]
	    if {$i1 != -1 && $i2 != -1} {
		set names [lreplace $names $i1 $i2]
	    }
	    set i1 [lsearch -exact $names auto_execok]
	    set i2 [lsearch -exact $names auto_reset]
	    if {$i1 != -1 && $i2 != -1} {
		set names [lreplace $names $i1 $i2]
	    }
	    set i1 [lsearch -exact $names unknown]
	    if {$i1 != -1} {
		set names [lreplace $names $i1 $i1]
	}   }
	$td_ChooseBox delete 0 end
	foreach i $names {
	    if {[lsearch -exact $procs $i] == -1} {
		$td_ChooseBox insert end " $i"
	    } else {
		$td_ChooseBox insert end "*$i"
    }   }   } else {
	$td_ChooseBox delete 0 end
	eval "$td_ChooseBox insert 0 $procs"
    }   
}

# }}}
# {{{ td_smartRescan

# Do td_rescanProcs but keep current yview if possible.

proc td_smartRescan {} {
    global td_ChooseBox td_ChooseScroll

    set view [lindex [$td_ChooseScroll get] 2]
    td_rescanProcs
    $td_ChooseBox yview $view
}

# }}}
# {{{ td_chooseOK

# Prepare or restore the proc that has been selected according to the
# value of `td_priv(choose)'.
# Args:
# y		y-position of mouse cursor

proc td_chooseOK y {
    global td_priv td_ChooseBox

    set sel [$td_ChooseBox nearest $y]
    
    if {$sel != ""} {
	set name [$td_ChooseBox get $sel]
    }
    if {$name != ""} {
	if {$td_priv(send)} {
	    if {! [td_loadDebugger $td_priv(interp)]} {return}
	}
	if {$td_priv(choose) == "prepare"} {
	    set name [string range $name 1 end]

	    # give some visible response
	    $td_ChooseBox select clear
	    update
	    
	    # can't use td_sendOrEval because of `after 1...'
	    if {$td_priv(send)} {
		if {[catch {send $td_priv(interp) \
			"after 1 \{td_prepareProc $name\}"} err]} {
		    td_panic $err
	    }   } else {
		td_prepareProc $name
	    }
	    $td_ChooseBox delete $sel
	    $td_ChooseBox insert $sel "*$name"
	    $td_ChooseBox select from $sel
	} else {
	    td_sendOrEval {td_restoreProc $name}
	    set view [$td_ChooseBox nearest 0]
	    td_rescanProcs
	    $td_ChooseBox yview $view
}   }   }

# }}}
# {{{ td_chooseList

# Display the selected proc.
# Args:
# y		y-position of mouse cursor

proc td_chooseList y {
    global td_priv td_ChooseBox

    set sel [$td_ChooseBox nearest $y]
    
    if {$sel != ""} {
	set name [$td_ChooseBox get $sel]
    }
    if {$name != ""} {
	if {$td_priv(send)} {
	    if {! [td_loadDebugger $td_priv(interp)]} {return}
	}
	if {$td_priv(choose) == "prepare"} {
	    set name [string range $name 1 end]
	}
	td_sendOrEval "td_displayProc $name"
}   }   

# }}}
# {{{ td_makeInterpMenu

# Setup the menu to change the selected interpreter. Don't diplay the
# interpreter of the Chooser

proc td_makeInterpMenu {} {
    global td_ChooseMenu td_ChooseMB

    $td_ChooseMenu delete 0 last
    set interps [winfo interps]
    set myind [lsearch -exact $interps [winfo name .]]
    set interps [lreplace $interps $myind $myind]
    if {$interps != ""} {
	foreach i $interps {
	    $td_ChooseMenu add command -label $i -command "td_doChange $i"
    }   } else {
	$td_ChooseMenu add command -label " <none> " 
	$td_ChooseMenu disable 0
    }
}

# }}}
# {{{ td_doChange

# Change `td_priv(interp)' to the interpreter chosen and
# call `td_rescan' to update the display.

proc td_doChange {args} {
    global td_priv
    set td_priv(interp) $args
    td_rescanProcs
}
    

# }}}
# {{{ td_popDebugger

# Make sure selected interpreter has sourced TdDebug.tcl  and popup
# Debugger window

proc td_popDebugger {} {
    global td_priv
    if {$td_priv(send)} {
	if {! [td_loadDebugger $td_priv(interp)]} {return}
	if {[catch {send $td_priv(interp) {wm deiconify $td_Top}} err]} {
	    td_panic $err
    }   } else {
	global td_Top
	wm deiconify $td_Top
}   }

# }}}
# {{{ td_loadDebugger

# Check if TdDebug has been sourced. If not, try to do it.
# Catch fails of send to avoid exiting when hitting an inactive
# interpreter.
# Args:
# interp	Interpreter to check
# Return value:
#		1	successfull
#		0	not successfull

proc td_loadDebugger interp {
    global td_priv

    if {[catch {send $interp "info procs td_eval"} procs]} {
	if {[string match "X server insecure*" $procs]} {
	    tkerror "$procs\nSee Installation section of README !"
	} else {
	    tkerror $procs
	}
	return 0
    }
    if {$procs == ""} {
	if {[catch {send $interp \
		"source $td_priv(debugdir)/TdDebug.tcl"} err]} {
	    tkerror $err
	    return 0
	}
	lappend td_priv(connected) $interp
	send $interp "set td_priv(chooseinterp) \{[winfo name .]\}"
    }   
    return 1
}

# }}}
# {{{ td_catchChooseScroll

proc td_catchChooseScroll {a b c d} {
    global td_ChooseScroll td_ChooseBox
    if {$a < $b && $c > 0} {
	$td_ChooseBox yview 0
	$td_ChooseScroll set $a $b 0 [expr $b - 1]
    } elseif {$a -$c < $b} {
	$td_ChooseBox yview [expr $a - $b]
	$td_ChooseScroll set $a $b [expr $a - $b] [expr $a - 1]
    } else {
	$td_ChooseScroll set $a $b $c $d
    }
}

# }}}
# {{{ td_panic

# This is called if send seems to work, but an error is caught anyway.
# As the text says, it shouldn't happen, but it will, if the application
# is busy, or maybe because of some real bug in TdDebug.tcl
# Arg:
# err:			The error that was caught.

proc td_panic {err} {
    error "$err\nThis should never have happened !\
	    Please report this error and include the backtrace info."
}

# }}}
# {{{ td_sendOrEval

proc td_sendOrEval {cmd} {
    global td_priv
    if {! $td_priv(send)} {
	return [uplevel 1 $cmd]
    }
    if { [catch {uplevel 1 send \{$td_priv(interp)\} $cmd} err]} {
	td_panic $err
    } else {
	return $err
}   }

# }}}
# {{{ td_chooseExit

# Detach from all interpreters and exit

proc td_chooseExit {} {
    global td_priv
    
    if !$td_priv(send) {
	td_detachDebugger
    } else {
	foreach i $td_priv(connected) {
	    catch "send $i td_detachDebugger"
	}
	destroy .
}   }

# }}}

# }}}
# {{{ interface

# {{{ setup symbolic widget names for Chooser

if {$td_priv(send)} {
    set td_Choose 	""
} else {
    set td_Choose	.td_Choose
}
set td_ChooseNameFrame	$td_Choose.chooseNameFrame
set td_ChooseLabel	$td_ChooseNameFrame.chooseLabel
set td_ChooseButton	$td_ChooseNameFrame.chooseButton
set td_ChooseMenu	$td_ChooseButton.menu
set td_ChooseName	$td_ChooseNameFrame.chooseName

set td_ChoosePop	$td_Choose.pop

set td_ChooseFrame	$td_Choose.chooseFrame
set td_ChooseBox	$td_ChooseFrame.chooseBox
set td_ChooseScroll	$td_ChooseFrame.chooseScroll

set td_ChooseBFrame	$td_Choose.chooseBFrame
set td_ChooseButtons1	$td_ChooseBFrame.chooseButtons1
set td_ChooseBPrepare 	$td_ChooseButtons1.choosePrepare
set td_ChooseBRestore 	$td_ChooseButtons1.chooseRestore

set td_ChooseBExit	$td_ChooseBFrame.chooseBExit

# }}}
# {{{ Chooser Toplevel

if {$td_priv(send)} {
    wm title . TDebug-Choose
    . configure -borderwidth 2
} else {
    toplevel $td_Choose -class TDebug-Choose
    wm title $td_Choose TDebug-Choose
}

# }}}
# {{{ the name

frame $td_ChooseNameFrame -borderwidth 2 -relief raised 
pack $td_ChooseNameFrame -side top -fill x -padx 2 -pady 2
label $td_ChooseLabel -text Interp: -width 8
pack $td_ChooseLabel -side left
if {$td_priv(send)} {
    menubutton $td_ChooseButton -relief raised -text "+" -width 1 \
	    -menu $td_ChooseMenu
    pack $td_ChooseButton -side left 
    menu $td_ChooseMenu -postcommand td_makeInterpMenu
}
entry $td_ChooseName -relief groove -textvariable td_priv(interp) -state disabled \
	-width 8
pack $td_ChooseName -side left -expand 1 -fill both

# }}}
# {{{ pop

button $td_ChoosePop -text "Popup Debugger" -command td_popDebugger
pack $td_ChoosePop -side top -fill x -padx 2 -pady 2

# }}}
# {{{ the listbox

frame $td_ChooseFrame -borderwidth 2 -relief raised
pack $td_ChooseFrame -side top -expand 1 -fill both -padx 2 -pady 2

scrollbar $td_ChooseScroll -command "$td_ChooseBox yview"
pack $td_ChooseScroll -side $td_priv(scrollbarside) -fill y

listbox $td_ChooseBox -relief sunken -setgrid 1 -geometry 17x3
if {$td_priv(constrainscroll)} {
    $td_ChooseBox configure -yscrollcommand td_catchChooseScroll
} else {
    $td_ChooseBox configure -yscrollcommand "$td_ChooseScroll set"
}
pack $td_ChooseBox -side $td_priv(scrollbarside) -expand 1 -fill both

# }}}
# {{{ the buttons

frame $td_ChooseBFrame
pack $td_ChooseBFrame -side top -fill x -padx 2 -pady 2
frame $td_ChooseButtons1
pack $td_ChooseButtons1 -side left -fill x -expand 1

radiobutton $td_ChooseBPrepare -relief raised -text "Prepare" -width 4 \
	-variable td_priv(choose) -value prepare \
	-command td_rescanProcs
pack $td_ChooseBPrepare -side top -fill x

radiobutton $td_ChooseBRestore -relief raised -text "Restore" -width 4 \
	-variable td_priv(choose) -value restore \
	-command td_rescanProcs
pack $td_ChooseBRestore -side top -fill x

button $td_ChooseBExit -relief raised -text "Exit" -width 4 -height 2 \
	-command td_chooseExit
pack $td_ChooseBExit -side left -fill both -expand 1

# }}}

if {$td_priv(send)} {
    wm geometry . $td_priv(choosewidth)x$td_priv(chooseheight)
    if [info exists td_priv(choosegeometry)] {
	wm geometry . $td_priv(choosegeometry)
	wm positionfrom . user
    }
    wm minsize . 17 3
} else {
    wm geometry $td_Choose $td_priv(choosewidth)x$td_priv(chooseheight)
    if [info exists td_priv(choosegeometry)] {
	wm geometry $td_Choose $td_priv(choosegeometry)
	wm positionfrom $td_Choose user
    }
    wm minsize $td_Choose 17 3
}
$td_ChooseBox configure -exportselection no  -selectbackground \
        [lindex [$td_ChooseBPrepare configure -activebackground] 3]
bind $td_ChooseBox <Enter> {%W select from [%W nearest %y]}
bind $td_ChooseBox <Leave> {%W select clear}
bind $td_ChooseBox <Any-Motion> {%W select from [%W nearest %y]}
bind $td_ChooseBox <Any-Motion> {%W select from [%W nearest %y]}
bind $td_ChooseBox <Button-2> {+ %W select clear}
bind $td_ChooseBox <B2-Motion> {%W scan dragto %x %y}
bind $td_ChooseBox <ButtonRelease-2> {%W select from [%W nearest %y]}
bind $td_ChooseBox <1> "td_chooseOK %y"
bind $td_ChooseBox <3> "td_chooseList %y"

set td_priv(choose) prepare

# }}}

if {! $td_priv(send)} {
    source $td_priv(debugdir)/TdDebug.tcl
    td_rescanProcs
} elseif {$td_priv(interp) != "<none>"} {
    td_rescanProcs
}   

# {{{ Emacs Local Variables


# Local Variables:
# folded-file: t
# End:

# }}}
