gdb/testsuite/gdb.gdbtk/insight-support.exp

   1 # GDB Testsuite Support for Insight.
   2 #
   3 # Copyright 2001, 2004 Red Hat, Inc.
   4 #
   5 # This program is free software; you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License (GPL) as published by
   7 # the Free Software Foundation; either version 2 of the License, or (at
   8 # your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14
  15 # Initializes the display for gdbtk testing.
  16 # Returns 1 if tests should run, 0 otherwise.
  17 proc gdbtk_initialize_display {} {
  18   global _using_windows
  19
  20   # This is hacky, but, we don't have much choice. When running
  21   # expect under Windows, tcl_platform(platform) is "unix".
  22   if {![info exists _using_windows]} {
  23     set _using_windows [expr {![catch {exec cygpath --help}]}]
  24   }
  25
  26   if {![_gdbtk_xvfb_init]} {
  27     if {$_using_windows} {
  28       untested "No GDB_DISPLAY -- skipping tests"
  29     } else {
  30       untested "No GDB_DISPLAY or Xvfb -- skipping tests"
  31     }
  32
  33     return 0
  34   }
  35
  36   return 1
  37 }
  38
  39 # From dejagnu:
  40 # srcdir = testsuite src dir (e.g., devo/gdb/testsuite)
  41 # objdir = testsuite obj dir (e.g., gdb/testsuite)
  42 # subdir = subdir of testsuite (e.g., gdb.gdbtk)
  43 #
  44 # To gdbtk:
  45 # env(DEFS)=the "defs" files (e.g., devo/gdb/testsuite/gdb.gdbtk/defs)
  46 # env(SRCDIR)=directory containing the test code (e.g., *.test)
  47 # env(OBJDIR)=directory which contains any executables
  48 #            (e.g., gdb/testsuite/gdb.gdbtk)
  49 proc gdbtk_start {test} {
  50   global verbose
  51   global GDB
  52   global GDBFLAGS
  53   global env srcdir subdir objdir
  54
  55   gdb_stop_suppressing_tests;
  56
  57   # Need to convert ::GDB to use (-)?insight...
  58   if {[regsub {gdb$} $GDB insight newGDB]} {
  59     set INSIGHT $newGDB
  60   } else {
  61     perror "Cannot find Insight executable"
  62     return "ERROR gdbtk_start"
  63   }
  64
  65   verbose "Starting $INSIGHT -nx -q --tclcommand=$test"
  66
  67   set real_test [which $test]
  68   if {$real_test == 0} {
  69     perror "$test is not found"
  70     return "ERROR gdbtk_start"
  71   }
  72
  73   if {![is_remote host]} {
  74     if { [which $INSIGHT] == 0 } {
  75       perror "$INSIGHT does not exist."
  76       return "ERROR gdbtk_start"
  77     }
  78   }
  79
  80   set wd [pwd]
  81
  82   # Find absolute path to test
  83   set test [to_tcl_path -abs $test]
  84
  85   # Set some environment variables
  86   cd $srcdir
  87   set abs_srcdir [pwd]
  88   set env(DEFS) [to_tcl_path -abs [file join $abs_srcdir $subdir defs]]
  89
  90   cd $wd
  91   cd [file join $objdir $subdir]
  92   set env(OBJDIR) [pwd]
  93   cd $wd
  94
  95   # Set info about target into env
  96   _gdbtk_export_target_info
  97
  98   set env(SRCDIR) $abs_srcdir
  99   set env(GDBTK_VERBOSE) 1
 100   set env(GDBTK_LOGFILE) [to_tcl_path [file join $objdir gdb.log]]
 101   if {[info exists env(TCL_LIBRARY)]} {
 102     unset -nocomplain env(TCL_LIBRARY)
 103   }
 104
 105   set err [catch {exec $INSIGHT -nx -q --tclcommand=$test} res]
 106   if { $err } {
 107     perror "Execing $INSIGHT failed: $res"
 108     append res "\nERROR gdb-crash"
 109   }
 110   return $res
 111 }
 112
 113 # Start xvfb when using it.
 114 # The precedence is:
 115 #   1. If GDB_DISPLAY is set (and not ""), use it
 116 #   2. If Xvfb exists, use it (not on cygwin)
 117 #   3. Skip tests
 118 proc _gdbtk_xvfb_init {} {
 119   global env spawn_id _xvfb_spawn_id _using_windows
 120
 121   if {[info exists env(GDB_DISPLAY)]} {
 122     if {$env(GDB_DISPLAY) != ""} {
 123       set env(DISPLAY) $env(GDB_DISPLAY)
 124     } else {
 125       # Suppress tests
 126       return 0
 127     }
 128   } elseif {!$_using_windows && [which Xvfb] != 0} {
 129     set screen ":[getpid]"
 130     set pid [spawn  Xvfb $screen -ac]
 131     set _xvfb_spawn_id $spawn_id
 132     set env(DISPLAY) localhost$screen
 133   } else {
 134     # No Xvfb found -- skip test
 135     return 0
 136   }
 137
 138   return 1
 139 }
 140
 141 # Kill xvfb
 142 proc _gdbtk_xvfb_exit {} {
 143   global objdir subdir env _xvfb_spawn_id
 144
 145   if {[info exists _xvfb_spawn_id]} {
 146     exec kill [exp_pid -i $_xvfb_spawn_id]
 147     wait -i $_xvfb_spawn_id
 148   }
 149 }
 150
 151 # help proc for setting tcl-style paths from unix-style paths
 152 # pass "-abs" to make it an absolute path
 153 proc to_tcl_path {unix_path {arg {}}} {
 154   global _using_windows
 155
 156   if {[string compare $unix_path "-abs"] == 0} {
 157     set unix_path $arg
 158     set wd [pwd]
 159     cd [file dirname $unix_path]
 160     set dirname [pwd]
 161     set unix_name [file join $dirname [file tail $unix_path]]
 162     cd $wd
 163   }
 164
 165   if {$_using_windows} {
 166     set unix_path [exec cygpath -aw $unix_path]
 167     set unix_path [join [split $unix_path \\] /]
 168   }
 169
 170   return $unix_path
 171 }
 172
 173 # Set information about the target into the environment
 174 # variable TARGET_INFO. This array will contain a list
 175 # of commands that are necessary to run a target.
 176 #
 177 # This is mostly devined from how dejagnu works, what
 178 # procs are defined, and analyzing unix.exp, monitor.exp,
 179 # and sim.exp.
 180 #
 181 # Array elements exported:
 182 # Index   Meaning
 183 # -----   -------
 184 # init    list of target/board initialization commands
 185 # target  target command for target/board
 186 # load    load command for target/board
 187 # run     run command for target_board
 188 proc _gdbtk_export_target_info {} {
 189   global env
 190
 191   # Figure out what "target class" the testsuite is using,
 192   # i.e., sim, monitor, native
 193   if {[string compare [info proc gdb_target_monitor] gdb_target_monitor] == 0} {
 194     # Using a monitor/remote target
 195     set target monitor
 196   } elseif {[string compare [info proc gdb_target_sim] gdb_target_sim] == 0} {
 197     # Using a simulator target
 198     set target simulator
 199   } elseif {[string compare [info proc gdb_target_sid] gdb_target_sid] == 0} {
 200     # Using sid
 201     set target sid
 202   } else {
 203     # Assume native
 204     set target native
 205   }
 206
 207   # Now setup the array to be exported.
 208   set info(init) {}
 209   set info(target) {}
 210   set info(load) {}
 211   set info(run) {}
 212
 213   switch $target {
 214     simulator {
 215       set opts "[target_info gdb,target_sim_options]"
 216       set info(target) "target sim $opts"
 217       set info(load) "load"
 218       set info(run) "run"
 219     }
 220
 221     monitor {
 222       # Setup options for the connection
 223       if {[target_info exists baud]} {
 224         lappend info(init) "set remotebaud [target_info baud]"
 225       }
 226       if {[target_info exists binarydownload]} {
 227         lappend info(init) "set remotebinarydownload [target_info binarydownload]"
 228       }
 229       if {[target_info exists disable_x_packet]} {
 230         lappend info(init) "set remote X-packet disable"
 231       }
 232       if {[target_info exists disable_z_packet]} {
 233         lappend info(init) "set remote Z-packet disable"
 234       }
 235
 236       # Get target name and connection info
 237       if {[target_info exists gdb_protocol]} {
 238         set targetname "[target_info gdb_protocol]"
 239       } else {
 240         set targetname "not_specified"
 241       }
 242       if {[target_info exists gdb_serial]} {
 243         set serialport "[target_info gdb_serial]"
 244       } elseif {[target_info exists netport]} {
 245         set serialport "[target_info netport]"
 246       } else {
 247         set serialport "[target_info serial]"
 248       }
 249
 250       set info(target) "target $targetname $serialport"
 251       set info(load) "load"
 252       set info(run) "continue"
 253     }
 254
 255     sid {
 256       # We must start sid first, since Insight won't have a clue
 257       # about how to do this.
 258       sid_start
 259       set info(target) "target [target_info gdb_protocol] [target_info netport]"
 260       set info(load) "load"
 261       set info(run) "continue"
 262     }
 263
 264     native {
 265       set info(run) "run"
 266     }
 267   }
 268
 269   # Export the array to the environment
 270   set env(TARGET_INFO) [array get info]
 271 }
 272
 273 # gdbtk tests call this function to print out the results of the
 274 # tests. The argument is a proper list of lists of the form:
 275 # {status name description msg}. All of these things typically
 276 # come from the testsuite harness.
 277 proc gdbtk_analyze_results {results} {
 278   foreach test $results {
 279     set status [lindex $test 0]
 280     set name [lindex $test 1]
 281     set description [lindex $test 2]
 282     set msg [lindex $test 3]
 283
 284     switch $status {
 285       PASS {
 286         pass "$description ($name)"
 287       }
 288
 289       FAIL {
 290         fail "$description ($name)"
 291       }
 292
 293       ERROR {
 294         perror "$name"
 295       }
 296
 297       XFAIL {
 298         xfail "$description ($name)"
 299       }
 300
 301       XPASS {
 302         xpass "$description ($name)"
 303       }
 304     }
 305   }
 306 }
 307
 308 proc gdbtk_done {{results {}}} {
 309   global _xvfb_spawn_id
 310   gdbtk_analyze_results $results
 311
 312   # Kill off xvfb if using it
 313   if {[info exists _xvfb_spawn_id]} {
 314     _gdbtk_xvfb_exit
 315   }
 316
 317   # Yich. If we're using sid, we must kill it
 318   if {[string compare [info proc gdb_target_sid] gdb_target_sid] == 0} {
 319     sid_exit
 320   }
 321 }