mirror of
git://git.sv.gnu.org/coreutils.git
synced 2026-02-15 11:52:15 +02:00
9fed2e35c0
* tests/cut/Test.pm: Adjust comment. * tests/misc/cut: Likewise. * tests/misc/ls-misc: Likewise. * tests/misc/od: Likewise. * tests/misc/stty-invalid: Likewise. * tests/tr/Test.pm: Likewise.
200 lines
7.1 KiB
Perl
Executable File
200 lines
7.1 KiB
Perl
Executable File
#!/bin/sh
|
|
# -*- perl -*-
|
|
|
|
# Copyright (C) 1998, 2000-2007 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 <http://www.gnu.org/licenses/>.
|
|
|
|
: ${PERL=perl}
|
|
: ${srcdir=.}
|
|
|
|
$PERL -e 'use warnings;' > /dev/null 2>&1 || {
|
|
echo 1>&2 "$0: configure didn't find a usable version of Perl," \
|
|
"so can't run this test"
|
|
exit 77
|
|
}
|
|
|
|
me=`echo $0|sed 's,.*/,,'`
|
|
exec $PERL -w -I$srcdir/.. -MCoreutils -M"CuTmpdir qw($me)" -- - << \EOF
|
|
require 5.003;
|
|
use strict;
|
|
|
|
(my $program_name = $0) =~ s|.*/||;
|
|
|
|
# Turn off localisation of executable's ouput.
|
|
@ENV{qw(LANGUAGE LANG LC_ALL)} = ('C') x 3;
|
|
|
|
# If the string $S is a well-behaved file name, simply return it.
|
|
# If it contains white space, quotes, etc., quote it, and return the new string.
|
|
sub shell_quote($)
|
|
{
|
|
my ($s) = @_;
|
|
if ($s =~ m![^\w+/.,-]!)
|
|
{
|
|
# Convert each single quote to '\''
|
|
$s =~ s/\'/\'\\\'\'/g;
|
|
# Then single quote the string.
|
|
$s = "'$s'";
|
|
}
|
|
return $s;
|
|
}
|
|
|
|
# Set up files used by the setuid-etc tests; skip this entire test if
|
|
# that cannot be done.
|
|
my $test = shell_quote "$ENV{abs_top_builddir}/src/test";
|
|
system (qq(touch setuid && chmod u+s setuid && $test -u setuid &&
|
|
touch setgid && chmod g+s setgid && $test -g setgid &&
|
|
mkdir sticky && chmod +t sticky && $test -k sticky &&
|
|
mkdir owt && chmod +t,o+w owt && $test -k owt &&
|
|
mkdir owr && chmod o+w owr)) == 0
|
|
or (warn "$program_name: cannot create setuid/setgid/sticky files,"
|
|
. "so can't run this test\n"), exit 77;
|
|
|
|
my $mkdir = {PRE => sub {mkdir 'd',0755 or die "d: $!\n"}};
|
|
my $rmdir = {POST => sub {rmdir 'd' or die "d: $!\n"}};
|
|
|
|
my $mkdir2 = {PRE => sub {mkdir 'd',0755 or die "d: $!\n";
|
|
mkdir 'd/e',0755 or die "d/e: $!\n" }};
|
|
my $rmdir2 = {POST => sub {rmdir 'd/e' or die "d/e: $!\n";
|
|
rmdir 'd' or die "d: $!\n" }};
|
|
|
|
my $target = {PRE => sub {
|
|
mkdir 'd',0755 or die "d: $!\n";
|
|
symlink '.', 'd/X' or die "d/X: $!\n";
|
|
$ENV{LS_COLORS}='ln=target'
|
|
}};
|
|
my $target2 = {POST => sub {unlink 'd/X' or die "d/X: $!\n";
|
|
rmdir 'd' or die "d: $!\n" }};
|
|
my $slink_d = {PRE => sub {symlink '/', 'd' or die "d: $!\n";
|
|
$ENV{LS_COLORS}='ln=01;36:di=01;34:or=40;31;01'
|
|
}};
|
|
my $unlink_d = {POST => sub {unlink 'd' or die "d: $!\n"}};
|
|
|
|
my $mkdir_d_slink = {PRE => sub {mkdir 'd',0755 or die "d: $!\n";
|
|
symlink '/', 'd/s' or die "d/s: $!\n" }};
|
|
my $rmdir_d_slink = {POST => sub {unlink 'd/s' or die "d/s: $!\n";
|
|
rmdir 'd' or die "d: $!\n" }};
|
|
|
|
sub make_j_d ()
|
|
{
|
|
mkdir 'j', 0700 or die "creating j: $!\n";
|
|
(open F, '>j/d') && close F or die "creating j/d: $!\n";
|
|
chmod 0555, 'j/d' or die "making j/d executable: $!\n";
|
|
}
|
|
|
|
my $exe_in_subdir = {PRE => sub { make_j_d (); $ENV{LS_COLORS}='ex=01;32' }};
|
|
my $remove_j = {POST => sub {unlink 'j/d' or die "j/d: $!\n";
|
|
rmdir 'j' or die "j: $!\n" }};
|
|
|
|
my $q_bell = {IN => {"q\a" => ''}};
|
|
my @Tests =
|
|
(
|
|
# test-name options input expected-output
|
|
#
|
|
# quoting tests............................................
|
|
['q-', $q_bell, {OUT => "q\a\n"}, {EXIT => 0}],
|
|
['q-N', '-N', $q_bell, {OUT => "q\a\n"}, {ERR => ''}],
|
|
['q-q', '-q', $q_bell, {OUT => "q?\n"}],
|
|
['q-Q', '-Q', $q_bell, {OUT => "\"q\\a\"\n"}],
|
|
|
|
['q-lit-q', '--quoting=literal -q', $q_bell, {OUT => "q?\n"}],
|
|
['q-qs-lit', '--quoting=literal', $q_bell, {OUT => "q\a\n"}],
|
|
['q-qs-sh', '--quoting=shell', $q_bell, {OUT => "q\a\n"}],
|
|
['q-qs-sh-a', '--quoting=shell-always', $q_bell, {OUT => "'q\a'\n"}],
|
|
['q-qs-c', '--quoting=c', $q_bell, {OUT => "\"q\\a\"\n"}],
|
|
['q-qs-esc', '--quoting=escape', $q_bell, {OUT => "q\\a\n"}],
|
|
['q-qs-c-1', '--quoting=c',
|
|
{IN => {"t\004" => ''}}, {OUT => "\"t\\004\"\n"}],
|
|
|
|
['emptydir', 'd', {OUT => ''}, $mkdir, $rmdir],
|
|
['emptydir-x2', 'd d', {OUT => "d:\n\nd:\n"}, $mkdir, $rmdir],
|
|
['emptydir-R', '-R d', {OUT => "d:\n"}, $mkdir, $rmdir],
|
|
|
|
# test `ls -R .' ............................................
|
|
['R-dot', '--ignore="[a-ce-zA-Z]*" -R .', {OUT => ".:\nd\n\n\./d:\n"},
|
|
$mkdir, $rmdir],
|
|
|
|
['slink-dir-F', '-F d', {OUT => "d@\n"}, $slink_d, $unlink_d],
|
|
['slink-dir-dF', '-dF d', {OUT => "d@\n"}, $slink_d, $unlink_d],
|
|
['slinkdir-dFH', '-dFH d', {OUT => "d/\n"}, $slink_d, $unlink_d],
|
|
['slinkdir-dFL', '-dFL d', {OUT => "d/\n"}, $slink_d, $unlink_d],
|
|
|
|
# Test for a bug that was fixed in coreutils-4.5.4.
|
|
['sl-F-color', '-F --color=always d',
|
|
{OUT => "\e[0m\e[01;36md\e[0m\@\n\e[m"},
|
|
$slink_d, $unlink_d],
|
|
['sl-dF-color', '-dF --color=always d',
|
|
{OUT => "\e[0m\e[01;36md\e[0m\@\n\e[m"},
|
|
$slink_d, $unlink_d],
|
|
|
|
# Test for a bug fixed after coreutils-6.9.
|
|
['sl-target', '--color=always d',
|
|
{OUT => "\e[0m\e[01;34mX\e[0m\n\e[m"}, $target, $target2],
|
|
|
|
# Test for another bug fixed after coreutils-6.9.
|
|
# This one bites only for a system/file system with d_type support.
|
|
['sl-dangle', '--color=always d',
|
|
{OUT => "\e[0m\e[40;31;01mX\e[0m\n\e[m"},
|
|
{PRE => sub {
|
|
mkdir 'd',0755 or die "d: $!\n";
|
|
symlink 'non-existent', 'd/X' or die "d/X: $!\n";
|
|
$ENV{LS_COLORS}='or=40;31;01'
|
|
}},
|
|
{POST => sub {unlink 'd/X' or die "d/X: $!\n";
|
|
rmdir 'd' or die "d: $!\n" }},
|
|
],
|
|
|
|
# Test for a bug that was introduced in coreutils-4.5.4; fixed in 4.5.5.
|
|
# To demonstrate it, the file in question (with executable bit set)
|
|
# must not be a command line argument.
|
|
['color-exe1', '--color=always j',
|
|
{OUT => "\e[0m\e[01;32md\e[0m\n\e[m"},
|
|
$exe_in_subdir, $remove_j],
|
|
|
|
# From Stéphane Chazelas.
|
|
['no-a-isdir-b', 'no-dir d',
|
|
{OUT => "d:\n"},
|
|
{ERR => "ls: cannot access no-dir: No such file or directory\n"},
|
|
$mkdir, $rmdir, {EXIT => 2}],
|
|
|
|
['recursive-2', '-R d', {OUT => "d:\ne\n\nd/e:\n"}, $mkdir2, $rmdir2],
|
|
|
|
['setuid-etc', '-1 -d --color=always owr owt setgid setuid sticky',
|
|
{OUT =>
|
|
"\e[0m\e[34;42mowr\e[0m\n"
|
|
. "\e[30;42mowt\e[0m\n"
|
|
. "\e[30;43msetgid\e[0m\n"
|
|
. "\e[37;41msetuid\e[0m\n"
|
|
. "\e[37;44msticky\e[0m\n"
|
|
. "\e[m"
|
|
},
|
|
|
|
{POST => sub {
|
|
unlink qw(setuid setgid);
|
|
foreach my $dir (qw(owr owt sticky)) {rmdir $dir} }},
|
|
],
|
|
|
|
# For 5.97 and earlier, --file-type acted like --indicator-style=slash.
|
|
['file-type', '--file-type d', {OUT => "s@\n"},
|
|
$mkdir_d_slink, $rmdir_d_slink],
|
|
);
|
|
|
|
my $save_temps = $ENV{SAVE_TEMPS};
|
|
my $verbose = $ENV{VERBOSE};
|
|
|
|
my $prog = 'ls';
|
|
my $fail = run_tests ($program_name, $prog, \@Tests, $save_temps, $verbose);
|
|
exit $fail;
|
|
EOF
|