[RFA] gdbtk testsuite enhancements - infrastructure

[Keith Seitz <keiths at cygnus dot com>]

Hi,

I have completed a bunch of work to enhance the gdbtk (aka Insight)
testsuite. This patch adds functionality to gdb's dejagnu testsuite
infrastructure to better support gui testing. Specifically, it
incorporates the ability to run the tests off-screen if Xvfb is installed.

Executive summary of how it will all affect the average gdb contributor:
If env variable GDB_DISPLAY is set, it will run gdbtk tests using that
display. If GDB_DISPLAY is not set, testsuite will attempt to run Xvfb for
testsing. If Xvfb is not found, tests are skipped.

So, to test on unix, either set GDB_DISPLAY=$DISPLAY (and don't touch
anything) or put Xvfb in your path. On Cygwin, you must set GDB_DISPLAY
(to anything) to run the tests.

There are accompanying gdb.gdbtk/*.exp changes to accompany this. See
follow-up.

Keith

testsuite/ChangeLog:
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.

Patch:
Index: gdb/testsuite/lib/gdb.exp
===================================================================
RCS file: /cvs/src/src/gdb/testsuite/lib/gdb.exp,v
retrieving revision 1.7
diff -u -r1.7 gdb.exp
--- gdb/testsuite/lib/gdb.exp	2001/03/06 08:22:01	1.7
+++ gdb/testsuite/lib/gdb.exp	2001/05/07 15:53:17
@@ -1599,6 +1599,30 @@
   }
 }

+# 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 @@
     }
   }

-
   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 @@
   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 derived 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
@@ -1700,6 +1867,16 @@
 	xpass "$description ($name)"
       }
     }
+  }
+}
+
+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
   }
 }