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