old-cross-binutils/gdb/testsuite/lib/insight-support.exp

# GDB Testsuite Support for Insight.
#
# Copyright 2001 Red Hat, Inc.
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License (GPL) as published by
# the Free Software Foundation; either version 2 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# 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)
# subdir = subdir of testsuite (e.g., gdb.gdbtk)
#
# To gdbtk:
# env(DEFS)=the "defs" files (e.g., devo/gdb/testsuite/gdb.gdbtk/defs)
# env(SRCDIR)=directory containing the test code (e.g., *.test)
# env(OBJDIR)=directory which contains any executables
#            (e.g., gdb/testsuite/gdb.gdbtk)
proc gdbtk_start {test} {
  global verbose
  global GDB
  global GDBFLAGS
  global env srcdir subdir objdir

  gdb_stop_suppressing_tests;

  verbose "Starting $GDB -nx -q --tclcommand=$test"

  set real_test [which $test]
  if {$real_test == 0} {
    perror "$test is not found"
    exit 1
  }

  if {![is_remote host]} {
    if { [which $GDB] == 0 } {
      perror "$GDB does not exist."
      exit 1
    }
  }

  set wd [pwd]

  # Find absolute path to test
  set test [to_tcl_path -abs $test]

  # Set some environment variables
  cd $srcdir
  set abs_srcdir [pwd]
  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) [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"
    append res "\nERROR gdb-crash"
  }
  return $res
}

# Start xvfb when using it.
# The precedence is:
#   1. If GDB_DISPLAY is set (and not ""), 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)]} {
    if {$env(GDB_DISPLAY) != ""} {
      set env(DISPLAY) $env(GDB_DISPLAY)
    } else {
      # Suppress tests
      return 0
    }
  } elseif {!$_using_windows && [which Xvfb] != 0} {
    set screen ":[getpid]"
    set pid [spawn  Xvfb $screen -ac]
    set _xvfb_spawn_id $spawn_id
    set env(DISPLAY) localhost$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
  } elseif {[string compare [info proc gdb_target_sid] gdb_target_sid] == 0} {
    # Using sid
    set target sid
  } 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"
    }

    sid {
      # We must start sid first, since Insight won't have a clue
      # about how to do this.
      sid_start
      set info(target) "target [target_info gdb_protocol] [target_info netport]"
      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
# come from the testsuite harness.
proc gdbtk_analyze_results {results} {
  foreach test $results {
    set status [lindex $test 0]
    set name [lindex $test 1]
    set description [lindex $test 2]
    set msg [lindex $test 3]

    switch $status {
      PASS {
	pass "$description ($name)"
      }

      FAIL {
	fail "$description ($name)"
      }

      ERROR {
	perror "$name"
      }

      XFAIL {
	xfail "$description ($name)"
      }

      XPASS {
	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
  }

  # Yich. If we're using sid, we must kill it
  if {[string compare [info proc gdb_target_sid] gdb_target_sid] == 0} {
    sid_exit
  }
}