3 # Copyright (C) 1998, 2000-2009 Free Software Foundation, Inc.
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.
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.
15 # You should have received a copy of the GNU General Public License
16 # along with this program. If not, see <http://www.gnu.org/licenses/>.
20 (my $program_name = $0) =~ s
|.*/||;
23 # Turn off localization of executable's output.
24 @ENV{qw(LANGUAGE LANG LC_ALL)} = ('C') x
3;
30 $saved_ls_colors = $ENV{LS_COLORS
};
31 $ENV{LS_COLORS
} = $_[0];
34 sub restore_ls_colors
()
36 $ENV{LS_COLORS
} = $saved_ls_colors;
39 # If the string $S is a well-behaved file name, simply return it.
40 # If it contains white space, quotes, etc., quote it, and return the new string.
44 if ($s =~ m![^\w+/.,-]!)
46 # Convert each single quote to '\''
47 $s =~ s/\'/\'\\\'\'/g;
48 # Then single quote the string.
54 # Set up files used by the setuid-etc tests; skip this entire test if
55 # that cannot be done.
58 my $test = shell_quote
"$ENV{abs_top_builddir}/src/test";
59 system (qq(touch setuid
&& chmod u
+s setuid
&& $test -u setuid
&&
60 touch setgid
&& chmod g
+s setgid
&& $test -g setgid
&&
61 mkdir sticky
&& chmod +t sticky
&& $test -k sticky
&&
62 mkdir owt
&& chmod +t
,o
+w owt
&& $test -k owt
&&
63 mkdir owr
&& chmod o
+w owr
)) == 0
64 or (warn "$program_name: cannot create setuid/setgid/sticky files,"
65 . "so can't run this test\n"), exit 77;
72 open (F
, '>', $f) && close F
73 or die "creating $f: $!\n";
77 sub mkdir_d
{mkdir 'd',0755 or die "d: $!\n"}
78 sub rmdir_d
{rmdir 'd' or die "d: $!\n"}
79 my $mkdir = {PRE
=> sub {mkdir_d
}};
80 my $rmdir = {POST
=> sub {rmdir_d
}};
81 my $mkdir_reg = {PRE
=> sub {mkdir_d
; mk_file
'd/f' }};
82 my $rmdir_reg = {POST
=> sub {unlink 'd/f' or die "d/f: $!\n";
83 rmdir 'd' or die "d: $!\n"}};
85 my $mkdir2 = {PRE
=> sub {mkdir 'd',0755 or die "d: $!\n";
86 mkdir 'd/e',0755 or die "d/e: $!\n" }};
87 my $rmdir2 = {POST
=> sub {rmdir 'd/e' or die "d/e: $!\n";
88 rmdir 'd' or die "d: $!\n" }};
90 my $target = {PRE
=> sub {
91 mkdir 'd',0755 or die "d: $!\n";
92 symlink '.', 'd/X' or die "d/X: $!\n";
93 push_ls_colors
('ln=target')
95 my $target2 = {POST
=> sub {unlink 'd/X' or die "d/X: $!\n";
96 rmdir 'd' or die "d: $!\n";
99 my $slink_d = {PRE
=> sub {symlink '/', 'd' or die "d: $!\n";
100 push_ls_colors
('ln=01;36:di=01;34:or=40;31;01')
102 my $unlink_d = {POST
=> sub {unlink 'd' or die "d: $!\n"; restore_ls_colors
}};
104 my $mkdir_d_slink = {PRE
=> sub {mkdir 'd',0755 or die "d: $!\n";
105 symlink '/', 'd/s' or die "d/s: $!\n" }};
106 my $rmdir_d_slink = {POST
=> sub {unlink 'd/s' or die "d/s: $!\n";
107 rmdir 'd' or die "d: $!\n" }};
111 mkdir 'j', 0700 or die "creating j: $!\n";
113 chmod 0555, 'j/d' or die "making j/d executable: $!\n";
116 my @v1 = (qw(0 9 A Z a z), 'zz~', 'zz', 'zz.~1~', 'zz.0');
117 my @v_files = ((map { ".$_" } @v1), @v1);
118 my $exe_in_subdir = {PRE
=> sub { make_j_d
(); push_ls_colors
('ex=01;32') }};
119 my $remove_j = {POST
=> sub {unlink 'j/d' or die "j/d: $!\n";
120 rmdir 'j' or die "j: $!\n";
121 restore_ls_colors
}};
124 my $q_bell = {IN
=> {"q\a" => ''}};
127 # test-name options input expected-output
129 # quoting tests............................................
130 ['q-', $q_bell, {OUT
=> "q\a\n"}, {EXIT
=> 0}],
131 ['q-N', '-N', $q_bell, {OUT
=> "q\a\n"}, {ERR
=> ''}],
132 ['q-q', '-q', $q_bell, {OUT
=> "q?\n"}],
133 ['q-Q', '-Q', $q_bell, {OUT
=> "\"q\\a\"\n"}],
135 ['q-lit-q', '--quoting=literal -q', $q_bell, {OUT
=> "q?\n"}],
136 ['q-qs-lit', '--quoting=literal', $q_bell, {OUT
=> "q\a\n"}],
137 ['q-qs-sh', '--quoting=shell', $q_bell, {OUT
=> "q\a\n"}],
138 ['q-qs-sh-a', '--quoting=shell-always', $q_bell, {OUT
=> "'q\a'\n"}],
139 ['q-qs-c', '--quoting=c', $q_bell, {OUT
=> "\"q\\a\"\n"}],
140 ['q-qs-esc', '--quoting=escape', $q_bell, {OUT
=> "q\\a\n"}],
141 ['q-qs-c-1', '--quoting=c',
142 {IN
=> {"t\004" => ''}}, {OUT
=> "\"t\\004\"\n"}],
144 ['emptydir', 'd', {OUT
=> ''}, $mkdir, $rmdir],
145 ['emptydir-x2', 'd d', {OUT
=> "d:\n\nd:\n"}, $mkdir, $rmdir],
146 ['emptydir-R', '-R d', {OUT
=> "d:\n"}, $mkdir, $rmdir],
148 # test `ls -R .' ............................................
149 ['R-dot', '--ignore="[a-ce-zA-Z]*" -R .', {OUT
=> ".:\nd\n\n\./d:\n"},
152 ['slink-dir-F', '-F d', {OUT
=> "d@\n"}, $slink_d, $unlink_d],
153 ['slink-dir-dF', '-dF d', {OUT
=> "d@\n"}, $slink_d, $unlink_d],
154 ['slinkdir-dFH', '-dFH d', {OUT
=> "d/\n"}, $slink_d, $unlink_d],
155 ['slinkdir-dFL', '-dFL d', {OUT
=> "d/\n"}, $slink_d, $unlink_d],
157 # Test for a bug that was fixed in coreutils-4.5.4.
158 ['sl-F-color', '-F --color=always d',
159 {OUT
=> "$e\e[01;36md$e\@\n\e[m"},
160 $slink_d, $unlink_d],
161 ['sl-dF-color', '-dF --color=always d',
162 {OUT
=> "$e\e[01;36md$e\@\n\e[m"},
163 $slink_d, $unlink_d],
165 # A listing with no output should have no color sequences at all.
166 ['no-c-empty', '--color=always d', {OUT
=> ""}, $mkdir, $rmdir],
167 # A listing with only regular files should have no color sequences at all.
168 ['no-c-reg', '--color=always d', {OUT
=> "f\n"}, $mkdir_reg, $rmdir_reg],
170 # Test for a bug fixed after coreutils-6.9.
171 ['sl-target', '--color=always d',
172 {OUT
=> "$e\e[01;34mX$e\n\e[m"}, $target, $target2],
174 # Test for another bug fixed after coreutils-6.9.
175 # This one bites only for a system/file system with d_type support.
176 ['sl-dangle', '--color=always d',
177 {OUT
=> "$e\e[40;31;01mX$e\n\e[m"},
179 mkdir 'd',0755 or die "d: $!\n";
180 symlink 'non-existent', 'd/X' or die "d/X: $!\n";
181 push_ls_colors
('or=40;31;01')
183 {POST
=> sub {unlink 'd/X' or die "d/X: $!\n";
184 rmdir 'd' or die "d: $!\n";
185 restore_ls_colors
; }},
188 # Test for a bug that was introduced in coreutils-4.5.4; fixed in 4.5.5.
189 # To demonstrate it, the file in question (with executable bit set)
190 # must not be a command line argument.
191 ['color-exe1', '--color=always j',
192 {OUT
=> "$e\e[01;32md$e\n\e[m"},
193 $exe_in_subdir, $remove_j],
195 # From Stéphane Chazelas.
196 ['no-a-isdir-b', 'no-dir d',
198 {ERR
=> "ls: cannot access no-dir: No such file or directory\n"},
199 $mkdir, $rmdir, {EXIT
=> 2}],
201 ['recursive-2', '-R d', {OUT
=> "d:\ne\n\nd/e:\n"}, $mkdir2, $rmdir2],
203 ['setuid-etc', '-1 -d --color=always owr owt setgid setuid sticky',
207 . "\e[30;43msetgid$e\n"
208 . "\e[37;41msetuid$e\n"
209 . "\e[37;44msticky$e\n"
214 unlink qw(setuid setgid);
215 foreach my $dir (qw(owr owt sticky)) {rmdir $dir} }},
218 # For 5.97 and earlier, --file-type acted like --indicator-style=slash.
219 ['file-type', '--file-type d', {OUT
=> "s@\n"},
220 $mkdir_d_slink, $rmdir_d_slink],
222 # 7.1 had a regression in how -v -a ordered some files
223 ['version-sort', '-v -A ' . join (' ', @v_files),
224 {OUT
=> join ("\n", @v_files) . "\n"},
225 {PRE
=> sub { mk_file
@v_files }},
226 {POST
=> sub { unlink @v_files }},
229 # Test for the ls -1U bug fixed in coreutils-7.5.
230 # It is triggered only with -1U and with two or more arguments,
231 # at least one of which is a nonempty directory.
232 ['multi-arg-U1', '-U1 d no-such',
234 {ERR_SUBST
=>'s/ch:.*/ch:/'},
235 {ERR
=> "$prog: cannot access no-such:\n"},
242 # Start with an unset LS_COLORS environment variable.
243 delete $ENV{LS_COLORS
};
245 my $save_temps = $ENV{SAVE_TEMPS
};
246 my $verbose = $ENV{VERBOSE
};
249 my $fail = run_tests
($program_name, $prog, \
@Tests, $save_temps, $verbose);
253 # Be careful to use the just-build dircolors.
254 my $env = `$ENV{abs_top_builddir}/src/dircolors -b`;
255 $env =~ s/^LS_COLORS=\'//;
257 $ENV{LS_COLORS
} = $env;
260 $fail = run_tests
($program_name, $prog, \
@Tests, $save_temps, $verbose);