2
2
# Test-specific TCL procedures required by DejaGNU.
3
# Copyright (C) 1994, 2000, 2003, 2004, 2005, 2006
4
# Free Software Foundation, Inc.
3
# Copyright (C) 1994,2003,2004,2005,2006,2007 Free Software Foundation, Inc.
6
5
# This program is free software: you can redistribute it and/or modify
7
6
# it under the terms of the GNU General Public License as published by
8
7
# the Free Software Foundation, either version 3 of the License, or
9
8
# (at your option) any later version.
11
10
# This program is distributed in the hope that it will be useful,
12
11
# but WITHOUT ANY WARRANTY; without even the implied warranty of
13
12
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14
13
# GNU General Public License for more details.
16
15
# You should have received a copy of the GNU General Public License
17
16
# along with this program. If not, see <http://www.gnu.org/licenses/>.
19
19
# Modified by David MacKenzie <djm@gnu.org> from the gcc files
20
20
# written by Rob Savoye <rob@cygnus.com>.
21
# Modified by James Youngman <jay@gnu.org>.
24
# We used to use "file normalize" here but that is not available in
25
# Tcl version 8.3 (it was introduced in 8.4). The DejaGnu utility funciton
26
# 'absolute' will canonicalise directory names but not the names of
28
proc normalize { path } {
29
set dir [absolute [file dirname $path] ]
30
set base [file tail $path]
31
return [ file join $dir $base ]
35
23
# use the local version of find for updatedb
37
25
# We normalise (normalize for those over the water) pathnames
38
26
# because the updatedb shell script uses "cd", which means that
39
27
# any relative paths no longer point where we thought they did.
40
set env(find) [normalize "../../find/find"]
28
# Because "file normalize" requires tcl 8.4, we have a plan B
29
# for normalising the name of a directory, but it is slower.
31
proc normalize_dir { dir } {
32
if [ catch { file normalize $dir } result ] then {
33
return [ exec /bin/sh -c "cd $dir && /bin/pwd" ]
39
set fulldir [ normalize_dir "../../find" ]
40
set env{find} "$fulldir/find"
42
42
# use the local help commands for updatedb
43
set env(LIBEXECDIR) [normalize .. ]
44
verbose "LIBEXECDIR environment variable has been set to $env(LIBEXECDIR)" 2
43
set env(LIBEXECDIR) [ normalize_dir .. ]
44
# use our local version of find, too.
46
46
# do not ignore any file systems for this test
47
47
set env(PRUNEFS) ""
50
if ![info exists UPDATEDB] {
51
set UPDATEDB [findfile $base_dir/../updatedb $base_dir/../updatedb [transform updatedb]]
52
verbose "UPDATEDB defaulting to $UPDATEDB" 2
57
if ![info exists FRCODE] {
58
set FRCODE [findfile $base_dir/../frcode $base_dir/../frcode [transform frcode]]
59
verbose "FRCODE defaulting to $FRCODE" 2
62
# look for bigram and code
64
if ![info exists BIGRAM] {
65
set BIGRAM [findfile $base_dir/../bigram $base_dir/../bigram [transform bigram]]
66
verbose "BIGRAM defaulting to $BIGRAM" 2
69
if ![info exists CODE] {
70
set CODE [findfile $base_dir/../code $base_dir/../code [transform code]]
71
verbose "CODE defaulting to $CODE" 2
54
set UPDATEDB [findfile $base_dir/../updatedb $base_dir/../updatedb [transform updatedb]]
55
set FRCODE [findfile $base_dir/../frcode $base_dir/../frcode [transform frcode ]]
56
set LOCATE [findfile $base_dir/../locate $base_dir/../locate [transform locate ]]
57
set FIND [findfile $base_dir/../../find/find $base_dir/../../find/find [transform find ]]
58
verbose "UPDATEDB is $UPDATEDB" 1
59
verbose "FRCODE is $FRCODE" 1
60
verbose "LOCATE is $LOCATE" 1
61
verbose "FIND is $FIND" 1
64
foreach exe "$UPDATEDB $FRCODE $LOCATE $FIND" {
65
if ![ string match "/*" $exe ] {
66
error "Failed to find a binary to test for $exe"
74
70
global UPDATEDBFLAGS
99
90
if {[which $LOCATE] != 0} then {
100
set tmp [ eval exec $LOCATE $LOCATEFLAGS --version </dev/null ]
101
regexp "version.*$" $tmp version
102
if [info exists version] then {
103
clone_output "[which $LOCATE] $version\n"
105
warning "cannot get version from $tmp."
91
set tmp [ eval exec $LOCATE $LOCATEFLAGS --version </dev/null | sed 1q]
108
94
warning "$LOCATE, program does not exist"
99
# Run locate and leave the output in $comp_output.
100
# Called by individual test scripts.
112
101
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
105
set fail_good [string match "f*" $passfail]
128
107
set scriptname [uplevel {info script}]
230
200
if $verbose>1 then {
231
201
send_user "Spawning \"$updatedb_cmd\"\n"
233
set locate_cmd "$LOCATE $LOCATEFLAGS $locate_options < $locate_infile > locate.out"
234
send_log "$locate_cmd\n"
236
send_user "Spawning \"$locate_cmd\"\n"
239
203
catch "exec $updatedb_cmd" comp_output
205
if {$comp_output != ""} then {
206
send_log "$comp_output\n"
208
send_user "$comp_output\n"
210
# If fail_good is set, that refers to the exit
211
# status of locate, not updatedb...
212
fail "$testname: updatedb is supposed to be silent, $comp_output"
215
send_log "updatedb: OK.\n"
240
219
eval $between_hook
221
set locate_cmd "$LOCATE $LOCATEFLAGS $locate_options < $locate_infile > locate.out"
222
send_log "$locate_cmd\n"
224
send_user "Spawning \"$locate_cmd\"\n"
241
227
catch "exec $locate_cmd" comp_output
242
228
if {$comp_output != ""} then {
243
229
send_log "$comp_output\n"
272
258
catch "exec rm -rf tmp"
263
proc locate_from_db { passfail locate_options locate_database } {
268
set fail_good [string match "f*" $passfail]
269
set scriptname [uplevel {info script}]
270
set testbase [file rootname $scriptname]
271
set testname [file tail $testbase]
272
set testdir [file dirname $scriptname]
274
set dbpath "$testdir/$locate_database"
275
set outfile "$testbase.xo"
277
set locate_cmd "$LOCATE $LOCATEFLAGS -d $dbpath $locate_options > locate.out"
278
send_log "$locate_cmd\n"
280
send_user "Spawning \"$locate_cmd\"\n"
283
catch "exec $locate_cmd 2>/dev/null" comp_output
284
if {$comp_output != ""} then {
285
send_log "$comp_output\n"
287
send_user "$comp_output\n"
290
# XXX: in general may want to compare output, too.
293
fail "$testname: locate unfortunately failed, $comp_output"
299
if [file exists $outfile] then {
300
set cmp_cmd "cmp locate.out $outfile"
301
send_log "$cmp_cmd\n"
302
catch "exec $cmp_cmd" cmpout
303
if {$cmpout != ""} then {
304
#catch "exec diff locate.out $outfile" diffout
306
fail "$testname, $cmpout"
310
if {[file size locate.out] != 0} then {
311
fail "$testname, output should be empty"
275
322
# Called by runtest.
276
323
# Clean up (remove temporary files) before runtest exits.
277
324
proc locate_exit {} {
added
removed
locate/testsuite/config/unix.exp
