← Back to branch summary

~ubuntu-branches/ubuntu/feisty/dejagnu/feisty

« back to all changes in this revision

Viewing changes to testsuite/runtest.all/default_procs.tcl

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Jacobowitz
  • Date: 2004-02-09 15:07:58 UTC
  • Revision ID: james.westby@ubuntu.com-20040209150758-oaj7r5zrop60v8sb
Tags: upstream-1.4.4
Import upstream version 1.4.4

Show diffs side-by-side

added added

removed removed

Lines of Context:
testsuite/runtest.all/default_procs.tcl
 
1
set sum_file [open .tmp w]
 
2
set reboot 0
 
3
set errno ""
 
4
 
 
5
# this tests a proc for a returned pattern
 
6
proc lib_pat_test { cmd arg pattern } {
 
7
    catch "$cmd \"$arg\"" result
 
8
    puts "CMD(lib_pat_test) was: $cmd \"$arg\""
 
9
    puts "RESULT(lib_pat_test) was: \"${result}\" for pattern \"$pattern\"."
 
10
    if [ regexp -- "with too many" $result ] {
 
11
        return -1
 
12
    }
 
13
    if [ string match "$pattern" $result ] {
 
14
        return 1
 
15
    } else {
 
16
        return 0
 
17
    }
 
18
}
 
19
        
 
20
# this tests a proc for a returned value
 
21
proc lib_ret_test { cmd arg val } {
 
22
    catch "$cmd \"$arg\"" result
 
23
#    catch "set result [$cmd $arg]" output
 
24
#    set result "$cmd [eval $arg]
 
25
    puts "CMD(lib_ret_test) was: $cmd $arg"
 
26
    puts "RESULT(lib_ret_test) was: $result"
 
27
#    puts "OUTPUT(lib_ret_test) was: $output"
 
28
 
 
29
    if { $result == $val } {
 
30
        return 1
 
31
    } else {
 
32
        return 0
 
33
    }
 
34
}
 
35
 
 
36
#
 
37
# This runs a standard test for a proc. The list is set up as:
 
38
# |test proc|proc being tested|args|pattern|message|
 
39
# test proc is something like lib_pat_test or lib_ret_test.
 
40
#
 
41
proc run_tests { tests } {
 
42
    foreach i "$tests" {
 
43
        set result [ [lindex $i 0] "[lindex $i 1]" "[lindex $i 2]" "[lindex $i 3]" ]
 
44
        switch -- $result {
 
45
            "-1" {
 
46
                puts "ERRORED: [lindex $i 4]"
 
47
            }
 
48
            "1" {
 
49
                puts "PASSED: [lindex $i 4]"
 
50
            }
 
51
            "0" {
 
52
                puts "FAILED: [lindex $i 4]"
 
53
            }
 
54
            default {
 
55
                puts "BAD VALUE: [lindex $i 4]"
 
56
            }
 
57
        }
 
58
    }
 
59
}
 
60
 
 
61
proc send_log { msg } {
 
62
    # this is just a stub for testing
 
63
}
 
64
 
 
65
proc pass { msg } {
 
66
    puts "PASSED: $msg"
 
67
}
 
68
 
 
69
proc fail { msg } {
 
70
    puts "FAILED: $msg"
 
71
}
 
72
 
 
73
proc perror { msg } {
 
74
    global errno
 
75
    puts "ERRORED: $msg"
 
76
    set errno "$msg"
 
77
}
 
78
 
 
79
proc warning { msg } {
 
80
    global errno
 
81
    puts "WARNED: $msg"
 
82
    set errno "$msg"
 
83
}
 
84
 
 
85
proc untested { msg } {
 
86
    puts "NOTTESTED: $msg"
 
87
}
 
88
 
 
89
proc unsupported { msg } {
 
90
    puts "NOTSUPPORTED: $msg"
 
91
}
 
92
proc verbose { args } {
 
93
    puts "[lindex $args 0]"
 
94
}