1# -*- TCL -*- 2# Test-specific TCL procedures required by DejaGNU. 3# Copyright (C) 2000-2021 Free Software Foundation, Inc. 4# 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 3 of the License, or 8# (at your option) any later version. 9# 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. 14# 15# You should have received a copy of the GNU General Public License 16# along with this program. If not, see <https://www.gnu.org/licenses/>. 17 18# Modified by Kevin Dalley <kevind@rahul.net> from the xargs files. 19# Modified by David MacKenzie <djm@gnu.ai.mit.edu> from the gcc files 20# written by Rob Savoye <rob@cygnus.com>. 21 22 23global OLDFIND 24global FTSFIND 25 26verbose "base_dir is $base_dir" 2 27global env; 28set env(GNU_FINDUTILS_FD_LEAK_CHECK) "1" 29 30# look for OLDFIND and FTSFIND 31if { ![info exists OLDFIND] || ![info exists FTSFIND] } { 32 verbose "Searching for oldfind" 33 set dir "$base_dir/.." 34 35 set objfile "ftsfind.o" 36 if ![file exists "$dir/$objfile"] then { 37 error "dir is $dir, but I cannot see $objfile in that directory" 38 } 39 set OLDFIND [findfile $dir/oldfind $dir/oldfind [transform oldfind]] 40 set FTSFIND [findfile $dir/find $dir/find [transform find ]] 41} 42 43verbose "ftsfind is at $FTSFIND" 2 44verbose "oldfind is at $OLDFIND" 2 45 46if { [ string equal $FTSFIND $OLDFIND ] } { 47 error "OLDFIND and FTSFIND are set to $FTSFIND, which can't be right" 48} 49 50if [file exists $FTSFIND] then { 51 if [file exists $OLDFIND] then { 52 verbose "FTSFIND=$FTSFIND and OLDFIND=$OLDFIND both exist." 2 53 } else { 54 error "OLDFIND=$OLDFIND, but that program does not exist" 55 } 56} else { 57 error "FTSFIND=$FTSFIND, but that program does not exist (base_dir is $base_dir)" 58} 59 60 61global FINDFLAGS 62if ![info exists FINDFLAGS] then { 63 set FINDFLAGS "" 64} 65 66# Called by runtest. 67# Extract and print the version number of find. 68proc find_version {} { 69 global FTSFIND 70 global FINDFLAGS 71 72 if {[which $FTSFIND] != 0} then { 73 set tmp [ eval exec $FTSFIND $FINDFLAGS --version </dev/null | sed 1q ] 74 clone_output $tmp 75 } else { 76 warning "$FTSFIND, program does not exist" 77 } 78} 79 80# Run find 81# Called by individual test scripts. 82proc do_find_start { suffix findprogram flags passfail options infile output } { 83 global verbose 84 85 set scriptname [uplevel {info script}] 86 set testbase [file rootname $scriptname] 87 88 89 if { [string match "f*" $passfail] } { 90 set fail_good 1 91 } else { 92 if { [string match "p*" $passfail] } { 93 set fail_good 0 94 } else { 95 if { [string match "xf*" $passfail] } { 96 setup_xfail "*-*-*" 97 set fail_good 1 98 } else { 99 if { [string match "xp*" $passfail] } { 100 setup_xfail "*-*-*" 101 set fail_good 0 102 } else { 103 # badly formed 104 untested "Badly defined test" 105 error "The first argument to find_start was $passfail but it should begin with p (pass) or f (fail) or xf (should fail but we know it passes) or xp (should pass but we know it fails)" 106 } 107 } 108 } 109 } 110 111 set test [file tail $testbase] 112 set testname "$test.$suffix" 113 114 # set compareprog "cmp" 115 set compareprog "diff -u" 116 117 set tmpout "" 118 if { $output != "" } { 119 error "The output option is not supported yet" 120 } 121 122 set outfile "$testbase.xo" 123 if {$infile != ""} then { 124 set infile "[file dirname [file dirname $testbase]]/inputs/$infile" 125 } else { 126 set infile /dev/null 127 } 128 129 set cmd "$findprogram $flags $options < $infile > find.out.uns" 130 send_log "$cmd\n" 131 if $verbose>1 then { 132 send_user "Spawning \"$cmd\"\n" 133 } 134 135 if $fail_good then { 136 send_log "Hoping for this command to return nonzero\n" 137 } else { 138 send_log "Hoping for this command to return 0\n" 139 } 140 set failed [ catch "exec $cmd" result ] 141 send_log "return value is $failed, result is '$result'\n" 142 if $failed { 143 # The command failed. 144 if $fail_good then { 145 send_log "As expected, $cmd returned nonzero\n" 146 } else { 147 fail "$testname, $result" 148 } 149 } else { 150 # The command returned 0. 151 if $fail_good then { 152 fail "$testname, $result" 153 } else { 154 send_log "As expected, $cmd returned 0\n" 155 } 156 } 157 158 exec sort < find.out.uns > find.out 159 file delete find.out.uns 160 161 if [file exists $outfile] then { 162 # We use the 'sort' above to sort the output of find to ensure 163 # that the directory entries appear in a predictable order. 164 # Because in the general case the person compiling and running 165 # "make check" will have a different collating order to the 166 # maintainer, we can't guarantee that our "correct" answer 167 # is already sorted in the correct order. To avoid trying 168 # to figure out how to select a POSIX environment on a 169 # random system, we just sort the data again here, using 170 # the local user's environment. 171 exec sort < $outfile > cmp.out 172 set cmp_cmd "$compareprog find.out cmp.out" 173 174 send_log "$cmp_cmd\n" 175 catch "exec $cmp_cmd" cmpout 176 if {$cmpout != ""} then { 177 fail "$testname, standard output differs from the expected result:\n$cmpout" 178 return 179 } 180 } else { 181 if {[file size find.out] != 0} then { 182 fail "$testname, output should be empty" 183 return 184 } 185 } 186 pass "$testname" 187} 188 189proc optimisation_levels_to_test {} { 190 global OPTIMISATION_LEVELS 191 if [info exists OPTIMISATION_LEVELS] { 192 send_log "Running find at optimisation levels $OPTIMISATION_LEVELS\n" 193 return $OPTIMISATION_LEVELS 194 } else { 195 send_log "Running find at default optimisation levels\n" 196 return {0 1 2 3} 197 } 198} 199 200proc find_start { passfail options {infile ""} {output ""} {setup ""}} { 201 global OLDFIND 202 global FTSFIND 203 global FINDFLAGS 204 global SKIP_OLD 205 global SKIP_NEW 206 207 if {$infile != ""} then { 208 set msg "Did not expect infile parameter to be set" 209 untested $msg 210 error $msg 211 } 212 213 if {[which $FTSFIND] == 0} then { 214 error "$FTSFIND, program does not exist" 215 exit 1 216 } 217 if {[which $OLDFIND] == 0} then { 218 error "$OLDFIND, program does not exist" 219 exit 1 220 } 221 222 # Now run the test with each binary, once with each optimisation level. 223 foreach optlevel [optimisation_levels_to_test] { 224 set flags "$FINDFLAGS -O$optlevel" 225 if { ![info exists SKIP_OLD] || ! $SKIP_OLD } { 226 eval $setup 227 do_find_start old-O$optlevel $OLDFIND $flags $passfail $options $infile $output 228 } 229 if { ![info exists SKIP_NEW] || !$SKIP_NEW } { 230 eval $setup 231 do_find_start new-O$optlevel $FTSFIND $flags $passfail $options $infile $output 232 } 233 } 234} 235 236# Called by runtest. 237# Clean up (remove temporary files) before runtest exits. 238proc find_exit {} { 239 catch "exec rm -f find.out cmp.out" 240} 241 242proc path_setting_is_unsafe {} { 243 global env; 244 set itemlist [ split $env(PATH) : ] 245 foreach item $itemlist { 246 if { [ string equal $item "" ] } { 247 return 1; 248 } 249 if { [ string equal $item "." ] } { 250 return 1; 251 } 252 if { ! [ string match "/*" $item ] } { 253 # not an absolute path element. 254 return 1 255 } 256 } 257 return 0; 258} 259 260proc touch args { 261 foreach filename $args { 262 set f [open "$filename" "a"] 263 close $f 264 } 265} 266 267proc mkdir { dirname } { 268 # Not all versions of Tcl offer 'file mkdir'. 269 set failed [ catch "file mkdir $dirname" result ] 270 if $failed { 271 # Fall back on the external command. 272 send_log "file mkdir does not work, falling back on exec mkdir\n" 273 exec mkdir "$dirname" 274 } 275} 276 277 278proc safe_path [ ] { 279 if { [ path_setting_is_unsafe ] } { 280 warning { Cannot perform test as your $PATH environment variable includes a reference to the current directory or a directory name which is not absolute } 281 untested { skipping this test because your $PATH variable is wrongly set } 282 return 0 283 } else { 284 return 1 285 } 286} 287 288 289proc fs_superuser [ ] { 290 set tmpfile "tmp000" 291 exec rm -f $tmpfile 292 touch $tmpfile 293 exec chmod 000 $tmpfile 294 set retval 0 295 296 if [ file readable $tmpfile ] { 297 # On Cygwin, a user with admin rights can read all files, and 298 # access(foo,R_OK) correctly returns 1 for all files. 299 warning "You have superuser privileges, skipping this test." 300 untested {skipping this test because you have superuser privileges} 301 set retval 1 302 } 303 exec rm -f $tmpfile 304 return $retval 305} 306