+# Run BODY in the context of the caller. After BODY is run, the variables
+# listed in VARS will be reset to the values they had before BODY was run.
+#
+# This is useful for providing a scope in which it is safe to temporarily
+# modify global variables, e.g.
+#
+# global INTERNAL_GDBFLAGS
+# global env
+#
+# set foo GDBHISTSIZE
+#
+# save_vars { INTERNAL_GDBFLAGS env($foo) env(HOME) } {
+# append INTERNAL_GDBFLAGS " -nx"
+# unset -nocomplain env(GDBHISTSIZE)
+# gdb_start
+# gdb_test ...
+# }
+#
+# Here, although INTERNAL_GDBFLAGS, env(GDBHISTSIZE) and env(HOME) may be
+# modified inside BODY, this proc guarantees that the modifications will be
+# undone after BODY finishes executing.
+
+proc save_vars { vars body } {
+ array set saved_scalars { }
+ array set saved_arrays { }
+ set unset_vars { }
+
+ foreach var $vars {
+ # First evaluate VAR in the context of the caller in case the variable
+ # name may be a not-yet-interpolated string like env($foo)
+ set var [uplevel 1 list $var]
+
+ if [uplevel 1 [list info exists $var]] {
+ if [uplevel 1 [list array exists $var]] {
+ set saved_arrays($var) [uplevel 1 [list array get $var]]
+ } else {
+ set saved_scalars($var) [uplevel 1 [list set $var]]
+ }
+ } else {
+ lappend unset_vars $var
+ }
+ }
+
+ set code [catch {uplevel 1 $body} result]
+
+ foreach {var value} [array get saved_scalars] {
+ uplevel 1 [list set $var $value]
+ }
+
+ foreach {var value} [array get saved_arrays] {
+ uplevel 1 [list unset $var]
+ uplevel 1 [list array set $var $value]
+ }
+
+ foreach var $unset_vars {
+ uplevel 1 [list unset -nocomplain $var]
+ }
+
+ if {$code == 1} {
+ global errorInfo errorCode
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
+ } else {
+ return -code $code $result
+ }
+}
+
+
+# Run tests in BODY with GDB prompt and variable $gdb_prompt set to
+# PROMPT. When BODY is finished, restore GDB prompt and variable
+# $gdb_prompt.
+# Returns the result of BODY.
+#
+# Notes:
+#
+# 1) If you want to use, for example, "(foo)" as the prompt you must pass it
+# as "(foo)", and not the regexp form "\(foo\)" (expressed as "\\(foo\\)" in
+# TCL). PROMPT is internally converted to a suitable regexp for matching.
+# We do the conversion from "(foo)" to "\(foo\)" here for a few reasons:
+# a) It's more intuitive for callers to pass the plain text form.
+# b) We need two forms of the prompt:
+# - a regexp to use in output matching,
+# - a value to pass to the "set prompt" command.
+# c) It's easier to convert the plain text form to its regexp form.
+#
+# 2) Don't add a trailing space, we do that here.
+
+proc with_gdb_prompt { prompt body } {
+ global gdb_prompt
+
+ # Convert "(foo)" to "\(foo\)".
+ # We don't use string_to_regexp because while it works today it's not
+ # clear it will work tomorrow: the value we need must work as both a
+ # regexp *and* as the argument to the "set prompt" command, at least until
+ # we start recording both forms separately instead of just $gdb_prompt.
+ # The testsuite is pretty-much hardwired to interpret $gdb_prompt as the
+ # regexp form.
+ regsub -all {[]*+.|()^$\[\\]} $prompt {\\&} prompt
+
+ set saved $gdb_prompt
+
+ verbose -log "Setting gdb prompt to \"$prompt \"."
+ set gdb_prompt $prompt
+ gdb_test_no_output "set prompt $prompt " ""
+
+ set code [catch {uplevel 1 $body} result]
+
+ verbose -log "Restoring gdb prompt to \"$saved \"."
+ set gdb_prompt $saved
+ gdb_test_no_output "set prompt $saved " ""
+
+ if {$code == 1} {
+ global errorInfo errorCode
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
+ } else {
+ return -code $code $result
+ }
+}
+
+# Run tests in BODY with target-charset setting to TARGET_CHARSET. When
+# BODY is finished, restore target-charset.
+
+proc with_target_charset { target_charset body } {
+ global gdb_prompt
+
+ set saved ""
+ gdb_test_multiple "show target-charset" "" {
+ -re "The target character set is \".*; currently (.*)\"\..*$gdb_prompt " {
+ set saved $expect_out(1,string)
+ }
+ -re "The target character set is \"(.*)\".*$gdb_prompt " {
+ set saved $expect_out(1,string)
+ }
+ -re ".*$gdb_prompt " {
+ fail "get target-charset"
+ }
+ }
+
+ gdb_test_no_output "set target-charset $target_charset" ""
+
+ set code [catch {uplevel 1 $body} result]
+
+ gdb_test_no_output "set target-charset $saved" ""
+
+ if {$code == 1} {
+ global errorInfo errorCode
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
+ } else {
+ return -code $code $result
+ }
+}
+
+# Select the largest timeout from all the timeouts:
+# - the local "timeout" variable of the scope two levels above,
+# - the global "timeout" variable,
+# - the board variable "gdb,timeout".
+
+proc get_largest_timeout {} {
+ upvar #0 timeout gtimeout
+ upvar 2 timeout timeout
+
+ set tmt 0
+ if [info exists timeout] {
+ set tmt $timeout
+ }
+ if { [info exists gtimeout] && $gtimeout > $tmt } {
+ set tmt $gtimeout
+ }
+ if { [target_info exists gdb,timeout]
+ && [target_info gdb,timeout] > $tmt } {
+ set tmt [target_info gdb,timeout]
+ }
+ if { $tmt == 0 } {
+ # Eeeeew.
+ set tmt 60
+ }
+
+ return $tmt
+}
+
+# Run tests in BODY with timeout increased by factor of FACTOR. When
+# BODY is finished, restore timeout.
+
+proc with_timeout_factor { factor body } {
+ global timeout
+
+ set savedtimeout $timeout
+
+ set timeout [expr [get_largest_timeout] * $factor]
+ set code [catch {uplevel 1 $body} result]
+
+ set timeout $savedtimeout
+ if {$code == 1} {
+ global errorInfo errorCode
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
+ } else {
+ return -code $code $result
+ }
+}
+