yggdrasil/binutils-gdb
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source 
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.
This commit is contained in:
Keith Seitz 2001-05-07 20:34:45 +00:00
parent f938fa6a95
commit 9671de4892
2 changed files with 210 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gdb/testsuite/ChangeLog
View File

@ -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.

213
gdb/testsuite/lib/gdb.exp
View File

@ -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.