1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
# -*- TCL -*-
# Test-specific TCL procedures required by DejaGNU.
# Copyright (C) 1994-2021 Free Software Foundation, Inc.
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <https://www.gnu.org/licenses/>.
# Modified by David MacKenzie <djm@gnu.ai.mit.edu> from the gcc files
# written by Rob Savoye <rob@cygnus.com>.
verbose "base_dir is $base_dir" 2
set env(GNU_FINDUTILS_FD_LEAK_CHECK) "1"
set objfile "xargs.o"
set dir "$base_dir/.."
set path "$dir/$objfile"
if ![file exists $path] then {
error "$path does not exist"
} else {
set XARGS [findfile $base_dir/../xargs [transform xargs]]
}
global XARGS
set XARGS [findfile $base_dir/../xargs $base_dir/../xargs [transform xargs]]
if [ string match "/*" $XARGS ] {
verbose "XARGS is set to $XARGS" 1
} else {
error "Failed to find a binary to test"
}
global XARGSFLAGS
if ![info exists XARGSFLAGS] then {
set XARGSFLAGS ""
}
# Called by runtest.
# Extract and print the version number of xargs.
proc xargs_version {} {
global XARGS
global XARGSFLAGS
if {[which $XARGS] != 0} then {
set tmp [ eval exec $XARGS $XARGSFLAGS --version </dev/null | sed 1q ]
clone_output $tmp
} else {
warning "$XARGS, program does not exist"
}
}
# Run xargs and leave the output in $comp_output.
# Called by individual test scripts.
proc xargs_start { passfail options {infile ""} {errh ""} {command ""} } {
global verbose
global XARGS
global XARGSFLAGS
global comp_output
if {[which $XARGS] == 0} then {
error "$XARGS, program does not exist"
exit 1
}
set scriptname [uplevel {info script}]
set testbase [file rootname $scriptname]
set testname [file tail $testbase]
if {[string match "\[0-9\]*" $passfail]} then {
set execrc "$passfail"
} elseif {[string match "p*" $passfail]} then {
set execrc "0"
} elseif {[string match "f*" $passfail]} then {
set execrc "1"
} else {
fail "$testname, failure in testing framework: passfail=$passfail"
return
}
set outfile "$testbase.xo"
if {$infile != ""} then {
set infile "[file dirname [file dirname $testbase]]/inputs/$infile"
} else {
set infile /dev/null
}
if {[string match "s*" $errh]} then {
set errfile ""
} else {
set errfile "$testbase.xe"
}
catch "exec rm -f xargs.out xargs.err"
if {$command != ""} then {
set cmd "$command < $infile > xargs.out 2> xargs.err"
} else {
set cmd "$XARGS $XARGSFLAGS $options < $infile > xargs.out 2> xargs.err"
}
send_log "$cmd\n"
if $verbose>1 then {
send_user "Spawning \"$cmd\"\n"
}
set status 0
if {[catch "exec $cmd" comp_output]} then {
if {[lindex $::errorCode 0] == "CHILDSTATUS"} then {
set status [lindex $::errorCode 2]
} else {
fail "$testname, failure in testing framework, $comp_output"
return
}
}
catch "exec cat xargs.err" comp_error
if {$execrc != $status} then {
if {$status == 0} then {
fail "$testname, unexpected success"
} elseif {$execrc == 0} then {
fail "$testname, unexpected failure, $comp_output, $comp_error"
} else {
fail "$testname, expected exit code $execrc, but got exit code $status"
}
return
}
# ok, at least exit code match.
if [file exists $outfile] then {
set cmp_cmd "cmp xargs.out $outfile"
send_log "$cmp_cmd\n"
catch "exec $cmp_cmd" cmpout
if {$cmpout != ""} then {
# stdout is wrong.
catch "exec diff -u xargs.out $outfile" diffs
send_log "stdout diffs: $diffs\n"
fail "$testname, wrong stdout output: $cmpout"
return
}
} elseif {[file size xargs.out] != 0} then {
fail "$testname, output on stdout should be empty"
return
}
# if stderr check is enabled,
if {$errfile != ""} then {
if {[file exists $errfile]} then {
catch "exec sed -i s/^.*xargs:/xargs:/ xargs.err" tmp
set cmp_cmd "cmp xargs.err $errfile"
send_log "$cmp_cmd\n"
catch "exec $cmp_cmd" cmperr
if {$cmperr != ""} then {
# stderr is wrong
catch "exec diff -ua xargs.err $errfile" diffs
send_log "stderr diffs: $diffs\n"
fail "$testname, wrong stderr output: $cmperr"
return
}
} elseif {[file size xargs.err] != 0} then {
fail "$testname, output on stderr should be empty"
return
}
}
pass "$testname"
}
# Called by runtest.
# Clean up (remove temporary files) before runtest exits.
proc xargs_exit {} {
catch "exec rm -f xargs.out xargs.err"
}
|
