gdb/testsuite/gdb.gdbtk/defs

   1 # This file contains support code for the gdbtk test suite.
   2 # Copyright 2001 Red Hat, Inc.
   3 #
   4 # Based on the Tcl testsuite support code, portions of this file
   5 # are Copyright (c) 1990-1994 The Regents of the University of California and
   6 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
   7 #
   8 global _test env srcdir objdir
   9
  10 if {![info exists srcdir]} {
  11   if {[info exists env(SRCDIR)]} {
  12     set srcdir $env(SRCDIR)
  13   } else {
  14     set srcdir .
  15   }
  16 }
  17
  18 if {![info exists objdir]} {
  19   if {[info exists env(OBJDIR)]} {
  20     set objdir $env(OBJDIR)
  21   } elseif {$_test(interactive)} {
  22     # If running interactively, assume that the objdir is
  23     # relative to the executable's location
  24     set objdir [file join [file dirname [info nameofexecutable]] testsuite gdb.gdbtk]
  25   } else {
  26     set objdir .
  27   }
  28 }
  29
  30 if {![info exists _test(verbose)]} {
  31   if {[info exists env(GDBTK_VERBOSE)]} {
  32     set _test(verbose) $env(GDBTK_VERBOSE)
  33   } else {
  34     set _test(verbose) 0
  35   }
  36 }
  37 if {![info exists _test(tests)]} {
  38
  39   if {[info exists env(GDBTK_TESTS)]} {
  40     set _test(tests) $env(GDBTK_TESTS)
  41   } else {
  42     set _test(tests) {}
  43   }
  44 }
  45
  46 if {[info exists env(GDBTK_LOGFILE)]} {
  47   set _test(logfile) [open $env(GDBTK_LOGFILE) a+]
  48   fconfigure $_test(logfile) -buffering none
  49 } else {
  50   set _test(logfile) {}
  51 }
  52
  53 # Informs gdbtk internals that testsuite is running. An example
  54 # where this is needed is the window manager, which must place
  55 # all windows at some place on the screen so that the system's
  56 # window manager does not interfere. This is reset in gdbtk_test_done.
  57 set env(GDBTK_TEST_RUNNING) 1
  58
  59 # The gdb "file" command to use for gdbtk testing
  60 # NOTE: This proc appends ".exe" to all windows' programs
  61 proc gdbtk_test_file {filename} {
  62   global tcl_platform
  63
  64   if {$tcl_platform(platform) == "windows"} {
  65     append filename ".exe"
  66   }
  67
  68   set err [catch {gdb_cmd "file $filename" 1} text]
  69   if {$err} {
  70     error $text
  71   }
  72
  73   return $text
  74 }
  75
  76 proc gdbtk_test_run {{prog_args {}}} {
  77   global env
  78
  79   # Get the target_info array from the testsuite
  80   array set target_info $env(TARGET_INFO)
  81
  82   # We get the target ready by:
  83   # 1. Run all init commands
  84   # 2. Issue target command
  85   # 3. Issue load command
  86   # 4. Issue run command
  87   foreach cmd $target_info(init) {
  88     set err [catch {gdb_cmd $cmd 0} txt]
  89     if {$err} {
  90       _report_error "Target initialization command \"$cmd\" failed: $txt"
  91       return 0
  92     }
  93   }
  94
  95   if {$target_info(target) != ""} {
  96     set err [catch {gdb_cmd $target_info(target) 0} txt]
  97     if {$err} {
  98       _report_error "Failed to connect to target: $txt"
  99       return 0
 100     }
 101   }
 102
 103   if {$target_info(load) != ""} {
 104     set err [catch {gdb_cmd $target_info(load) 0} txt]
 105     if {$err} {
 106       _report_error "Failed to load: $txt"
 107       return 0
 108     }
 109   }
 110
 111   if {$target_info(run) != ""} {
 112     set err [catch {gdb_cmd $target_info(run) 0} txt]
 113     if {$err} {
 114       _report_error "Could not run target with \"$target_info(run)\": $txt"
 115       return 0
 116     }
 117   }
 118
 119   return 1
 120 }
 121
 122 proc _report_error {msg} {
 123   global _test
 124
 125   if {[info exists _test(interactive)] && $_test(interactive)} {
 126     # Dialog
 127     tk_messageBox -message $msg -icon error -type ok
 128   } else {
 129     # to stderr
 130     puts stderr $msg
 131   }
 132 }
 133
 134 proc gdbtk_print_verbose {status name description script code answer} {
 135   global _test
 136
 137   switch $code {
 138     0 {
 139       set code_words {}
 140     }
 141     1 {
 142       set code_words "Test generated error: $answer"
 143     }
 144
 145     2 {
 146       set code_words "Test generated return exception;  result was: $answer"
 147     }
 148
 149     3 {
 150       set code_words "Test generated break exception"
 151     }
 152
 153     4 {
 154       set code_words "Test generated continue exception"
 155     }
 156
 157     5 {
 158       set code_words "Test generated exception $code;  message was:$answer"
 159     }
 160   }
 161
 162   if {$_test(verbose) > 1 \
 163         || ($_test(verbose) != 1 && ($status == "ERROR" || $status == "FAIL"))} {
 164     # Printed when user verbose mode (verbose > 1) or an error/failure occurs
 165     # not running the testsuite (dejagnu)
 166     puts stdout "\n"
 167     puts stdout "==== $name $description"
 168     puts stdout "==== Contents of test case:"
 169     puts stdout "$script"
 170     if {$code_words != ""} {
 171       puts stdout $code_words
 172     }
 173     puts stdout "==== Result was:"
 174     puts stdout "$answer"
 175   } elseif {$_test(verbose)} {
 176     # Printed for the testsuite (verbose = 1)
 177     puts stdout "[list $status $name $description $code_words]"
 178
 179     if {$_test(logfile) != ""} {
 180       puts $_test(logfile) "\n"
 181       puts $_test(logfile) "==== $name $description"
 182       puts $_test(logfile) "==== Contents of test case:"
 183       puts $_test(logfile) "$script"
 184       if {$code_words != ""} {
 185         puts $_test(logfile) $code_words
 186       }
 187       puts $_test(logfile) "==== Result was:"
 188       puts $_test(logfile) "$answer"
 189     }
 190   }
 191 }
 192
 193 # gdbtk_test
 194 #
 195 # This procedure runs a test and prints an error message if the
 196 # test fails.
 197 #
 198 # Arguments:
 199 # name -                Name of test, in the form foo-1.2.
 200 # description -         Short textual description of the test, to
 201 #                       help humans understand what it does.
 202 # script -              Script to run to carry out the test.  It must
 203 #                       return a result that can be checked for
 204 #                       correctness.
 205 # answer -              Expected result from script.
 206
 207 proc gdbtk_test {name description script answer} {
 208   global _test test_ran
 209
 210   set test_ran 0
 211   if {[string compare $_test(tests) ""] != 0} then {
 212     set ok 0
 213     foreach test $_test(tests) {
 214       if [string match $test $name] then {
 215         set ok 1
 216         break
 217       }
 218     }
 219     if !$ok then return
 220   }
 221
 222   set code [catch {uplevel $script} result]
 223   set test_ran 1
 224   if {$code != 0} {
 225     # Error
 226     gdbtk_print_verbose ERROR $name $description $script \
 227       $code $result
 228   } elseif {[string compare $result $answer] == 0} {
 229     if {[string index $name 0] == "*"} {
 230       # XPASS
 231       set HOW XPASS
 232     } else {
 233       set HOW PASS
 234     }
 235
 236     if {$_test(verbose)} {
 237       gdbtk_print_verbose $HOW $name $description $script \
 238         $code $result
 239       if {$_test(verbose) != 1} {
 240         puts stdout "++++ $name ${HOW}ED"
 241       }
 242     }
 243     if {$_test(logfile) != ""} {
 244       puts $_test(logfile) "++++ $name ${HOW}ED"
 245     }
 246   } else {
 247     if {[string index $name 0] == "*"} {
 248       # XFAIL
 249       set HOW XFAIL
 250     } else {
 251       set HOW FAIL
 252     }
 253
 254     gdbtk_print_verbose $HOW $name $description $script \
 255       $code $result
 256     if {$_test(verbose) != 1} {
 257       puts stdout "---- Result should have been:"
 258       puts stdout "$answer"
 259       puts stdout "---- $name ${HOW}ED"
 260     }
 261     if {$_test(logfile) != ""} {
 262       puts $_test(logfile) "---- Result should have been:"
 263       puts $_test(logfile) "$answer"
 264       puts $_test(logfile) "---- $name ${HOW}ED"
 265     }
 266   }
 267 }
 268
 269 proc gdbtk_dotests {file args} {
 270   global _test
 271   set savedTests $_test(tests)
 272   set _test(tests) $args
 273   source $file
 274   set _test(tests) $savedTests
 275 }
 276
 277 proc gdbtk_test_done {} {
 278   global _test env
 279
 280   if {$_test(logfile) != ""} {
 281     close $_test(logfile)
 282   }
 283
 284   set env(GDBTK_TEST_RUNNING) 0
 285   if {![info exists _test(interactive)] || !$_test(interactive)} {
 286     gdbtk_force_quit
 287   }
 288 }
 289
 290 proc gdbtk_test_error {desc} {
 291   set desc [join [split $desc \n] |]
 292   puts "ERROR \{$desc\} \{\} \{\}"
 293   gdbtk_test_done
 294 }
 295
 296 # Override the warning dialog. We don't want to see them.
 297 rename show_warning real_show_warning
 298 proc show_warning {msg} {
 299   global _test
 300
 301   set str "INSIGHT TESTSUITE WARNING: $msg"
 302   puts stdout $str
 303   if {$_test(logfile) != ""} {
 304     puts $_test(logfile) $str
 305   }
 306 }