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#
23proc 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#
38proc 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#
53proc 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#
61proc 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#
82proc 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
91proc 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#
102proc 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#
122proc 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#
142proc 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#
162proc 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#
181proc print { var } {
182    puts $var
183}
184
185proc quit { } {
186    log_and_exit
187}
188
189proc 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#
196proc dp { args } {
197    uplevel 1 dumprocs $args
198}
199
200proc dv { args } {
201    uplevel 1 dumpvars $args
202}
203
204proc dl { args } {
205    uplevel 1 dumplocals $args
206}
207
208proc dw { args } {
209    uplevel 1 dumpwatch $args
210}
211
212proc q { } {
213    quit
214}
215
216proc p { args } {
217    uplevel 1 print $args
218}
219
220proc wu { args } {
221    uplevel 1 watchunset $args
222}
223
224proc ww { args } {
225    uplevel 1 watchwrite $args
226}
227
228proc wr { args } {
229    uplevel 1 watchread $args
230}
231
232proc wd { args } {
233    uplevel 1 watchdel $args
234}
235