Subversion Repositories or1k

# 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 _tesst(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 {

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

    gdb_force_quit

  }

}

proc gdbtk_test_error {desc} {

  set desc [join [split $desc \n] |]

  puts "ERROR \{$desc\} \{\} \{\}"

  gdbtk_test_done

}