399 lines
8.9 KiB
Tcl
399 lines
8.9 KiB
Tcl
|
|
#----------------------------------------------------------------------
|
|
# Some generic utility functions
|
|
#
|
|
|
|
proc cmt args {}
|
|
proc Nop {} {}
|
|
|
|
proc setIfNew { var val } {
|
|
global $var
|
|
if ![info exists $var] {
|
|
set $var $val
|
|
}
|
|
}
|
|
|
|
proc crunch_skip args {}
|
|
|
|
crunch_skip begin
|
|
|
|
cmt {
|
|
proc o_push { v val } {
|
|
upvar 1 $v l
|
|
lappend l $val
|
|
}
|
|
proc o_pop v {
|
|
upvar 1 $v l
|
|
set tmp [lindex $l end]
|
|
catch {set l [lreplace $l end end]}
|
|
return $tmp
|
|
}
|
|
proc o_peek v {
|
|
upvar 1 $v l
|
|
return [lindex $l end]
|
|
}
|
|
}
|
|
|
|
crunch_skip end
|
|
|
|
proc lappendUniq { v val } {
|
|
upvar $v var
|
|
|
|
if { [lsearch $var $val] != -1 } { return }
|
|
lappend var $val
|
|
}
|
|
proc listMinus { a b } {
|
|
set ret {}
|
|
foreach i $a { set ArrA($i) 1 }
|
|
foreach i $b { set ArrB($i) 1 }
|
|
foreach i [array names ArrA] {
|
|
if ![info exists ArrB($i)] {
|
|
lappend ret $i
|
|
}
|
|
}
|
|
return $ret
|
|
}
|
|
|
|
#----------------------------------------------------------------------
|
|
#
|
|
# StrictMotif: Redefine look-and-feel to be more Motif like.
|
|
# This routine disables scrollbar from being pushed in (sunken),
|
|
# as well as sets the tk_strictMotif variable.
|
|
|
|
# `_otReferenceSBD' is only for string comparison with currently used routine.
|
|
# DO NOT ALTER IN ANY WAY!
|
|
#
|
|
set _otReferenceSBD {
|
|
global tkPriv
|
|
set tkPriv(relief) [$w cget -activerelief]
|
|
$w configure -activerelief sunken
|
|
set element [$w identify $x $y]
|
|
if {$element == "slider"} {
|
|
tkScrollStartDrag $w $x $y
|
|
} else {
|
|
tkScrollSelect $w $element initial
|
|
}
|
|
}
|
|
proc otTkScrollButtonDown {w x y} {
|
|
global tkPriv
|
|
set tkPriv(relief) [$w cget -activerelief]
|
|
set element [$w identify $x $y]
|
|
if [string compare "slider" $element] {
|
|
$w configure -activerelief sunken
|
|
tkScrollSelect $w $element initial
|
|
} else {
|
|
tkScrollStartDrag $w $x $y
|
|
}
|
|
}
|
|
|
|
proc StrictMotif {} {
|
|
global tk_version tk_strictMotif _otReferenceSBD
|
|
set tk_strictMotif 1
|
|
if { $tk_version == 4.0 ||
|
|
![string compare [info body tkScrollButtonDown] \
|
|
[set _otReferenceSBD]] } {
|
|
if [string compare "" [info procs otTkScrollButtonDown]] {
|
|
rename tkScrollButtonDown {}
|
|
rename otTkScrollButtonDown tkScrollButtonDown
|
|
}
|
|
}
|
|
}
|
|
|
|
proc dbputs s {}
|
|
|
|
# Dummy to allow crunched obtcl processing normal obTcl-scripts
|
|
proc DOC { name rest } {}
|
|
proc DOC_get_list {} {}
|
|
|
|
crunch_skip begin
|
|
|
|
setIfNew db_debug 0
|
|
proc db_debug {} {
|
|
global db_debug
|
|
set db_debug [expr !$db_debug]
|
|
}
|
|
proc dbputs s {
|
|
global db_debug
|
|
if { $db_debug != 0 } {
|
|
puts stderr $s
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------
|
|
# DOCS
|
|
|
|
setIfNew _uPriv_DOCS() ""
|
|
|
|
proc DOC_get_list {} {
|
|
global _uPriv_DOCS
|
|
return [array names _uPriv_DOCS]
|
|
}
|
|
|
|
proc DOC { name rest } {
|
|
global _uPriv_DOCS
|
|
set _uPriv_DOCS($name) $rest
|
|
}
|
|
|
|
proc PrDOCS {} {
|
|
global _uPriv_DOCS
|
|
set names [lsort [array names _uPriv_DOCS]]
|
|
foreach i $names {
|
|
puts "$_uPriv_DOCS($i)"
|
|
puts "----------------------------------------------------------------------"
|
|
}
|
|
}
|
|
proc GetDOCS {} {
|
|
global _uPriv_DOCS
|
|
set names [lsort [array names _uPriv_DOCS]]
|
|
set all ""
|
|
foreach i $names {
|
|
append all "$_uPriv_DOCS($i)"
|
|
append all "----------------------------------------------------------------------"
|
|
}
|
|
return $all
|
|
}
|
|
proc GetDOC name {
|
|
global _uPriv_DOCS
|
|
return $_uPriv_DOCS($name)
|
|
}
|
|
proc help args {
|
|
global _uPriv_DOCS
|
|
set names [lsort [array names _uPriv_DOCS "${args}*"]]
|
|
|
|
if { [llength $names] > 1 } {
|
|
puts "Select one of: "
|
|
set n 1
|
|
foreach i $names {
|
|
puts " ${n}) $i "
|
|
incr n 1
|
|
}
|
|
puts -nonewline ">> "
|
|
set answ [gets stdin]
|
|
append tmp [lindex $names [expr $answ-1]]
|
|
eval help $tmp
|
|
}
|
|
if { [llength $names] == 1 } {
|
|
eval set tmp $names
|
|
puts $_uPriv_DOCS($tmp)
|
|
}
|
|
if { [llength $names] < 1 } {
|
|
puts "No help on: $args"
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------
|
|
DOC "Tcl-debugger" {
|
|
|
|
NAME
|
|
Tcldb - A Tcl debugger
|
|
|
|
SYNOPSIS
|
|
bp ?ID?
|
|
|
|
DESCRIPTION
|
|
A simple debugger for Tcl-script. Breakpoints are set by calling
|
|
`bp' from your Tcl-code. Selecting where to break is done by
|
|
string-matching.
|
|
|
|
USAGE
|
|
Use by putting calls to `bp' in the Tcl-code. If `ID' is specified,
|
|
it will be displayed when the breakpoint is reached.
|
|
|
|
Example of using two breakpoints with different IDs:
|
|
|
|
func say { a } {
|
|
|
|
bp say_A
|
|
|
|
puts "You said: $a!"
|
|
|
|
bp say_B
|
|
}
|
|
|
|
Call `bpOff' to disable all breakpoints, `bpOn' to enable all,
|
|
`bpOn <funcname>' to enable breakpoints in functions matching
|
|
<funcname>, and finally `bpID <ID>' to enable breakpoints
|
|
matching <ID>. Matching is done according to Tcl's `string match'
|
|
function.
|
|
|
|
When in the break-point handler, type "?" for help.
|
|
|
|
ACKNOWLEDGEMENTS
|
|
This simple debugger is based on Stephen Uhler's article
|
|
"Debugging Tcl Scripts" from the Oct-95 issue of Linux Journal.
|
|
}
|
|
|
|
proc bpGetHelp {} {
|
|
puts stderr \
|
|
"------------------------------- Tcldb help ------------------------------------
|
|
|
|
Set breakpoints by adding calls to `bp' in your Tcl-code. Example:
|
|
|
|
bp Func1 ;# bp followed by the identifier `Func1'
|
|
|
|
Commands available when in `bp':
|
|
|
|
+ Move down in call-stack
|
|
- Move up in call stack
|
|
. Show current proc name and params
|
|
|
|
v Show names of variables currently in scope
|
|
V Show names and values of variables currently in scope
|
|
l Show names of variables that are local (transient)
|
|
L Show names and values of variables that are local (transient)
|
|
g Show names of variables that are declared global
|
|
G Show names and values of variables that are declared global
|
|
t Show a call chain trace, terse mode
|
|
T Show a call chain trace, verbose mode
|
|
|
|
b Show body of current proc
|
|
c Continue execution
|
|
h,? Print this help
|
|
|
|
You can also enter any Tcl command (even multi-line) and it will be
|
|
executed in the currently selected stack frame.
|
|
|
|
Available at any time:
|
|
|
|
bpOff Turn off all breakpoints
|
|
bpOn Turn on all breakpoints
|
|
bpOn <match>
|
|
Enable breakpoints in functions with names matching <match>
|
|
bpID <match>
|
|
Enable breakpoints whose ID matches <match>
|
|
"
|
|
}
|
|
setIfNew _bp_ON 1
|
|
setIfNew _bp_ID *
|
|
|
|
proc bpOn { {func 1} } { global _bp_ON _bp_ID; set _bp_ID *; set _bp_ON $func }
|
|
proc bpID id { global _bp_ON _bp_ID; set _bp_ON 1; set _bp_ID $id }
|
|
proc bpOff {} { global _bp_ON; set _bp_ON 0 }
|
|
|
|
proc bp args {
|
|
global _bp_ON _bp_ID
|
|
if { $_bp_ON == 0 } { return }
|
|
set max [expr [info level] - 1]
|
|
set current $max
|
|
set fName [lindex [info level $current] 0]
|
|
if { "$_bp_ON" == "1" || "$fName" == "$_bp_ON" || \
|
|
("$_bp_ON" == "top" && $current == 0) || \
|
|
[string match $_bp_ON $fName] } {
|
|
if ![string match $_bp_ID $args] {
|
|
return
|
|
}
|
|
} else {
|
|
return
|
|
}
|
|
bpShow VERBOSE $current
|
|
while {1} {
|
|
if { "$args" != "" } { puts "bp: $args" }
|
|
puts -nonewline stderr "#${current}:"
|
|
gets stdin line
|
|
while {![info complete $line]} {
|
|
puts -nonewline "> "
|
|
append line "\n[gets stdin]"
|
|
}
|
|
switch -- $line {
|
|
"+" {if {$current < $max} {bpShow VERBOSE [incr current]}}
|
|
"-" {if {$current > 0} {bpShow VERBOSE [incr current -1]}}
|
|
"b" {bpBody $current}
|
|
"c" {puts stderr "Continuing"; return}
|
|
"v" {bpVisibleVars NAMES $current}
|
|
"V" {bpVisibleVars VALUES $current}
|
|
"l" {bpLocalVars NAMES $current}
|
|
"L" {bpLocalVars VALUES $current}
|
|
"g" {bpGlobalVars NAMES $current}
|
|
"G" {bpGlobalVars VALUES $current}
|
|
"t" {bpTraceCalls TERSE $current}
|
|
"T" {bpTraceCalls VERBOSE $current}
|
|
"." {bpShow VERBOSE $current}
|
|
"h" -
|
|
"?" {bpGetHelp}
|
|
default {
|
|
catch {uplevel #$current $line } result
|
|
puts stderr $result
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc bpPrVar { level mode name } {
|
|
upvar #$level $name var
|
|
if { $mode == "NAMES" } {
|
|
puts " $name"
|
|
return
|
|
}
|
|
if { [array exists var] == 1 } {
|
|
puts " Array ${name} :"
|
|
foreach i [array names var] {
|
|
puts " ${name}($i) = [set var($i)]"
|
|
}
|
|
} else {
|
|
if {[info exists var] != 1 } {
|
|
puts " $name : Declared but uninitialized"
|
|
} else {
|
|
puts " $name = $var"
|
|
}
|
|
}
|
|
}
|
|
|
|
proc bpBody current {
|
|
uplevel #$current {
|
|
catch {puts [info body [lindex [info level [info level]] 0]]}
|
|
}
|
|
}
|
|
proc bpVisibleVars { mode curr } {
|
|
puts "#$curr visible vars:"
|
|
foreach i [uplevel #$curr {lsort [info vars]}] {
|
|
bpPrVar $curr $mode $i
|
|
}
|
|
}
|
|
proc bpLocalVars { mode curr } {
|
|
puts "#$curr local vars:"
|
|
foreach i [uplevel #$curr {lsort [info locals]}] {
|
|
bpPrVar $curr $mode $i
|
|
}
|
|
}
|
|
proc bpGlobalVars { mode curr } {
|
|
puts "#$curr global visible vars:"
|
|
set Vis [uplevel #$curr {info vars}]
|
|
set Loc [uplevel #$curr {info locals}]
|
|
foreach i [lsort [listMinus $Vis $Loc]] {
|
|
bpPrVar 0 $mode $i
|
|
}
|
|
|
|
}
|
|
proc bpTraceCalls { mode curr } {
|
|
for {set i 1} {$i <= $curr} {incr i} {
|
|
bpShow $mode $i
|
|
}
|
|
}
|
|
proc bpShow { mode curr } {
|
|
if { $curr > 0 } {
|
|
set info [info level $curr]
|
|
set proc [lindex $info 0]
|
|
if {"$mode" == "TERSE"} {
|
|
puts stderr "$curr: $proc [lrange $info 1 end]"
|
|
return
|
|
}
|
|
puts stderr "$curr: Proc= $proc \
|
|
{[info args $proc]}"
|
|
set idx 0
|
|
foreach arg [info args $proc] {
|
|
if { "$arg" == "args" } {
|
|
puts stderr "\t$arg = [lrange $info [incr idx] end]"
|
|
break;
|
|
} else {
|
|
puts stderr "\t$arg = [lindex $info [incr idx]]"
|
|
}
|
|
}
|
|
} else {
|
|
puts stderr "Top level"
|
|
}
|
|
}
|
|
|
|
crunch_skip end
|
|
|
|
|