1#!/usr/bin/perl
2
3# Copyright (C) 1998-2023 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
18use strict;
19
20(my $ME = $0) =~ s|.*/||;
21my $prog = 'ls';
22
23# Turn off localization of executable's output.
24@ENV{qw(LANGUAGE LANG LC_ALL)} = ('C') x 3;
25
26my $saved_ls_colors;
27
28sub push_ls_colors($)
29{
30  $saved_ls_colors = $ENV{LS_COLORS} || '';
31  $ENV{LS_COLORS} = $_[0];
32}
33
34sub restore_ls_colors()
35{
36  $ENV{LS_COLORS} = $saved_ls_colors;
37}
38
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.
41sub shell_quote($)
42{
43  my ($s) = @_;
44  if ($s =~ m![^\w+/.,-]!)
45    {
46      # Convert each single quote to '\''
47      $s =~ s/\'/\'\\\'\'/g;
48      # Then single quote the string.
49      $s = "'$s'";
50    }
51  return $s;
52}
53
54# Set up files used by the setuid-etc tests; skip this entire test if
55# that cannot be done.
56sub setuid_setup()
57{
58  my $test = 'env 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 CuSkip::skip "$ME: cannot create setuid/setgid/sticky files,"
65                 . "so can't run this test\n";
66}
67
68sub mk_file(@)
69{
70  foreach my $f (@_)
71    {
72      open (F, '>', $f) && close F
73        or die "creating $f: $!\n";
74    }
75}
76
77sub mkdir_d {mkdir 'd',0755 or die "d: $!\n"}
78sub rmdir_d {rmdir 'd'      or die "d: $!\n"}
79my $mkdir = {PRE => sub {mkdir_d}};
80my $rmdir = {POST => sub {rmdir_d}};
81my $mkdir_reg = {PRE => sub {mkdir_d; mk_file 'd/f' }};
82my $rmdir_reg = {POST => sub {unlink 'd/f' or die "d/f: $!\n";
83                              rmdir 'd' or die "d: $!\n"}};
84
85my $mkdir2 = {PRE => sub {mkdir 'd',0755 or die "d: $!\n";
86                          mkdir 'd/e',0755 or die "d/e: $!\n" }};
87my $rmdir2 = {POST => sub {rmdir 'd/e' or die "d/e: $!\n";
88                           rmdir 'd' or die "d: $!\n" }};
89
90my $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')
94              }};
95my $target2 = {POST => sub {unlink 'd/X' or die "d/X: $!\n";
96                            rmdir 'd' or die "d: $!\n";
97                            restore_ls_colors
98                            }};
99my $slink_d = {PRE => sub {symlink '/', 'd' or die "d: $!\n";
100                           push_ls_colors('ln=01;36:di=01;34:or=40;31;01')
101                           }};
102my $unlink_d = {POST => sub {unlink 'd' or die "d: $!\n"; restore_ls_colors}};
103
104my $mkdir_d_slink = {PRE => sub {mkdir 'd',0755 or die "d: $!\n";
105                                 symlink '/', 'd/s' or die "d/s: $!\n" }};
106my $rmdir_d_slink = {POST => sub {unlink 'd/s' or die "d/s: $!\n";
107                                  rmdir 'd' or die "d: $!\n" }};
108
109sub make_j_d ()
110{
111  mkdir 'j', 0700 or die "creating j: $!\n";
112  mk_file 'j/d';
113  chmod 0555, 'j/d' or die "making j/d executable: $!\n";
114}
115
116my @v_files = (
117    '.0', '.9',
118    '.A', '.Z', '.a', '.z', '.zz~', '.zz', '.zz.~1~', '.zz.0',
119     '0',  '9',
120     'A',  'Z',  'a',  'z',  'zz~',  'zz',  'zz.~1~',  'zz.0');
121my $exe_in_subdir = {PRE => sub { make_j_d (); push_ls_colors('ex=01;32') }};
122my $remove_j = {POST => sub {unlink 'j/d' or die "j/d: $!\n";
123                             rmdir 'j' or die "j: $!\n";
124                             restore_ls_colors }};
125
126my $e = "\e[0m";
127my $q_bell = {IN => {"q\a" => ''}};
128my @Tests =
129    (
130     # test-name options input expected-output
131     #
132     # quoting tests............................................
133     ['q-',        $q_bell, {OUT => "q\a\n"}, {EXIT => 0}],
134     ['q-N', '-N', $q_bell, {OUT => "q\a\n"}, {ERR => ''}],
135     ['q-q', '-q', $q_bell, {OUT => "q?\n"}],
136     ['q-Q', '-Q', $q_bell, {OUT => "\"q\\a\"\n"}],
137
138     ['q-qs-lit',    '--quoting=literal',     $q_bell, {OUT => "q\a\n"}],
139     ['q-qs-sh',     '--quoting=shell',       $q_bell, {OUT => "q\a\n"}],
140     ['q-qs-sh-a',   '--quoting=shell-always',$q_bell, {OUT => "'q\a'\n"}],
141     ['q-qs-sh-e',   '--quoting=shell-escape',$q_bell, {OUT => "'q'\$'\\a'\n"}],
142     ['q-qs-c',      '--quoting=c',           $q_bell, {OUT => "\"q\\a\"\n"}],
143     ['q-qs-esc',    '--quoting=escape',      $q_bell, {OUT => "q\\a\n"}],
144     ['q-qs-loc',    '--quoting=locale',      $q_bell, {OUT => "'q\\a'\n"}],
145     ['q-qs-cloc',   '--quoting=clocale',     $q_bell, {OUT => "\"q\\a\"\n"}],
146
147     ['q-qs-lit-q',  '--quoting=literal -q',  $q_bell, {OUT => "q?\n"}],
148     ['q-qs-sh-q',   '--quoting=shell -q',    $q_bell, {OUT => "q?\n"}],
149     ['q-qs-sh-a-q', '--quoting=shell-al -q', $q_bell, {OUT => "'q?'\n"}],
150     ['q-qs-sh-e-q', '--quoting=shell-escape -q',
151                                              $q_bell, {OUT => "'q'\$'\\a'\n"}],
152     ['q-qs-c-q',    '--quoting=c -q',        $q_bell, {OUT => "\"q\\a\"\n"}],
153     ['q-qs-esc-q',  '--quoting=escape -q',   $q_bell, {OUT => "q\\a\n"}],
154     ['q-qs-loc-q',  '--quoting=locale -q',   $q_bell, {OUT => "'q\\a'\n"}],
155     ['q-qs-cloc-q', '--quoting=clocale -q',  $q_bell, {OUT => "\"q\\a\"\n"}],
156
157     ['q-qs-c-1', '--quoting=c',
158      {IN => {"t\004" => ''}}, {OUT => "\"t\\004\"\n"}],
159
160     ['emptydir', 'd',  {OUT => ''}, $mkdir, $rmdir],
161     ['emptydir-x2', 'd d',  {OUT => "d:\n\nd:\n"}, $mkdir, $rmdir],
162     ['emptydir-R', '-R d',  {OUT => "d:\n"}, $mkdir, $rmdir],
163
164     # test 'ls -R .' ............................................
165     ['R-dot', '--ignore="[a-ce-zA-Z]*" -R .',  {OUT => ".:\nd\n\n\./d:\n"},
166      $mkdir, $rmdir],
167
168     ['slink-dir-F',     '-F d', {OUT => "d@\n"}, $slink_d, $unlink_d],
169     ['slink-dir-dF',   '-dF d', {OUT => "d@\n"}, $slink_d, $unlink_d],
170     ['slinkdir-dFH',  '-dFH d', {OUT => "d/\n"}, $slink_d, $unlink_d],
171     ['slinkdir-dFL',  '-dFL d', {OUT => "d/\n"}, $slink_d, $unlink_d],
172
173     # Test for a bug that was fixed in coreutils-4.5.4.
174     ['sl-F-color', '-F --color=always d',
175                                 {OUT => "$e\e[01;36md$e\@\n"},
176                                  $slink_d, $unlink_d],
177     ['sl-dF-color', '-dF --color=always d',
178                                 {OUT => "$e\e[01;36md$e\@\n"},
179                                  $slink_d, $unlink_d],
180
181     # A listing with no output should have no color sequences at all.
182     ['no-c-empty', '--color=always d', {OUT => ""}, $mkdir, $rmdir],
183     # A listing with only regular files should have no color sequences at all.
184     ['no-c-reg', '--color=always d', {OUT => "f\n"}, $mkdir_reg, $rmdir_reg],
185
186     # Test for a bug fixed after coreutils-6.9.
187     ['sl-target', '--color=always d',
188      {OUT => "$e\e[01;34mX$e\n"}, $target, $target2],
189
190     # Test for another bug fixed after coreutils-6.9.
191     # This one bites only for a system/file system with d_type support.
192     ['sl-dangle', '--color=always d',
193      {OUT => "$e\e[40;31;01mX$e\n"},
194      {PRE => sub {
195                mkdir 'd',0755 or die "d: $!\n";
196                symlink 'non-existent', 'd/X' or die "d/X: $!\n";
197                push_ls_colors('or=40;31;01')
198              }},
199      {POST => sub {unlink 'd/X' or die "d/X: $!\n";
200                    rmdir 'd' or die "d: $!\n";
201                    restore_ls_colors; }},
202     ],
203
204     # Test for a bug fixed after coreutils-8.2.
205     ['sl-dangle2', '-o --time-style=+:TIME: --color=always l',
206      {OUT_SUBST => 's/.*:TIME: //'},
207      {OUT => "l -> nowhere\n"},
208      {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n";
209                   push_ls_colors('ln=target')
210       }},
211      {POST => sub {unlink 'l' or die "l: $!\n";
212                    restore_ls_colors; }},
213     ],
214     ['sl-dangle3', '-o --time-style=+:TIME: --color=always l',
215      {OUT_SUBST => 's/.*:TIME: //'},
216      {OUT => "$e\e[40ml$e -> \e[34mnowhere$e\n"},
217      {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n";
218                   push_ls_colors('ln=target:or=40:mi=34:')
219       }},
220      {POST => sub {unlink 'l' or die "l: $!\n";
221                    restore_ls_colors; }},
222     ],
223     ['sl-dangle4', '-o --time-style=+:TIME: --color=always l',
224      {OUT_SUBST => 's/.*:TIME: //'},
225      {OUT => "$e\e[36ml$e -> \e[35mnowhere$e\n"},
226      {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n";
227                   push_ls_colors('ln=34:mi=35:or=36:')
228       }},
229      {POST => sub {unlink 'l' or die "l: $!\n";
230                    restore_ls_colors; }},
231     ],
232     ['sl-dangle5', '-o --time-style=+:TIME: --color=always l',
233      {OUT_SUBST => 's/.*:TIME: //'},
234      {OUT => "$e\e[34ml$e -> \e[35mnowhere$e\n"},
235      {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n";
236                   push_ls_colors('ln=34:mi=35:')
237       }},
238      {POST => sub {unlink 'l' or die "l: $!\n";
239                    restore_ls_colors; }},
240     ],
241
242     # Test for a bug fixed after coreutils-8.13
243     # where 'argetm' was erroneously printed for dangling links
244     # when ln=target was used in LS_COLORS
245     ['sl-dangle6', '-L --color=always d',
246      {OUT => "s\n"},
247      {PRE => sub {mkdir 'd',0755 or die "d: $!\n";
248                   symlink 'dangle', 'd/s' or die "d/s: $!\n";
249                   push_ls_colors('ln=target')
250       }},
251      {POST => sub {unlink 'd/s' or die "d/s: $!\n";
252                    rmdir 'd' or die "d: $!\n";
253                    restore_ls_colors; }},
254      {ERR => "ls: cannot access 'd/s': No such file or directory\n"},
255      {EXIT => 1}
256     ],
257     # Related to the above fix, is this case where
258     # the code simulates "linkok".  In this case "linkmode"
259     # should always be zero, and hence not trigger any
260     # issues with type being set to C_LINK
261     ['sl-dangle7', '--color=always d',
262      {OUT => "$e\e[ms$e\n"},
263      {PRE => sub {mkdir 'd',0755 or die "d: $!\n";
264                   symlink 'dangle', 'd/s' or die "d/s: $!\n";
265                   push_ls_colors('ln=target:or=:ex=:')
266       }},
267      {POST => sub {unlink 'd/s' or die "d/s: $!\n";
268                    rmdir 'd' or die "d: $!\n";
269                    restore_ls_colors; }},
270     ],
271     # Another case with simulated "linkok", that does
272     # actually use the value of 'ln' from $LS_COLORS.
273     # This path is not taken though when 'ln=target'.
274     ['sl-dangle8', '--color=always s',
275      {OUT => "$e\e[1;36ms$e\n"},
276      {PRE => sub {symlink 'dangle', 's' or die "s: $!\n";
277                   push_ls_colors('ln=1;36:or=:')
278       }},
279      {POST => sub {unlink 's' or die "s: $!\n";
280                    restore_ls_colors; }},
281     ],
282     # The patch associated with sl-dangle[678] introduced a regression
283     # that was fixed after coreutils-8.19.  This edge case triggers when
284     # listing a dir containing dangling symlinks, but with orphans uncolored.
285     # I.e., the same as the previous test, but listing the directory
286     # rather than the symlink directly.
287     ['sl-dangle9', '--color=always d',
288      {OUT => "$e\e[1;36ms$e\n"},
289      {PRE => sub {mkdir 'd',0755 or die "d: $!\n";
290                   symlink 'dangle', 'd/s' or die "d/s: $!\n";
291                   push_ls_colors('ln=1;36:or=:')
292       }},
293      {POST => sub {unlink 'd/s' or die "d/s: $!\n";
294                    rmdir 'd' or die "d: $!\n";
295                    restore_ls_colors; }},
296     ],
297
298     # Test for a bug that was introduced in coreutils-4.5.4; fixed in 4.5.5.
299     # To demonstrate it, the file in question (with executable bit set)
300     # must not be a command line argument.
301     ['color-exe1', '--color=always j',
302                                 {OUT => "$e\e[01;32md$e\n"},
303                                  $exe_in_subdir, $remove_j],
304
305     # From Stéphane Chazelas.
306     ['no-a-isdir-b', 'no-dir d',
307         {OUT => "d:\n"},
308         {ERR => "ls: cannot access 'no-dir': No such file or directory\n"},
309         $mkdir, $rmdir, {EXIT => 2}],
310
311     ['recursive-2', '-R d', {OUT => "d:\ne\n\nd/e:\n"}, $mkdir2, $rmdir2],
312
313     ['setuid-etc', '-1 -d --color=always owr owt setgid setuid sticky',
314         {OUT =>
315            "$e\e[34;42mowr$e\n"
316            . "\e[30;42mowt$e\n"
317            . "\e[30;43msetgid$e\n"
318            . "\e[37;41msetuid$e\n"
319            . "\e[37;44msticky$e\n"
320         },
321
322        {PRE => sub {
323         push_ls_colors('ow=34;42:tw=30;42:sg=30;43:su=37;41:st=37;44'); }},
324        {POST => sub {
325         unlink qw(setuid setgid);
326         foreach my $dir (qw(owr owt sticky)) {rmdir $dir}
327         restore_ls_colors; }},
328         ],
329
330     # For 5.97 and earlier, --file-type acted like --indicator-style=slash.
331     ['file-type', '--file-type d', {OUT => "s@\n"},
332      $mkdir_d_slink, $rmdir_d_slink],
333
334     # 7.1 had a regression in how -v -a ordered some files
335     ['version-sort', '-v -A ' . join (' ', @v_files),
336      {OUT => join ("\n", @v_files) . "\n"},
337      {PRE => sub { mk_file @v_files }},
338      {POST => sub { unlink @v_files }},
339      ],
340
341     # Test for the ls -1U bug fixed in coreutils-7.5.
342     # It is triggered only with -1U and with two or more arguments,
343     # at least one of which is a nonempty directory.
344     ['multi-arg-U1', '-U1 d no-such',
345      {OUT => "d:\nf\n"},
346      {ERR_SUBST=>"s/ch':.*/ch':/"},
347      {ERR => "$prog: cannot access 'no-such':\n"},
348      $mkdir_reg,
349      $rmdir_reg,
350      {EXIT => 2},
351     ],
352    );
353
354umask 022;
355
356# Start with an unset LS_COLORS environment variable.
357delete $ENV{LS_COLORS};
358
359my $save_temps = $ENV{SAVE_TEMPS};
360my $verbose = $ENV{VERBOSE};
361
362setuid_setup;
363my $fail = run_tests ($ME, $prog, \@Tests, $save_temps, $verbose);
364$fail
365  and exit 1;
366
367# Be careful to use the just-build dircolors.
368my $env = qx/dircolors -b/;
369$env =~ s/^LS_COLORS=\'//;
370$env =~ s/\';.*//sm;
371$ENV{LS_COLORS} = $env;
372
373setuid_setup;
374$fail = run_tests ($ME, $prog, \@Tests, $save_temps, $verbose);
375exit $fail;
376