# -*- TCL -*-
# Test-specific TCL procedures required by DejaGNU.
# Copyright (C) 2000, 2003, 2004, 2005, 2006, 2010, 2011 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 .
# Modified by Kevin Dalley from the xargs files.
# Modified by David MacKenzie from the gcc files
# written by Rob Savoye .
global OLDFIND
global FTSFIND
verbose "base_dir is $base_dir" 2
global env;
set env(GNU_FINDUTILS_FD_LEAK_CHECK) "1"
# look for OLDFIND and FTSFIND
if { ![info exists OLDFIND] || ![info exists FTSFIND] } {
verbose "Searching for oldfind"
set dir "$base_dir/.."
set objfile "find.o"
if ![file exists "$dir/$objfile"] then {
error "dir is $dir, but I cannot see $objfile in that directory"
}
if ([findfile $dir/oldfind 1 0]) {
verbose "found oldfind, so ftsfind must be called find"
set OLDFIND [findfile $dir/oldfind $dir/oldfind [transform oldfind]]
set FTSFIND [findfile $dir/find $dir/find [transform find ]]
} else {
verbose "did not find oldfind, so ftsfind must be called ftsfind"
set OLDFIND [findfile $dir/find $dir/find [transform find ]]
set FTSFIND [findfile $dir/ftsfind $dir/ftsfind [transform ftsfind]]
}
}
verbose "ftsfind is at $FTSFIND" 2
verbose "oldfind is at $OLDFIND" 2
if { [ string equal $FTSFIND $OLDFIND ] } {
error "OLDFIND and FTSFIND are set to $FTSFIND, which can't be right"
}
if [file exists $FTSFIND] then {
if [file exists $OLDFIND] then {
verbose "FTSFIND=$FTSFIND and OLDFIND=$OLDFIND both exist." 2
} else {
error "OLDFIND=$OLDFIND, but that program does not exist"
}
} else {
error "FTSFIND=$FTSFIND, but that program does not exist (base_dir is $base_dir)"
}
global FINDFLAGS
if ![info exists FINDFLAGS] then {
set FINDFLAGS ""
}
# Called by runtest.
# Extract and print the version number of find.
proc find_version {} {
global FTSFIND
global FINDFLAGS
if {[which $FTSFIND] != 0} then {
set tmp [ eval exec $FTSFIND $FINDFLAGS --version find.out.uns"
send_log "$cmd\n"
if $verbose>1 then {
send_user "Spawning \"$cmd\"\n"
}
if $fail_good then {
send_log "Hoping for this command to return nonzero\n"
} else {
send_log "Hoping for this command to return 0\n"
}
set failed [ catch "exec $cmd" result ]
send_log "return value is $failed, result is '$result'\n"
if $failed {
# The command failed.
if $fail_good then {
send_log "As expected, $cmd returned nonzero\n"
} else {
fail "$testname, $result"
}
} else {
# The command returned 0.
if $fail_good then {
fail "$testname, $result"
} else {
send_log "As expected, $cmd returned 0\n"
}
}
exec sort < find.out.uns > find.out
file delete find.out.uns
if [file exists $outfile] then {
# We use the 'sort' above to sort the output of find to ensure
# that the directory entries appear in a predictable order.
# Because in the general case the person compiling and running
# "make check" will have a different collating order to the
# maintainer, we can't guarantee that our "correct" answer
# is already sorted in the correct order. To avoid trying
# to figure out how to select a POSIX environment on a
# random system, we just sort the data again here, using
# the local user's environment.
exec sort < $outfile > cmp.out
set cmp_cmd "$compareprog find.out cmp.out"
send_log "$cmp_cmd\n"
catch "exec $cmp_cmd" cmpout
if {$cmpout != ""} then {
fail "$testname, standard output differs from the expected result:\n$cmpout"
return
}
} else {
if {[file size find.out] != 0} then {
fail "$testname, output should be empty"
return
}
}
pass "$testname"
}
proc optimisation_levels_to_test {} {
global OPTIMISATION_LEVELS
if [info exists OPTIMISATION_LEVELS] {
send_log "Running find at optimisation levels $OPTIMISATION_LEVELS\n"
return $OPTIMISATION_LEVELS
} else {
send_log "Running find at default optimisation levels\n"
return {0 1 2 3}
}
}
proc find_start { passfail options {infile ""} {output ""} {setup ""}} {
global OLDFIND
global FTSFIND
global FINDFLAGS
global SKIP_OLD
global SKIP_NEW
if {$infile != ""} then {
set msg "Did not expect infile parameter to be set"
untested $msg
error $msg
}
if {[which $FTSFIND] == 0} then {
error "$FTSFIND, program does not exist"
exit 1
}
if {[which $OLDFIND] == 0} then {
error "$OLDFIND, program does not exist"
exit 1
}
# Now run the test with each binary, once with each optimisation level.
foreach optlevel [optimisation_levels_to_test] {
set flags "$FINDFLAGS -O$optlevel"
if { ![info exists SKIP_OLD] || ! $SKIP_OLD } {
eval $setup
do_find_start old-O$optlevel $OLDFIND $flags $passfail $options $infile $output
}
if { ![info exists SKIP_NEW] || !$SKIP_NEW } {
eval $setup
do_find_start new-O$optlevel $FTSFIND $flags $passfail $options $infile $output
}
}
}
# Called by runtest.
# Clean up (remove temporary files) before runtest exits.
proc find_exit {} {
catch "exec rm -f find.out cmp.out"
}
proc path_setting_is_unsafe {} {
global env;
set itemlist [ split $env(PATH) : ]
foreach item $itemlist {
if { [ string equal $item "" ] } {
return 1;
}
if { [ string equal $item "." ] } {
return 1;
}
if { ! [ string match "/*" $item ] } {
# not an absolute path element.
return 1
}
}
return 0;
}
proc touch args {
foreach filename $args {
set f [open "$filename" "a"]
close $f
}
}
proc mkdir { dirname } {
# Not all versions of Tcl offer 'file mkdir'.
set failed [ catch "file mkdir $dirname" result ]
if $failed {
# Fall back on the external command.
send_log "file mkdir does not work, falling back on exec mkdir\n"
exec mkdir "$dirname"
}
}
proc safe_path [ ] {
if { [ path_setting_is_unsafe ] } {
warning { Cannot perform test as your $PATH environment variable includes a reference to the current directory or a directory name which is not absolute }
untested { skipping this test because your $PATH variable is wrongly set }
return 0
} else {
return 1
}
}
proc fs_superuser [ ] {
set tmpfile "tmp000"
exec rm -f $tmpfile
touch $tmpfile
exec chmod 000 $tmpfile
set retval 0
if [ file readable $tmpfile ] {
# On Cygwin, a user with admin rights can read all files, and
# access(foo,R_OK) correctly returns 1 for all files.
warning "You have superuser privileges, skipping this test."
untested {skipping this test because you have superuser privileges}
set retval 1
}
exec rm -f $tmpfile
return $retval
}