From 9671de48921b4746825bdd2addbe3f4fd00146d8 Mon Sep 17 00:00:00 2001 From: Keith Seitz Date: Mon, 7 May 2001 20:34:45 +0000 Subject: [PATCH] * 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. --- gdb/testsuite/ChangeLog | 15 +++ gdb/testsuite/lib/gdb.exp | 213 ++++++++++++++++++++++++++++++++++---- 2 files changed, 210 insertions(+), 18 deletions(-) diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index fe2979c934a..83c1a8c7c1b 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,18 @@ +2001-05-07 Keith Seitz + + * 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 * 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 496b21a2a6c..7ac1d1d12d6 100644 --- 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. -- 2.30.2