hosttest.exp

eCos1.31版

    set dirname [file join $::objdir "testcase"]
    if { [file exists $dirname] == 0 } {

        # Something must have gone seriously wrong during the build phase,
        # there is nothing there.
        return
    }

    if { [file isdirectory $dirname] == 0 } {
	error "hosttest_clean: $dirname should be a directory"
    }

    foreach entry [glob -nocomplain -- [file join $dirname "*"]] {
	set filename [file join $dirname $entry]
	if { [file isfile $filename] == 0 } {
	    error "hosttest_clean: $filename is not a file"
	}
	set status [catch { file delete -force -- $filename } message]
	if { $status != 0 } {
	    error "hosttest_clean: unable to delete $filename, $message"
	}
    }
    set status [catch { file delete -force -- $dirname } message]
    if { $status != 0 } {
	error "hosttest_clean: unable to delete directory $dirname, $message"
    }
}

# ----------------------------------------------------------------------------
# Run a test executable, returning the status code and the output.
# The results are returned in variables. It is assumed that some test cases
# will fail, so raising an exception is appropriate only if something
# has gone wrong at the test harness level. The argument list
# should be the name of the test case (from which the executable file name
# can be derived) and a list of arguments.

proc hosttest_run { result_arg output_arg test args } {

    upvar $result_arg result
    upvar $output_arg output

    # Figure out the filename corresponding to the test and make
    # sure it exists.
    set filename [file join $::objdir "testcase" $test]
    append filename $::hosttest_data(EXEEXT)
    if { ([file exists $filename] == 0) || ([file isfile $filename] == 0) } {
	error "hosttest_run: testcase file $filename does not exist"
    }
    
    # There is no need to worry about interacting with the program,
    # just exec it. It is a good idea to do this in the testcase directory,
    # so that any core dumps get cleaned up as well.
    set current_dir [pwd]
    set status [ catch { cd [file join $::objdir "testcase"] } message ]
    if { $status != 0 } {
	error "unable to change directory to [file join $::objdir testcase]\n$message"
    }
    
    verbose -log -- $filename $args
    set status [ catch { set result [eval exec -keepnewline -- $filename $args] } output]
    if { $status == 0 } {
	# The command has succeeded. The exit code is 0 and the output
	# was returned by the exec.
	set output $result
	set result 0
    } else {
	# The command has failed. The exit code is 1 and the output is
	# already in the right place.
	verbose -log -- $output
	set result 1
    }
    set status [catch { cd $current_dir } message]
    if { $status != 0 } {
	error "unable to change directory back to $current_dir"
    }
}

# ----------------------------------------------------------------------------
# Given some test output, look through it for pass and fail messages.
# These should result in appropriate DejaGnu pass and fail calls.
# In addition, if the program exited with a non-zero status code but
# did not report any failures then a special failure is reported.

proc hosttest_handle_output { name result output } {

    set passes 0
    set fails  0
    
    foreach line [split $output "\n"] {

	# The output should be of one of the following forms:
	#    PASS:<message>
	#    FAIL:<message> Line: xx File: xx
	#    Whatever
	#
	# PASS and FAIL messages will be reported via DejaGnu pass and fail
	# calls. Everything else gets passed to verbose, so the user gets
	# to choose how much information gets reported.

	set dummy   ""
	set match1  ""
	set match2  ""

	if { [regexp -- {^PASS:<(.*)>.*$} $line dummy match1] == 1 } {
	    pass $match1
	    incr passes
	} elseif { [regexp -- {^FAIL:<(.*)>(.*)$} $line dummy match1 match2] == 1 } {
	    fail "$match1 $match2"
	    incr fails
	} else {
	    verbose $line
	}
    }

    if { ($result != 0) && ($fails == 0) } {
	fail "program terminated with non-zero exit code but did not report any failures"
    } elseif { ($passes == 0) && ($fails == 0) } {
	unresolved "test case $name did not report any passes or failures"
    }
}

# ----------------------------------------------------------------------------
# hosttest_run_test_with_filter
#    This routines combines the compile, run and clean operations,
#    plus it invokes a supplied callback to filter the output. The
#    callback is passed three arguments: the test name, the exit code,
#    and all of the program output.

proc hosttest_run_test_with_filter { name filter sources incdirs libdirs libs args } {

    set result 0
    set output ""

    set status [ catch { hosttest_compile $name $sources $incdirs $libdirs $libs } message]
    if { $status != 0 } {
	fail "unable to compile test case $name, $message"
	hosttest_clean
	return
    } 
    set status [ catch { hosttest_run result output $name $args } message]
    if { $status != 0 } {
	fail "unable to run test case $name, $message"
	hosttest_clean
	return
    }
    set status [ catch { $filter $name $result $output } message]
    if { $status != 0 } {
	fail "unable to parse output from test case $name"
	hosttest_clean
	return
    }

    hosttest_clean
}

# ----------------------------------------------------------------------------
# hosttest_run_simple_test
#    This routine combines the compile, run, output, and clean operations.
#    The arguments are the same as for compilation, plus an additional
#    list for run-time parameters to the test case.

proc hosttest_run_simple_test { name sources incdirs libdirs libs args } {


    set result 0
    set output ""

    set status [ catch { hosttest_compile $name $sources $incdirs $libdirs $libs } message]
    if { $status != 0 } {
	fail "unable to compile test case $name, $message"
	hosttest_clean
	return
    } 
    set status [ catch { hosttest_run result output $name $args } message]
    if { $status != 0 } {
	fail "unable to run test case $name, $message"
	hosttest_clean
	return
    }
    set status [ catch { hosttest_handle_output $name $result $output } message]
    if { $status != 0 } {
	fail "unable to parse output from test case $name"
	hosttest_clean
	return
    }

    hosttest_clean
}

# ----------------------------------------------------------------------------
# Filename translation. A particular file has been created and must now
# be accessed from Tcl.
#
# Under Unix everything just works.
#
# Under Windows, well there is cygwin and there is the Windows world.
# A file may have come from either. cygtclsh80 and hence DejaGnu is not
# fully integrated with cygwin, for example it does not know about
# cygwin mount points. There are also complications because of
# volume-relative filenames.
#
# The code here tries a number of different ways of finding a file which
# matches the name. It is possible that the result is not actually what
# was intended, but hopefully this case will never arise.

proc hosttest_translate_existing_filename { name } {

    if { $::tcl_platform(platform) == "unix" } {
	# The file should exist. It is worth checking just in case.
	if { [file exists $name] == 0 } {
	    return ""
	} else {
	    return $name
	}
    }

    if { $::tcl_platform(platform) != "windows" } {
	perror "The testing framework does not know about platform $::tcl_platform(platform)"
	return ""
    }

    # Always get rid of any backslashes, they just cause trouble
    regsub -all -- {\\} $name {/} name

    # If the name is already valid, great.
    if { [file exists $name] } {
	return $name
    }

    # OK, try to use cygwin's cygpath utility to convert it.
    set status [catch "exec cygpath -w $name" message]
    if { $status == 0 } {
	set cygwin_name ""
	regsub -all -- {\\} $message {/} cygwin_name
	if { [file exists $cygwin_name] } {
	    return $cygwin_name
	}
    }

    # Is the name volumerelative? If so work out the current volume
    # from the current directory and prepend this.
    if { [file pathtype $name] == "volumerelative" } {
	append fullname [string range [pwd] 0 1] $name
	if { [file exists $fullname] } {
	    return $fullname
	}
    }

    # There are other possibilities, e.g. d:xxx indicating a file
    # relative to the current directory on drive d:. For now such
    # Lovecraftian abominations are ignored.
    return ""
}

# ----------------------------------------------------------------------------
# Support for assertion dumps. The infrastructure allows other subsystems
# to add their own callbacks which get invoked during a panic and which
# can write additional output to the dump file. For example it would be
# possible to output full details of the current configuration. These
# routines make it easier to write test cases for such callbacks.
#
# hosttest_assert_check(result output)
#     Make sure that the test case really triggered an assertion.
#
# hosttest_assert_read_dump(output)
#     Identify the temporary file used for the dump, read it in, delete
#     it (no point in leaving such temporaries lying around when running
#     testcases) and return the contents of the file.
#
# hosttest_assert_extract_callback(dump title)
#     Given a dump output as returned by read_dump, look for a section
#     generated by a callback with the given title. Return the contents
#     of the callback.

proc hosttest_assert_check { result output } {

    if { $result == 0 } {
	return 0
    }

    foreach line [split $output "\n"] {
	if { [string match "Assertion failure*" $line] } {
	    return 1
	}
    }
    return 0
}

# This routine assumes that assert_check has already been called.
proc hosttest_assert_read_dump { output } {

    foreach line [split $output "\n"] {
	set dummy ""
	set match ""

	if { [regexp -nocase -- {^writing additional output to (.*)$} $line dummy match] } {

	    # The filename is in match, but it may not be directly accessible.
	    set filename [hosttest_translate_existing_filename $match]
	    if { $filename == "" } {
		return ""
	    }
	    set status [ catch {
		set fd   [open $filename r]
		set data [read $fd]
		close $fd
		file delete $filename
	    } message]
            if { $status != 0 } {
		unresolved "Unable to process assertion dump file $filename"
		unresolved "File $filename may have to be deleted manually"
		return ""
	    }
	    return $data
	}
    }
    return ""
}

# Look for the appropriate markers. Also clean up blank lines
# at the start and end.
proc hosttest_assert_extract_callback { dump title } {

    set lines [split $dump "\n"]
    set result ""

    while { [llength $lines] > 0 } {
	set line  [lindex $lines 0]
	set lines [lreplace $lines 0 0]

	if { [regexp -nocase -- "^\# \{\{\{.*${title}.*\$" $line] } {

	    # Skip any blank lines at the start
	    while { [llength $lines] > 0 } {
		set line  [lindex $lines 0]
		if { [regexp -- {^ *$} $line] == 0} {
		    break
		}
		set lines [lreplace $lines 0 0]
	    }

	    # Now add any lines until the close marker.
	    # Nested folds are not supported yet.
	    while { [llength $lines] > 0 } {
		set line  [lindex $lines 0]
		set lines [lreplace $lines 0 0]
		if { [regexp -nocase -- {^\# \}\}\}.*$} $line] } {
		    break
		}
		append result $line "\n"
	    }

	    return $result
	}
    }

    return ""
}