gdb/testsuite/lib/selftest-support.exp

   1 # Copyright 2003-2021 Free Software Foundation, Inc.
   2
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 3 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 # Find a pathname to a file that we would execute if the shell was asked
  17 # to run $arg using the current PATH.
  18
  19 proc find_gdb { arg } {
  20
  21     # If the arg directly specifies an existing executable file, then
  22     # simply use it.
  23
  24     if [file executable $arg] then {
  25         return $arg
  26     }
  27
  28     set result [which $arg]
  29     if [string match "/" [ string range $result 0 0 ]] then {
  30         return $result
  31     }
  32
  33     # If everything fails, just return the unqualified pathname as default
  34     # and hope for best.
  35
  36     return $arg
  37 }
  38
  39 # A helper proc that sets up for self-testing.
  40 # EXECUTABLE is the gdb to use.
  41 # FUNCTION is the function to break in, either captured_main
  42 # or captured_command_loop.
  43 # Return 0 in case of success, -1 in case of failure, and -2 in case of
  44 # skipping the test-case.
  45
  46 proc selftest_setup { executable function } {
  47     global gdb_prompt
  48     global timeout
  49     global INTERNAL_GDBFLAGS
  50
  51     # load yourself into the debugger
  52     # This can take a relatively long time, particularly for testing where
  53     # the executable is being accessed over a network, or where gdb does not
  54     # support partial symbols for a particular target and has to load the
  55     # entire symbol table.  Set the timeout to 10 minutes, which should be
  56     # adequate for most environments (it *has* timed out with 5 min on a
  57     # SPARCstation SLC under moderate load, so this isn't unreasonable).
  58     # After gdb is started, set the timeout to 30 seconds for the duration
  59     # of this test, and then back to the original value.
  60
  61     set oldtimeout $timeout
  62     set timeout 600
  63     verbose "Timeout is now $timeout seconds" 2
  64
  65     global gdb_file_cmd_debug_info
  66     set gdb_file_cmd_debug_info "unset"
  67
  68     set result [gdb_load $executable]
  69     set timeout $oldtimeout
  70     verbose "Timeout is now $timeout seconds" 2
  71
  72     if { $result != 0 } then {
  73         return -1
  74     }
  75
  76     if { $gdb_file_cmd_debug_info != "debug" } then {
  77         untested "no debug information, skipping testcase."
  78         return -2
  79     }
  80
  81     # Set a breakpoint at $function.
  82     if { [gdb_breakpoint $function "no-message"] != 1 } {
  83         untested "Cannot set breakpoint at $function, skipping testcase."
  84         return -2
  85     }
  86
  87     # run yourself
  88     # It may take a very long time for the inferior gdb to start (lynx),
  89     # so we bump it back up for the duration of this command.
  90     set timeout 600
  91
  92     set description "run until breakpoint at $function"
  93     gdb_test_multiple "run $INTERNAL_GDBFLAGS" "$description" {
  94         -re "Starting program.*Breakpoint \[0-9\]+,.*$function \\(.*\\).* at .*main.c:.*$gdb_prompt $" {
  95             pass "$description"
  96         }
  97         -re "Starting program.*Breakpoint \[0-9\]+,.*$function \\(.*\\).*$gdb_prompt $" {
  98             xfail "$description (line numbers scrambled?)"
  99         }
 100         -re "vfork: No more processes.*$gdb_prompt $" {
 101             fail "$description (out of virtual memory)"
 102             set timeout $oldtimeout
 103             verbose "Timeout is now $timeout seconds" 2
 104             return -1
 105         }
 106         -re ".*$gdb_prompt $" {
 107             fail "$description"
 108             set timeout $oldtimeout
 109             verbose "Timeout is now $timeout seconds" 2
 110             return -1
 111         }
 112     }
 113
 114     set timeout $oldtimeout
 115     verbose "Timeout is now $timeout seconds" 2
 116
 117     return 0
 118 }
 119
 120 # A simple way to run some self-tests.
 121
 122 proc do_self_tests {function body} {
 123     global GDB tool
 124
 125     # Are we testing with a remote board?  In that case, the target
 126     # won't have access to the GDB's auxilliary data files
 127     # (data-directory, etc.).  It's simpler to just skip.
 128     if [is_remote target] {
 129         return
 130     }
 131
 132     # ... or seemingly testing with a cross debugger?  Likely GDB
 133     # wouldn't be able to debug itself then...
 134     if ![isnative] {
 135         return
 136     }
 137
 138     # ... or with a stub-like server?  I.e., gdbserver + "target
 139     # remote"?  In that case we won't be able to pass command line
 140     # arguments to GDB, and selftest_setup wants to do exactly that.
 141     if [use_gdb_stub] {
 142         return
 143     }
 144
 145     # Run the test with self.  Copy the file executable file in case
 146     # this OS doesn't like to edit its own text space.
 147
 148     set GDB_FULLPATH [find_gdb $GDB]
 149
 150     if {[is_remote host]} {
 151         set xgdb x$tool
 152     } else {
 153         set xgdb [standard_output_file x$tool]
 154     }
 155
 156     # Remove any old copy lying around.
 157     remote_file host delete $xgdb
 158
 159     gdb_start
 160     set file [remote_download host $GDB_FULLPATH $xgdb]
 161
 162     set result [selftest_setup $file $function]
 163     if {$result == 0} then {
 164         set result [uplevel $body]
 165     }
 166
 167     gdb_exit
 168     catch "remote_file host delete $file"
 169
 170     if {$result == -1} then {
 171         warning "Couldn't test self"
 172     }
 173 }