2 # Test
-specific TCL procedures required by DejaGNU.
3 # Copyright
(C
) 1994 Free Software Foundation
, Inc.
5 # This
program is free software
; you can redistribute it and
/or modify
6 # it under the terms of the GNU General Public License as published by
7 # the Free Software Foundation
; either version
2 of the License
, or
8 #
(at your option
) any later version.
10 # This
program is distributed in the hope that it will be useful
,
11 # but WITHOUT
ANY WARRANTY
; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the
13 # GNU General Public License
for more details.
15 # You should have received a copy of the GNU General Public License
16 # along with this
program; if not
, write to the Free Software
17 # Foundation
, Inc.
, 51 Franklin Street
, Fifth Floor
, Boston
, MA
02110-1301,
21 # Modified by David MacKenzie
<djm@gnu.org
> from the gcc files
22 # written by Rob Savoye
<rob@cygnus.com
>.
25 # use the local version of find
for updatedb
27 # We normalise
(normalize
for those over the water
) pathnames
28 # because the updatedb
shell script uses
"cd", which means that
29 #
any relative paths no longer point where we thought they did.
30 # Because
"file normalize" requires tcl 8.4, we have a plan B
31 #
for normalising the
name of a directory
, but it is slower.
33 proc normalize_dir
{ dir } {
34 if [ catch
{ file normalize $
dir } result
] then {
35 return [ exec
/bin
/sh
-c
"cd $dir && /bin/pwd" ]
41 set fulldir
[ normalize_dir
"../../find" ]
42 set env
{find
} "$fulldir/find"
44 # use the local help commands
for updatedb
45 set env
(LIBEXECDIR
) [ normalize_dir ..
]
46 # use our local version of find
, too.
48 #
do not ignore
any file systems
for this test
52 if ![info exists UPDATEDB
] {
53 set UPDATEDB
[findfile $base_dir
/..
/updatedb $base_dir
/..
/updatedb
[transform updatedb
]]
54 verbose
"UPDATEDB defaulting to $UPDATEDB" 2
59 if ![info exists FRCODE
] {
60 set FRCODE
[findfile $base_dir
/..
/frcode $base_dir
/..
/frcode
[transform frcode
]]
61 verbose
"FRCODE defaulting to $FRCODE" 2
65 if ![info exists UPDATEDBFLAGS
] then {
71 if ![info exists LOCATE
] {
72 set LOCATE
[findfile $base_dir
/..
/locate $base_dir
/..
/locate
[transform locate
]]
73 verbose
"LOCATE defaulting to $LOCATE" 2
78 if ![info exists FIND
] {
79 set FIND
[findfile $base_dir
/..
/..
/find
/find $base_dir
/..
/..
/find
/find
[transform find
]]
80 verbose
"FIND defaulting to $FIND" 2
85 if ![info exists LOCATEFLAGS
] then {
90 # Extract and print the version number of locate.
91 proc locate_version
{} {
97 if {[which $LOCATE
] != 0} then {
98 set tmp
[ eval exec $LOCATE $LOCATEFLAGS
--version
</dev
/null
]
99 regexp
"version.*$" $tmp version
100 if [info exists version
] then {
101 clone_output
"[which $LOCATE] $version\n"
103 warning
"cannot get version from $tmp."
106 warning
"$LOCATE, program does not exist"
110 # Run locate and leave the output in $comp_output.
111 # Called by individual test scripts.
112 proc locate_textonly
{ passfail id intext locateoptions outtext
} {
116 if {[which $LOCATE
] == 0} then {
117 error
"$LOCATE, program does not exist"
121 if {[which $FRCODE
] == 0} then {
122 error
"$FRCODE, program does not exist"
126 set fail_good
[string match
"f*" $passfail]
128 set scriptname
[uplevel
{info script
}]
129 set testbase
[file rootname $scriptname
]
130 set testname
[file tail $testbase
]
131 set listfile
"updatedb-paths.txt"
132 set dbfile
"locate.db"
133 set outfile "locate.out"
135 # Generate the
"frcode" input.
136 catch
{ file
delete -force $listfle
}
137 set f
[open $listfile w
]
142 exec $FRCODE
< $listfile
> $dbfile
145 set locatecmd
"$LOCATE -d $dbfile $locateoptions"
146 send_log
"Running $locatecmd \n"
147 catch
"exec $locatecmd > $outfile"
150 set f
[open
"$outfile" r]
151 while { [ gets $f line
] >= 0 } {
152 # send_log
"Output fragment is $line\n"
153 append result
"$line\n"
157 # send_log
"Output is $result\n"
159 if {[string equal $result $outtext
]} {
166 send_log
"Output mismatch.\n"
167 send_log
"Expected: $outtext\n"
168 send_log
"Got : $result\n"
174 #
Do a test in which we expect an input
text file to be preserved unchanged.
175 proc locate_roundtrip
{ id intext
} {
176 if ![regexp
"\n$" $intext] {
177 # We like the items to be terminated by newlines.
178 error
"The input text is not terminated by newline"
181 locate_textonly p $id $intext
"-r ." $intext
186 # Run locate and leave the output in $comp_output.
187 # Called by individual test scripts.
188 proc locate_start
{ passfail updatedb_options locate_options
189 {updatedb_infile
""} {locate_infile ""}
199 if {[which $UPDATEDB
] == 0} then {
200 error
"$UPDATEDB, program does not exist"
203 if {[which $LOCATE
] == 0} then {
204 error
"$LOCATE, program does not exist"
208 set fail_good
[string match
"f*" $passfail]
210 set scriptname
[uplevel
{info script
}]
211 set testbase
[file rootname $scriptname
]
212 set testname
[file tail $testbase
]
214 set outfile "$testbase.xo"
215 if {"$updatedb_infile" != ""} then {
216 set updatedb_infile
"[file dirname [file dirname $testbase]]/inputs/$updatedb_infile"
218 set updatedb_infile
/dev
/null
220 if {"$locate_infile" != ""} then {
221 set locate_infile
"[file dirname [file dirname $testbase]]/inputs/$locate_infile"
223 set locate_infile
/dev
/null
226 catch
"exec rm -f locate.out"
228 set updatedb_cmd
"$UPDATEDB $UPDATEDBFLAGS $updatedb_options < $updatedb_infile"
229 send_log
"$updatedb_cmd\n"
231 send_user
"Spawning \"$updatedb_cmd\"\n"
233 catch
"exec $updatedb_cmd" comp_output
235 if {$comp_output
!= ""} then {
236 send_log
"$comp_output\n"
238 send_user
"$comp_output\n"
240 #
If fail_good is
set, that refers to the exit
status of locate
, not updatedb...
241 fail
"$testname, $comp_output"
244 send_log
"updatedb: OK.\n"
250 set locate_cmd
"$LOCATE $LOCATEFLAGS $locate_options < $locate_infile > locate.out"
251 send_log
"$locate_cmd\n"
253 send_user
"Spawning \"$locate_cmd\"\n"
256 catch
"exec $locate_cmd" comp_output
257 if {$comp_output
!= ""} then {
258 send_log
"$comp_output\n"
260 send_user
"$comp_output\n"
265 fail
"$testname, $comp_output"
270 if [file
exists $
outfile] then {
271 set cmp_cmd
"cmp locate.out $outfile"
272 send_log
"$cmp_cmd\n"
273 catch
"exec $cmp_cmd" cmpout
274 if {$cmpout
!= ""} then {
275 #catch
"exec diff locate.out $outfile" diffout
277 fail
"$testname, $cmpout"
281 if {[file size locate.out
] != 0} then {
282 fail
"$testname, output should be empty"
287 catch
"exec rm -rf tmp"
291 # Clean up
(remove temporary files
) before runtest exits.
292 proc locate_exit
{} {
293 catch
"exec rm -f locate.out updatedb-paths.txt locate.db"
297 # Extract and print the version number of updatedb.
298 proc updatedb_version
{} {
302 if {[which $UPDATEDB
] != 0} then {
303 set tmp
[ eval exec $UPDATEDB $UPDATEDBFLAGS
--version
</dev
/null
]
304 regexp
"version.*$" $tmp version
305 if [info exists version
] then {
306 clone_output
"[which $UPDATEDB] $version\n"
308 warning
"cannot get version from $tmp."
311 warning
"$UPDATEDB, program does not exist"