# Copyright (C) 1992-2016 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 3 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., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, 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 { array element op } {

    upvar [set array]($element) avar

    switch -- $op {

	"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 ignored op } {

    upvar $v var

    switch -- $op {

	"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 watchpoint.

#

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 { } {

    # The w command is provided by the Tcl debugger.

    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

}