path: root/gdb/testsuite/gdb.gdbtk/defs

# This file contains support code for the gdbtk test suite.
# Copyright 2001 Red Hat, Inc.
#
# Based on the Tcl testsuite support code, portions of this file
# are Copyright (c) 1990-1994 The Regents of the University of California and
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
global _test env srcdir objdir

if {![info exists srcdir]} {
  if {[info exists env(SRCDIR)]} {
    set srcdir $env(SRCDIR)
  } else {
    set srcdir .
  }
}

if {![info exists objdir]} {
  if {[info exists env(OBJDIR)]} {
    set objdir $env(OBJDIR)
  } elseif {$_test(interactive)} {
    # If running interactively, assume that the objdir is
    # relative to the executable's location
    set objdir [file join [file dirname [info nameofexecutable]] testsuite gdb.gdbtk]
  } else {
    set objdir .
  }
}

if {![info exists _test(verbose)]} {
  if {[info exists env(GDBTK_VERBOSE)]} {
    set _test(verbose) $env(GDBTK_VERBOSE)
  } else {
    set _test(verbose) 0
  }
}
if {![info exists _test(tests)]} {

  if {[info exists env(GDBTK_TESTS)]} {
    set _test(tests) $env(GDBTK_TESTS)
  } else {
    set _test(tests) {}
  }
}

if {[info exists env(GDBTK_LOGFILE)]} {
  set _test(logfile) [open $env(GDBTK_LOGFILE) a+]
  fconfigure $_test(logfile) -buffering none
} else {
  set _test(logfile) {}
}

# Informs gdbtk internals that testsuite is running. An example
# where this is needed is the window manager, which must place
# all windows at some place on the screen so that the system's
# window manager does not interfere. This is reset in gdbtk_test_done.
set env(GDBTK_TEST_RUNNING) 1

# The gdb "file" command to use for gdbtk testing
# NOTE: This proc appends ".exe" to all windows' programs
proc gdbtk_test_file {filename} {
  global tcl_platform

  if {$tcl_platform(platform) == "windows"} {
    append filename ".exe"
  }

  set err [catch {gdb_cmd "file $filename" 1} text]
  if {$err} {
    error $text
  }

  return $text
}

proc gdbtk_test_run {{prog_args {}}} {
  global env

  # Get the target_info array from the testsuite
  array set target_info $env(TARGET_INFO)

  # We get the target ready by:
  # 1. Run all init commands
  # 2. Issue target command
  # 3. Issue load command
  # 4. Issue run command
  foreach cmd $target_info(init) {
    set err [catch {gdb_cmd $cmd 0} txt]
    if {$err} {
      _report_error "Target initialization command \"$cmd\" failed: $txt"
      return 0
    }
  }

  if {$target_info(target) != ""} {
    set err [catch {gdb_cmd $target_info(target) 0} txt]
    if {$err} {
      _report_error "Failed to connect to target: $txt"
      return 0
    }
  }

  if {$target_info(load) != ""} {
    set err [catch {gdb_cmd $target_info(load) 0} txt]
    if {$err} {
      _report_error "Failed to load: $txt"
      return 0
    }
  }

  if {$target_info(run) != ""} {
    set err [catch {gdb_cmd $target_info(run) 0} txt]
    if {$err} {
      _report_error "Could not run target with \"$target_info(run)\": $txt"
      return 0
    }
  }

  return 1
}

proc _report_error {msg} {
  global _test

  if {[info exists _test(interactive)] && $_test(interactive)} {
    # Dialog
    tk_messageBox -message $msg -icon error -type ok
  } else {
    # to stderr
    puts stderr $msg
  }
}

proc gdbtk_print_verbose {status name description script code answer} {
  global _test

  switch $code {
    0 {
      set code_words {}
    }
    1 {
      set code_words "Test generated error: $answer"
    }

    2 {
      set code_words "Test generated return exception;  result was: $answer"
    }

    3 {
      set code_words "Test generated break exception"
    }

    4 {
      set code_words "Test generated continue exception"
    }

    5 {
      set code_words "Test generated exception $code;  message was:$answer"
    }
  }

  if {$_test(verbose) > 1 \
	|| ($_test(verbose) != 1 && ($status == "ERROR" || $status == "FAIL"))} {
    # Printed when user verbose mode (verbose > 1) or an error/failure occurs
    # not running the testsuite (dejagnu)
    puts stdout "\n"
    puts stdout "==== $name $description"
    puts stdout "==== Contents of test case:"
    puts stdout "$script"
    if {$code_words != ""} {
      puts stdout $code_words
    }
    puts stdout "==== Result was:"
    puts stdout "$answer"
  } elseif {$_test(verbose)} {
    # Printed for the testsuite (verbose = 1)
    puts stdout "[list $status $name $description $code_words]"

    if {$_test(logfile) != ""} {
      puts $_test(logfile) "\n"
      puts $_test(logfile) "==== $name $description"
      puts $_test(logfile) "==== Contents of test case:"
      puts $_test(logfile) "$script"
      if {$code_words != ""} {
	puts $_test(logfile) $code_words
      }
      puts $_test(logfile) "==== Result was:"
      puts $_test(logfile) "$answer"
    }
  }
}

# gdbtk_test
#
# This procedure runs a test and prints an error message if the
# test fails.
#
# Arguments:
# name -		Name of test, in the form foo-1.2.
# description -		Short textual description of the test, to
#			help humans understand what it does.
# script -		Script to run to carry out the test.  It must
#			return a result that can be checked for
#			correctness.
# answer -		Expected result from script.

proc gdbtk_test {name description script answer} {
  global _test test_ran

  set test_ran 0
  if {[string compare $_test(tests) ""] != 0} then {
    set ok 0
    foreach test $_test(tests) {
      if [string match $test $name] then {
	set ok 1
	break
      }
    }
    if !$ok then return
  }

  set code [catch {uplevel $script} result]
  set test_ran 1
  if {$code != 0} {
    # Error
    gdbtk_print_verbose ERROR $name $description $script \
      $code $result
  } elseif {[string compare $result $answer] == 0} { 
    if {[string index $name 0] == "*"} {
      # XPASS
      set HOW XPASS
    } else {
      set HOW PASS
    }

    if {$_test(verbose)} {
      gdbtk_print_verbose $HOW $name $description $script \
	$code $result
      if {$_test(verbose) != 1} {
	puts stdout "++++ $name ${HOW}ED"
      }
    }
    if {$_test(logfile) != ""} {
      puts $_test(logfile) "++++ $name ${HOW}ED"
    }
  } else {
    if {[string index $name 0] == "*"} {
      # XFAIL
      set HOW XFAIL
    } else {
      set HOW FAIL
    }

    gdbtk_print_verbose $HOW $name $description $script \
      $code $result
    if {$_test(verbose) != 1} {
      puts stdout "---- Result should have been:"
      puts stdout "$answer"
      puts stdout "---- $name ${HOW}ED" 
    }
    if {$_test(logfile) != ""} {
      puts $_test(logfile) "---- Result should have been:"
      puts $_test(logfile) "$answer"
      puts $_test(logfile) "---- $name ${HOW}ED" 
    }
  }
}

proc gdbtk_dotests {file args} {
  global _test
  set savedTests $_test(tests)
  set _test(tests) $args
  source $file
  set _test(tests) $savedTests
}

proc gdbtk_test_done {} {
  global _test env

  if {$_test(logfile) != ""} {
    close $_test(logfile)
  }

  set env(GDBTK_TEST_RUNNING) 0
  if {![info exists _test(interactive)] || !$_test(interactive)} {
    gdbtk_force_quit
  }
}

proc gdbtk_test_error {desc} {
  set desc [join [split $desc \n] |]
  puts "ERROR \{$desc\} \{\} \{\}"
  gdbtk_test_done
}

# Override the warning dialog. We don't want to see them.
rename show_warning real_show_warning
proc show_warning {msg} {
  global _test

  set str "INSIGHT TESTSUITE WARNING: $msg"
  puts stdout $str
  if {$_test(logfile) != ""} {
    puts $_test(logfile) $str
  }
}