clang-tests/gdb-1472-testsuite/src/dejagnu/testsuite/runtest.all/default_procs.tcl

set sum_file [open .tmp w]
set reboot 0
set errno ""

# this tests a proc for a returned pattern
proc lib_pat_test { cmd arg pattern } {
    catch "$cmd \"$arg\"" result
    puts "CMD(lib_pat_test) was: $cmd \"$arg\""
    puts "RESULT(lib_pat_test) was: \"${result}\" for pattern \"$pattern\"."
    if [ regexp -- "with too many" $result ] {
	return -1
    }
    if [ string match "$pattern" $result ] {
 	return 1
    } else {
	return 0
    }
}
	
# this tests a proc for a returned value
proc lib_ret_test { cmd arg val } {
    catch "$cmd \"$arg\"" result
#    catch "set result [$cmd $arg]" output
#    set result "$cmd [eval $arg]
    puts "CMD(lib_ret_test) was: $cmd $arg"
    puts "RESULT(lib_ret_test) was: $result"
#    puts "OUTPUT(lib_ret_test) was: $output"

    if { $result == $val } {
	return 1
    } else {
	return 0
    }
}

#
# This runs a standard test for a proc. The list is set up as:
# |test proc|proc being tested|args|pattern|message|
# test proc is something like lib_pat_test or lib_ret_test.
#
proc run_tests { tests } {
    foreach i "$tests" {
	set result [ [lindex $i 0] "[lindex $i 1]" "[lindex $i 2]" "[lindex $i 3]" ]
	switch -- $result {
	    "-1" {
		puts "ERRORED: [lindex $i 4]"
	    }
	    "1" {
		puts "PASSED: [lindex $i 4]"
	    }
	    "0" {
		puts "FAILED: [lindex $i 4]"
	    }
	    default {
		puts "BAD VALUE: [lindex $i 4]"
	    }
	}
    }
}

proc send_log { msg } {
    # this is just a stub for testing
}

proc pass { msg } {
    puts "PASSED: $msg"
}

proc fail { msg } {
    puts "FAILED: $msg"
}

proc perror { msg } {
    global errno
    puts "ERRORED: $msg"
    set errno "$msg"
}

proc warning { msg } {
    global errno
    puts "WARNED: $msg"
    set errno "$msg"
}

proc untested { msg } {
    puts "NOTTESTED: $msg"
}

proc unsupported { msg } {
    puts "NOTSUPPORTED: $msg"
}
proc verbose { args } {
    puts "[lindex $args 0]"
}