* lib/gdb.exp (gdbtk_initialize_display): New proc which will

        set up the display for testing.
        (gdbtk_start): Convert all paths to paths that tcl will like.
        Export target information to environment.
        (_gdbtk_xvfb_init): New proc to start Xvfb if available and
        necessary.
        (_gdbtk_xvfb_exit): New proc to kill Xvfb if necessary.
        (to_tcl_path): New proc to convert a given pathname into
        a path acceptible as an argument to a tcl command.
        (_gdbtk_export_target_info): New proc to export target info
        into the environment for gdbtk testing.
        (gdbtk_done): New proc to signal end-of-test.

diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index fe2979c..83c1a8c 100644 (file)
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,3 +1,18 @@
+2001-05-07  Keith Seitz <keiths@cygnus.com>
+
+        * lib/gdb.exp (gdbtk_initialize_display): New proc which will
+        set up the display for testing.
+        (gdbtk_start): Convert all paths to paths that tcl will like.
+        Export target information to environment.
+        (_gdbtk_xvfb_init): New proc to start Xvfb if available and
+        necessary.
+        (_gdbtk_xvfb_exit): New proc to kill Xvfb if necessary.
+        (to_tcl_path): New proc to convert a given pathname into
+        a path acceptible as an argument to a tcl command.
+        (_gdbtk_export_target_info): New proc to export target info
+        into the environment for gdbtk testing.
+        (gdbtk_done): New proc to signal end-of-test.
+
 2001-05-06  Jim Blandy  <jimb@redhat.com>
 
        * restore.c: Make the code of caller0 correspond to its comment.

diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 496b21a..7ac1d1d 100644 (file)
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -1599,6 +1599,30 @@ proc rerun_to_main {} {
   }
 }
 
+# Initializes the display for gdbtk testing.
+# Returns 1 if tests should run, 0 otherwise.
+proc gdbtk_initialize_display {} {
+  global _using_windows
+
+  # This is hacky, but, we don't have much choice. When running
+  # expect under Windows, tcl_platform(platform) is "unix".
+  if {![info exists _using_windows]} {
+    set _using_windows [expr {![catch {exec cygpath --help}]}]
+  }
+
+  if {![_gdbtk_xvfb_init]} {
+    if {$_using_windows} {
+      untested "No GDB_DISPLAY -- skipping tests"
+    } else {
+      untested "No GDB_DISPLAY or Xvfb -- skipping tests"
+    }
+
+    return 0
+  }
+
+  return 1
+}
+
 # From dejagnu:
 # srcdir = testsuite src dir (e.g., devo/gdb/testsuite)
 # objdir = testsuite obj dir (e.g., gdb/testsuite)
@@ -1632,34 +1656,34 @@ proc gdbtk_start {test} {
     }
   }
 
-  
   set wd [pwd]
+
+  # Find absolute path to test
+  set test [to_tcl_path -abs $test]
+
+  # Set environment variables for tcl libraries and such
   cd $srcdir
   set abs_srcdir [pwd]
-  cd [file join $abs_srcdir .. gdbtk library]
-  set env(GDBTK_LIBRARY) [pwd]
-  cd [file join $abs_srcdir .. .. tcl library]
-  set env(TCL_LIBRARY) [pwd]
-  cd [file join $abs_srcdir .. .. tk library]
-  set env(TK_LIBRARY) [pwd]
-  cd [file join $abs_srcdir .. .. tix library]
-  set env(TIX_LIBRARY) [pwd]
-  cd [file join $abs_srcdir .. .. itcl itcl library]
-  set env(ITCL_LIBRARY) [pwd]
-  cd [file join .. $abs_srcdir .. .. libgui library]
-  set env(CYGNUS_GUI_LIBRARY) [pwd]
-  cd $wd
-  cd [file join $abs_srcdir $subdir]
-  set env(DEFS) [file join [pwd] defs]
+  set env(GDBTK_LIBRARY) [to_tcl_path -abs [file join $abs_srcdir .. gdbtk library]]
+  set env(TCL_LIBRARY) [to_tcl_path -abs [file join $abs_srcdir .. .. tcl library]]
+  set env(TK_LIBRARY) [to_tcl_path -abs [file join $abs_srcdir .. .. tk library]]
+  set env(TIX_LIBRARY) [to_tcl_path -abs [file join $abs_srcdir .. .. tix library]]
+  set env(ITCL_LIBRARY) [to_tcl_path -abs [file join $abs_srcdir .. .. itcl itcl library]]
+  set env(CYGNUS_GUI_LIBRARY) [to_tcl_path -abs [file join .. $abs_srcdir .. .. libgui library]]
+  set env(DEFS) [to_tcl_path -abs [file join $abs_srcdir $subdir defs]]
+
   cd $wd
   cd [file join $objdir $subdir]
   set env(OBJDIR) [pwd]
   cd $wd
 
+  # Set info about target into env
+  _gdbtk_export_target_info
+
   set env(SRCDIR) $abs_srcdir
   set env(GDBTK_VERBOSE) 1
-  set env(GDBTK_LOGFILE) [file join $objdir gdb.log]
-  set env(GDBTK_TEST_RUNNING) 1
+  set env(GDBTK_LOGFILE) [to_tcl_path [file join $objdir gdb.log]]
+
   set err [catch {exec $GDB -nx -q --tclcommand=$test} res]
   if { $err } {
     perror "Execing $GDB failed: $res"
@@ -1668,6 +1692,149 @@ proc gdbtk_start {test} {
   return $res
 }
 
+# Start xvfb when using it.
+# The precedence is:
+#   1. If GDB_DISPLAY is set, use it
+#   2. If Xvfb exists, use it (not on cygwin)
+#   3. Skip tests
+proc _gdbtk_xvfb_init {} {
+  global env spawn_id _xvfb_spawn_id _using_windows
+
+  if {[info exists env(GDB_DISPLAY)]} {
+    set env(DISPLAY) $env(GDB_DISPLAY)
+  } elseif {!$_using_windows && [which Xvfb] != 0} {
+    set screen ":[getpid]"
+    set pid [spawn  Xvfb $screen]
+    set _xvfb_spawn_id $spawn_id
+    set env(DISPLAY) $screen
+  } else {
+    # No Xvfb found -- skip test
+    return 0
+  }
+
+  return 1
+}
+
+# Kill xvfb
+proc _gdbtk_xvfb_exit {} {
+  global objdir subdir env _xvfb_spawn_id
+
+  if {[info exists _xvfb_spawn_id]} {
+    exec kill [exp_pid -i $_xvfb_spawn_id]
+    wait -i $_xvfb_spawn_id
+  }
+}
+
+# help proc for setting tcl-style paths from unix-style paths
+# pass "-abs" to make it an absolute path
+proc to_tcl_path {unix_path {arg {}}} {
+  global _using_windows
+
+  if {[string compare $unix_path "-abs"] == 0} {
+    set unix_path $arg
+    set wd [pwd]
+    cd [file dirname $unix_path]
+    set dirname [pwd]
+    set unix_name [file join $dirname [file tail $unix_path]]
+    cd $wd
+  }
+
+  if {$_using_windows} {
+    set unix_path [exec cygpath -aw $unix_path]
+    set unix_path [join [split $unix_path \\] /]
+  }
+
+  return $unix_path
+}
+  
+# Set information about the target into the environment
+# variable TARGET_INFO. This array will contain a list
+# of commands that are necessary to run a target.
+#
+# This is mostly devined from how dejagnu works, what
+# procs are defined, and analyzing unix.exp, monitor.exp,
+# and sim.exp.
+#
+# Array elements exported:
+# Index   Meaning
+# -----   -------
+# init    list of target/board initialization commands
+# target  target command for target/board
+# load    load command for target/board
+# run     run command for target_board
+proc _gdbtk_export_target_info {} {
+  global env
+
+  # Figure out what "target class" the testsuite is using,
+  # i.e., sim, monitor, native
+  if {[string compare [info proc gdb_target_monitor] gdb_target_monitor] == 0} {
+    # Using a monitor/remote target
+    set target monitor
+  } elseif {[string compare [info proc gdb_target_sim] gdb_target_sim] == 0} {
+    # Using a simulator target
+    set target simulator
+  } else {
+    # Assume native
+    set target native
+  }
+
+  # Now setup the array to be exported.
+  set info(init) {}
+  set info(target) {}
+  set info(load) {}
+  set info(run) {}
+
+  switch $target {
+    simulator {
+      set opts "[target_info gdb,target_sim_options]"
+      set info(target) "target sim $opts"
+      set info(load) "load"
+      set info(run) "run"
+    }
+
+    monitor {
+      # Setup options for the connection
+      if {[target_info exists baud]} {
+       lappend info(init) "set remotebaud [target_info baud]"
+      }
+      if {[target_info exists binarydownload]} {
+       lappend info(init) "set remotebinarydownload [target_info binarydownload]"
+      }
+      if {[target_info exists disable_x_packet]} {
+       lappend info(init) "set remote X-packet disable"
+      }
+      if {[target_info exists disable_z_packet]} {
+       lappend info(init) "set remote Z-packet disable"
+      }
+
+      # Get target name and connection info
+      if {[target_info exists gdb_protocol]} {
+       set targetname "[target_info gdb_protocol]"
+      } else {
+       set targetname "not_specified"
+      }
+      if {[target_info exists gdb_serial]} {
+       set serialport "[target_info gdb_serial]"
+      } elseif {[target_info exists netport]} {
+       set serialport "[target_info netport]"
+      } else {
+       set serialport "[target_info serial]"
+      }
+
+      set info(target) "target $targetname $serialport"
+      set info(load) "load"
+      set info(run) "continue"
+    }
+
+    native {
+      set info(run) "run"
+    }
+  }
+
+  # Export the array to the environment
+  set env(TARGET_INFO) [array get info]
+}
+
 # gdbtk tests call this function to print out the results of the
 # tests. The argument is a proper list of lists of the form:
 # {status name description msg}. All of these things typically
@@ -1703,6 +1870,16 @@ proc gdbtk_analyze_results {results} {
   }
 }
 
+proc gdbtk_done {{results {}}} {
+  global _xvfb_spawn_id
+  gdbtk_analyze_results $results
+
+  # Kill off xvfb if using it
+  if {[info exists _xvfb_spawn_id]} {
+    _gdbtk_xvfb_exit
+  }
+}
+
 # Print a message and return true if a test should be skipped
 # due to lack of floating point suport.