| # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, |
| # 2001, 2002, 2003 Free Software Foundation, Inc. |
| # |
| # This file is part of DejaGnu. |
| # |
| # DejaGnu 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. |
| # |
| # DejaGnu 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 DejaGnu; if not, write to the Free Software Foundation, |
| # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| |
| # This file was written by Rob Savoye. (rob@welcomehome.org) |
| |
| # |
| # Dump the values of a shell expression representing variable |
| # names. |
| proc dumpvars { args } { |
| uplevel 1 [list foreach i [uplevel 1 "info vars $args"] { |
| if { [catch "array names $i" names ] } { |
| eval "puts \"${i} = \$${i}\"" |
| } else { |
| foreach k $names { |
| eval "puts \"$i\($k\) = \$$i\($k\)\"" |
| } |
| } |
| } |
| ] |
| } |
| |
| # |
| # dump the values of a shell expression representing variable |
| # names. |
| proc dumplocals { args } { |
| uplevel 1 [list foreach i [uplevel 1 "info locals $args"] { |
| if { [catch "array names $i" names ] } { |
| eval "puts \"${i} = \$${i}\"" |
| } else { |
| foreach k $names { |
| eval "puts \"$i\($k\) = \$$i\($k\)\"" |
| } |
| } |
| } |
| ] |
| } |
| # |
| # Dump the body of procedures specified by a regexp. |
| # |
| proc dumprocs { args } { |
| foreach i [info procs $args] { |
| puts "\nproc $i \{ [info args $i] \} \{ [info body $i]\}" |
| } |
| } |
| |
| # |
| # Dump all the current watchpoints |
| # |
| proc dumpwatch { args } { |
| foreach i [uplevel 1 "info vars $args"] { |
| set tmp "" |
| if { [catch "uplevel 1 array name $i" names] } { |
| set tmp [uplevel 1 trace vinfo $i] |
| if ![string match "" $tmp] { |
| puts "$i $tmp" |
| } |
| } else { |
| foreach k $names { |
| set tmp [uplevel 1 trace vinfo [set i]($k)] |
| if ![string match "" $tmp] { |
| puts "[set i]($k) = $tmp" |
| } |
| } |
| } |
| } |
| } |
| |
| # |
| # Trap a watchpoint for an array |
| # |
| proc watcharray { element type} { |
| upvar [set array]($element) avar |
| case $type { |
| "w" { puts "New value of [set array]($element) is $avar" } |
| "r" { puts "[set array]($element) (= $avar) was just read" } |
| "u" { puts "[set array]($element) (= $avar) was just unset" } |
| } |
| } |
| |
| proc watchvar { v type } { |
| upvar $v var |
| case $type { |
| "w" { puts "New value of $v is $var" } |
| "r" { puts "$v (=$var) was just read" } |
| "u" { puts "$v (=$var) was just unset" } |
| } |
| } |
| |
| # |
| # Watch when a variable is written |
| # |
| proc watchunset { arg } { |
| if { [catch "uplevel 1 array name $arg" names ] } { |
| if ![uplevel 1 info exists $arg] { |
| puts stderr "$arg does not exist" |
| return |
| } |
| uplevel 1 trace variable $arg u watchvar |
| } else { |
| foreach k $names { |
| if ![uplevel 1 info exists $arg] { |
| puts stderr "$arg does not exist" |
| return |
| } |
| uplevel 1 trace variable [set arg]($k) u watcharray |
| } |
| } |
| } |
| |
| # |
| # Watch when a variable is written |
| # |
| proc watchwrite { arg } { |
| if { [catch "uplevel 1 array name $arg" names ] } { |
| if ![uplevel 1 info exists $arg] { |
| puts stderr "$arg does not exist" |
| return |
| } |
| uplevel 1 trace variable $arg w watchvar |
| } else { |
| foreach k $names { |
| if ![uplevel 1 info exists $arg] { |
| puts stderr "$arg does not exist" |
| return |
| } |
| uplevel 1 trace variable [set arg]($k) w watcharray |
| } |
| } |
| } |
| |
| # |
| # Watch when a variable is read |
| # |
| proc watchread { arg } { |
| if { [catch "uplevel 1 array name $arg" names ] } { |
| if ![uplevel 1 info exists $arg] { |
| puts stderr "$arg does not exist" |
| return |
| } |
| uplevel 1 trace variable $arg r watchvar |
| } else { |
| foreach k $names { |
| if ![uplevel 1 info exists $arg] { |
| puts stderr "$arg does not exist" |
| return |
| } |
| uplevel 1 trace variable [set arg]($k) r watcharray |
| } |
| } |
| } |
| |
| # |
| # Delete a watch point |
| # |
| proc watchdel { args } { |
| foreach i [uplevel 1 "info vars $args"] { |
| set tmp "" |
| if { [catch "uplevel 1 array name $i" names] } { |
| catch "uplevel 1 trace vdelete $i w watchvar" |
| catch "uplevel 1 trace vdelete $i r watchvar" |
| catch "uplevel 1 trace vdelete $i u watchvar" |
| } else { |
| foreach k $names { |
| catch "uplevel 1 trace vdelete [set i]($k) w watcharray" |
| catch "uplevel 1 trace vdelete [set i]($k) r watcharray" |
| catch "uplevel 1 trace vdelete [set i]($k) u watcharray" |
| } |
| } |
| } |
| } |
| |
| # |
| # This file creates GDB style commands for the Tcl debugger |
| # |
| proc print { var } { |
| puts "$var" |
| } |
| |
| proc quit { } { |
| log_and_exit |
| } |
| |
| proc bt { } { |
| puts "[w]" |
| } |
| |
| # |
| # create some stub procedures since we can't alias the command names |
| # |
| proc dp { args } { |
| uplevel 1 dumprocs $args |
| } |
| |
| proc dv { args } { |
| uplevel 1 dumpvars $args |
| } |
| |
| proc dl { args } { |
| uplevel 1 dumplocals $args |
| } |
| |
| proc dw { args } { |
| uplevel 1 dumpwatch $args |
| } |
| |
| proc q { } { |
| quit |
| } |
| |
| proc p { args } { |
| uplevel 1 print $args |
| } |
| |
| proc wu { args } { |
| uplevel 1 watchunset $args |
| } |
| |
| proc ww { args } { |
| uplevel 1 watchwrite $args |
| } |
| |
| proc wr { args } { |
| uplevel 1 watchread $args |
| } |
| |
| proc wd { args } { |
| uplevel 1 watchdel $args |
| } |