lib/debugger.exp

   1 # Copyright (C) 1992-2019, 2020 Free Software Foundation, Inc.
   2 #
   3 # This file is part of DejaGnu.
   4 #
   5 # DejaGnu is free software; you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # DejaGnu is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with DejaGnu; if not, write to the Free Software Foundation,
  17 # Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA.
  18
  19 # This file was written by Rob Savoye <rob@welcomehome.org>.
  20
  21 # Dump the values of a shell expression representing variable names.
  22 #
  23 proc dumpvars { args } {
  24     uplevel 1 [list foreach i [uplevel 1 "info vars $args"] {
  25         if { [catch "array names $i" names ] } {
  26             eval "puts \"$i = \$$i\""
  27         } else {
  28             foreach k $names {
  29                 eval "puts \"$i\($k\) = \$$i\($k\)\""
  30             }
  31         }
  32     }
  33               ]
  34 }
  35
  36 # Dump the values of a shell expression representing variable names.
  37 #
  38 proc dumplocals { args } {
  39     uplevel 1 [list foreach i [uplevel 1 "info locals $args"] {
  40         if { [catch "array names $i" names ] } {
  41             eval "puts \"${i} = \$${i}\""
  42         } else {
  43             foreach k $names {
  44                 eval "puts \"$i\($k\) = \$$i\($k\)\""
  45             }
  46         }
  47     }
  48               ]
  49 }
  50
  51 # Dump the body of procedures specified by a pattern.
  52 #
  53 proc dumprocs { args } {
  54     foreach i [info procs $args] {
  55         puts "\nproc $i \{ [info args $i] \} \{ [info body $i]\}"
  56     }
  57 }
  58
  59 # Dump all the current watchpoints.
  60 #
  61 proc dumpwatch { args } {
  62     foreach i [uplevel 1 "info vars $args"] {
  63         set tmp ""
  64         if { [catch "uplevel 1 array name $i" names] } {
  65             set tmp [uplevel 1 trace vinfo $i]
  66             if {$tmp ne ""} {
  67                 puts "$i $tmp"
  68             }
  69         } else {
  70             foreach k $names {
  71                 set tmp [uplevel 1 trace vinfo [set i]($k)]
  72                 if {$tmp ne ""} {
  73                     puts "[set i]($k) = $tmp"
  74                 }
  75             }
  76         }
  77     }
  78 }
  79
  80 # Trap a watchpoint for an array.
  81 #
  82 proc watcharray { array element op } {
  83     upvar [set array]($element) avar
  84     switch -- $op {
  85         "w" { puts "New value of [set array]($element) is $avar" }
  86         "r" { puts "[set array]($element) (= $avar) was just read" }
  87         "u" { puts "[set array]($element) (= $avar) was just unset" }
  88     }
  89 }
  90
  91 proc watchvar { v ignored op } {
  92     upvar $v var
  93     switch -- $op {
  94         "w" { puts "New value of $v is $var" }
  95         "r" { puts "$v (=$var) was just read" }
  96         "u" { puts "$v (=$var) was just unset" }
  97     }
  98 }
  99
 100 # Watch when a variable is written.
 101 #
 102 proc watchunset { arg } {
 103     if { [catch "uplevel 1 array name $arg" names ] } {
 104         if {![uplevel 1 info exists $arg]} {
 105             puts stderr "$arg does not exist"
 106             return
 107         }
 108         uplevel 1 trace variable $arg u watchvar
 109     } else {
 110         foreach k $names {
 111             if {![uplevel 1 info exists $arg]} {
 112                 puts stderr "$arg does not exist"
 113                 return
 114             }
 115             uplevel 1 trace variable [set arg]($k) u watcharray
 116         }
 117     }
 118 }
 119
 120 # Watch when a variable is written.
 121 #
 122 proc watchwrite { arg } {
 123     if { [catch "uplevel 1 array name $arg" names ] } {
 124         if {![uplevel 1 info exists $arg]} {
 125             puts stderr "$arg does not exist"
 126             return
 127         }
 128         uplevel 1 trace variable $arg w watchvar
 129     } else {
 130         foreach k $names {
 131             if {![uplevel 1 info exists $arg]} {
 132                 puts stderr "$arg does not exist"
 133                 return
 134             }
 135             uplevel 1 trace variable [set arg]($k) w watcharray
 136         }
 137     }
 138 }
 139
 140 # Watch when a variable is read.
 141 #
 142 proc watchread { arg } {
 143     if { [catch "uplevel 1 array name $arg" names ] } {
 144         if {![uplevel 1 info exists $arg]} {
 145             puts stderr "$arg does not exist"
 146             return
 147         }
 148         uplevel 1 trace variable $arg r watchvar
 149     } else {
 150         foreach k $names {
 151             if {![uplevel 1 info exists $arg]} {
 152                 puts stderr "$arg does not exist"
 153                 return
 154             }
 155             uplevel 1 trace variable [set arg]($k) r watcharray
 156         }
 157     }
 158 }
 159
 160 # Delete a watchpoint.
 161 #
 162 proc watchdel { args } {
 163     foreach i [uplevel 1 "info vars $args"] {
 164         set tmp ""
 165         if { [catch "uplevel 1 array name $i" names] } {
 166             catch "uplevel 1 trace vdelete $i w watchvar"
 167             catch "uplevel 1 trace vdelete $i r watchvar"
 168             catch "uplevel 1 trace vdelete $i u watchvar"
 169         } else {
 170             foreach k $names {
 171                 catch "uplevel 1 trace vdelete [set i]($k) w watcharray"
 172                 catch "uplevel 1 trace vdelete [set i]($k) r watcharray"
 173                 catch "uplevel 1 trace vdelete [set i]($k) u watcharray"
 174             }
 175         }
 176     }
 177 }
 178
 179 # This file creates GDB style commands for the Tcl debugger
 180 #
 181 proc print { var } {
 182     puts $var
 183 }
 184
 185 proc quit { } {
 186     log_and_exit
 187 }
 188
 189 proc bt { } {
 190     # The w command is provided by the Tcl debugger.
 191     puts "[w]"
 192 }
 193
 194 # Create some stub procedures since we can't alias the command names.
 195 #
 196 proc dp { args } {
 197     uplevel 1 dumprocs $args
 198 }
 199
 200 proc dv { args } {
 201     uplevel 1 dumpvars $args
 202 }
 203
 204 proc dl { args } {
 205     uplevel 1 dumplocals $args
 206 }
 207
 208 proc dw { args } {
 209     uplevel 1 dumpwatch $args
 210 }
 211
 212 proc q { } {
 213     quit
 214 }
 215
 216 proc p { args } {
 217     uplevel 1 print $args
 218 }
 219
 220 proc wu { args } {
 221     uplevel 1 watchunset $args
 222 }
 223
 224 proc ww { args } {
 225     uplevel 1 watchwrite $args
 226 }
 227
 228 proc wr { args } {
 229     uplevel 1 watchread $args
 230 }
 231
 232 proc wd { args } {
 233     uplevel 1 watchdel $args
 234 }