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, see <http://www.gnu.org/licenses/>.
  17
  18 # This file was written by Rob Savoye <rob@welcomehome.org>.
  19
  20 # Dump the values of a shell expression representing variable names.
  21 #
  22 proc dumpvars { args } {
  23     uplevel 1 [list foreach i [uplevel 1 "info vars $args"] {
  24         if { [catch "array names $i" names ] } {
  25             eval "puts \"$i = \$$i\""
  26         } else {
  27             foreach k $names {
  28                 eval "puts \"$i\($k\) = \$$i\($k\)\""
  29             }
  30         }
  31     }
  32               ]
  33 }
  34
  35 # Dump the values of a shell expression representing variable names.
  36 #
  37 proc dumplocals { args } {
  38     uplevel 1 [list foreach i [uplevel 1 "info locals $args"] {
  39         if { [catch "array names $i" names ] } {
  40             eval "puts \"${i} = \$${i}\""
  41         } else {
  42             foreach k $names {
  43                 eval "puts \"$i\($k\) = \$$i\($k\)\""
  44             }
  45         }
  46     }
  47               ]
  48 }
  49
  50 # Dump the body of procedures specified by a pattern.
  51 #
  52 proc dumprocs { args } {
  53     foreach i [info procs $args] {
  54         puts "\nproc $i \{ [info args $i] \} \{ [info body $i]\}"
  55     }
  56 }
  57
  58 # Dump all the current watchpoints.
  59 #
  60 proc dumpwatch { args } {
  61     foreach i [uplevel 1 "info vars $args"] {
  62         set tmp ""
  63         if { [catch "uplevel 1 array name $i" names] } {
  64             set tmp [uplevel 1 trace vinfo $i]
  65             if {$tmp ne ""} {
  66                 puts "$i $tmp"
  67             }
  68         } else {
  69             foreach k $names {
  70                 set tmp [uplevel 1 trace vinfo [set i]($k)]
  71                 if {$tmp ne ""} {
  72                     puts "[set i]($k) = $tmp"
  73                 }
  74             }
  75         }
  76     }
  77 }
  78
  79 # Trap a watchpoint for an array.
  80 #
  81 proc watcharray { array element op } {
  82     upvar [set array]($element) avar
  83     switch -- $op {
  84         "w" { puts "New value of [set array]($element) is $avar" }
  85         "r" { puts "[set array]($element) (= $avar) was just read" }
  86         "u" { puts "[set array]($element) (= $avar) was just unset" }
  87     }
  88 }
  89
  90 proc watchvar { v ignored op } {
  91     upvar $v var
  92     switch -- $op {
  93         "w" { puts "New value of $v is $var" }
  94         "r" { puts "$v (=$var) was just read" }
  95         "u" { puts "$v (=$var) was just unset" }
  96     }
  97 }
  98
  99 # Watch when a variable is written.
 100 #
 101 proc watchunset { arg } {
 102     if { [catch "uplevel 1 array name $arg" names ] } {
 103         if {![uplevel 1 info exists $arg]} {
 104             puts stderr "$arg does not exist"
 105             return
 106         }
 107         uplevel 1 trace variable $arg u watchvar
 108     } else {
 109         foreach k $names {
 110             if {![uplevel 1 info exists $arg]} {
 111                 puts stderr "$arg does not exist"
 112                 return
 113             }
 114             uplevel 1 trace variable [set arg]($k) u watcharray
 115         }
 116     }
 117 }
 118
 119 # Watch when a variable is written.
 120 #
 121 proc watchwrite { arg } {
 122     if { [catch "uplevel 1 array name $arg" names ] } {
 123         if {![uplevel 1 info exists $arg]} {
 124             puts stderr "$arg does not exist"
 125             return
 126         }
 127         uplevel 1 trace variable $arg w watchvar
 128     } else {
 129         foreach k $names {
 130             if {![uplevel 1 info exists $arg]} {
 131                 puts stderr "$arg does not exist"
 132                 return
 133             }
 134             uplevel 1 trace variable [set arg]($k) w watcharray
 135         }
 136     }
 137 }
 138
 139 # Watch when a variable is read.
 140 #
 141 proc watchread { arg } {
 142     if { [catch "uplevel 1 array name $arg" names ] } {
 143         if {![uplevel 1 info exists $arg]} {
 144             puts stderr "$arg does not exist"
 145             return
 146         }
 147         uplevel 1 trace variable $arg r watchvar
 148     } else {
 149         foreach k $names {
 150             if {![uplevel 1 info exists $arg]} {
 151                 puts stderr "$arg does not exist"
 152                 return
 153             }
 154             uplevel 1 trace variable [set arg]($k) r watcharray
 155         }
 156     }
 157 }
 158
 159 # Delete a watchpoint.
 160 #
 161 proc watchdel { args } {
 162     foreach i [uplevel 1 "info vars $args"] {
 163         set tmp ""
 164         if { [catch "uplevel 1 array name $i" names] } {
 165             catch "uplevel 1 trace vdelete $i w watchvar"
 166             catch "uplevel 1 trace vdelete $i r watchvar"
 167             catch "uplevel 1 trace vdelete $i u watchvar"
 168         } else {
 169             foreach k $names {
 170                 catch "uplevel 1 trace vdelete [set i]($k) w watcharray"
 171                 catch "uplevel 1 trace vdelete [set i]($k) r watcharray"
 172                 catch "uplevel 1 trace vdelete [set i]($k) u watcharray"
 173             }
 174         }
 175     }
 176 }
 177
 178 # This file creates GDB style commands for the Tcl debugger
 179 #
 180 proc print { var } {
 181     puts $var
 182 }
 183
 184 proc quit { } {
 185     log_and_exit
 186 }
 187
 188 proc bt { } {
 189     # The w command is provided by the Tcl debugger.
 190     puts "[w]"
 191 }
 192
 193 # Create some stub procedures since we can't alias the command names.
 194 #
 195 proc dp { args } {
 196     uplevel 1 dumprocs $args
 197 }
 198
 199 proc dv { args } {
 200     uplevel 1 dumpvars $args
 201 }
 202
 203 proc dl { args } {
 204     uplevel 1 dumplocals $args
 205 }
 206
 207 proc dw { args } {
 208     uplevel 1 dumpwatch $args
 209 }
 210
 211 proc q { } {
 212     quit
 213 }
 214
 215 proc p { args } {
 216     uplevel 1 print $args
 217 }
 218
 219 proc wu { args } {
 220     uplevel 1 watchunset $args
 221 }
 222
 223 proc ww { args } {
 224     uplevel 1 watchwrite $args
 225 }
 226
 227 proc wr { args } {
 228     uplevel 1 watchread $args
 229 }
 230
 231 proc wd { args } {
 232     uplevel 1 watchdel $args
 233 }