path: root/find/testsuite/config/unix.exp

# -*- TCL -*-
# Test-specific TCL procedures required by DejaGNU.
# Copyright (C) 2000-2023 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 <https://www.gnu.org/licenses/>.

# Modified by Kevin Dalley <kevind@rahul.net> from the xargs files.
# Modified by David MacKenzie <djm@gnu.ai.mit.edu> from the gcc files
# written by Rob Savoye <rob@cygnus.com>.


global FTSFIND

verbose "base_dir is $base_dir" 2
global env;
set env(GNU_FINDUTILS_FD_LEAK_CHECK) "1"

# look for FTSFIND
if { ![info exists FTSFIND] } {
    verbose "Searching for find"
    set dir "$base_dir/.."

    set objfile "ftsfind.o"
    if ![file exists "$dir/$objfile"] then {
	error "dir is $dir, but I cannot see $objfile in that directory"
    }
    set FTSFIND [findfile $dir/find    $dir/find    [transform find   ]]
}

verbose "ftsfind is at $FTSFIND" 2

if [file exists $FTSFIND] then {
    verbose "FTSFIND=$FTSFIND exists." 2
} 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 </dev/null | sed 1q ]
	clone_output $tmp
    } else {
	warning "$FTSFIND, program does not exist"
    }
}

# Run find
# Called by individual test scripts.
proc do_find_start { suffix findprogram flags passfail options infile output } {
    global verbose

    set scriptname [uplevel {info script}]
    set testbase [file rootname $scriptname]


    if { [string match "f*" $passfail] } {
	set fail_good 1
    } else {
	if { [string match "p*" $passfail] } {
	    set fail_good 0
	} else {
	    if { [string match "xf*" $passfail] } {
		setup_xfail "*-*-*"
		set fail_good 1
	    } else {
		if { [string match "xp*" $passfail] } {
		    setup_xfail "*-*-*"
		    set fail_good 0
		} else {
		    # badly formed
		    untested "Badly defined test"
		    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)"
		}
	    }
	}
    }

    set test [file tail $testbase]
    set testname "$test.$suffix"

    # set compareprog "cmp"
    set compareprog "diff -u"

    set tmpout ""
    if { $output != "" } {
	error "The output option is not supported yet"
    }

    set outfile "$testbase.xo"
    if {$infile != ""} then {
	set infile "[file dirname [file dirname $testbase]]/inputs/$infile"
    } else {
	set infile /dev/null
    }

    set cmd "$findprogram $flags $options < $infile > 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 FTSFIND
    global FINDFLAGS
    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
    }

    # 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_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
}