tests/misc/ls-misc

   1 #!/usr/bin/perl
   2
   3 # Copyright (C) 1998, 2000-2010 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 <http://www.gnu.org/licenses/>.
  17
  18 use strict;
  19
  20 (my $program_name = $0) =~ s|.*/||;
  21 my $prog = 'ls';
  22
  23 # Turn off localization of executable's output.
  24 @ENV{qw(LANGUAGE LANG LC_ALL)} = ('C') x 3;
  25
  26 my $saved_ls_colors;
  27
  28 sub push_ls_colors($)
  29 {
  30   $saved_ls_colors = $ENV{LS_COLORS};
  31   $ENV{LS_COLORS} = $_[0];
  32 }
  33
  34 sub 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.
  41 sub 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.
  56 sub setuid_setup()
  57 {
  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;
  66 }
  67
  68 sub mk_file(@)
  69 {
  70   foreach my $f (@_)
  71     {
  72       open (F, '>', $f) && close F
  73         or die "creating $f: $!\n";
  74     }
  75 }
  76
  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"}};
  84
  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" }};
  89
  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')
  94               }};
  95 my $target2 = {POST => sub {unlink 'd/X' or die "d/X: $!\n";
  96                             rmdir 'd' or die "d: $!\n";
  97                             restore_ls_colors
  98                             }};
  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')
 101                            }};
 102 my $unlink_d = {POST => sub {unlink 'd' or die "d: $!\n"; restore_ls_colors}};
 103
 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" }};
 108
 109 sub 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
 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 }};
 122
 123 my $e = "\e[0m";
 124 my $q_bell = {IN => {"q\a" => ''}};
 125 my @Tests =
 126     (
 127      # test-name options input expected-output
 128      #
 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"}],
 134
 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"}],
 143
 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],
 147
 148      # test `ls -R .' ............................................
 149      ['R-dot', '--ignore="[a-ce-zA-Z]*" -R .',  {OUT => ".:\nd\n\n\./d:\n"},
 150       $mkdir, $rmdir],
 151
 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],
 156
 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],
 164
 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],
 169
 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],
 173
 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"},
 178       {PRE => sub {
 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')
 182               }},
 183       {POST => sub {unlink 'd/X' or die "d/X: $!\n";
 184                     rmdir 'd' or die "d: $!\n";
 185                     restore_ls_colors; }},
 186      ],
 187
 188      # Test for a bug fixed after coreutils-8.2.
 189      ['sl-dangle2', '-o --color=always l',
 190       {OUT_SUBST => 's/.*[0-9][0-9]:[0-9][0-9] //'},
 191       {OUT => "l -> nowhere\n"},
 192       {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n";
 193                    push_ls_colors('ln=target')
 194        }},
 195       {POST => sub {unlink 'l' or die "l: $!\n";
 196                     restore_ls_colors; }},
 197      ],
 198      ['sl-dangle3', '-o --color=always l',
 199       {OUT_SUBST => 's/.*[0-9][0-9]:[0-9][0-9] //'},
 200       {OUT => "$e\e[40ml$e -> \e[34mnowhere$e\n\e[m"},
 201       {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n";
 202                    push_ls_colors('ln=target:or=40:mi=34:')
 203        }},
 204       {POST => sub {unlink 'l' or die "l: $!\n";
 205                     restore_ls_colors; }},
 206      ],
 207      ['sl-dangle4', '-o --color=always l',
 208       {OUT_SUBST => 's/.*[0-9][0-9]:[0-9][0-9] //'},
 209       {OUT => "$e\e[36ml$e -> \e[35mnowhere$e\n\e[m"},
 210       {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n";
 211                    push_ls_colors('ln=34:mi=35:or=36:')
 212        }},
 213       {POST => sub {unlink 'l' or die "l: $!\n";
 214                     restore_ls_colors; }},
 215      ],
 216      ['sl-dangle5', '-o --color=always l',
 217       {OUT_SUBST => 's/.*[0-9][0-9]:[0-9][0-9] //'},
 218       {OUT => "$e\e[34ml$e -> \e[35mnowhere$e\n\e[m"},
 219       {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n";
 220                    push_ls_colors('ln=34:mi=35:')
 221        }},
 222       {POST => sub {unlink 'l' or die "l: $!\n";
 223                     restore_ls_colors; }},
 224      ],
 225
 226      # Test for a bug that was introduced in coreutils-4.5.4; fixed in 4.5.5.
 227      # To demonstrate it, the file in question (with executable bit set)
 228      # must not be a command line argument.
 229      ['color-exe1', '--color=always j',
 230                                  {OUT => "$e\e[01;32md$e\n\e[m"},
 231                                   $exe_in_subdir, $remove_j],
 232
 233      # From Stéphane Chazelas.
 234      ['no-a-isdir-b', 'no-dir d',
 235          {OUT => "d:\n"},
 236          {ERR => "ls: cannot access no-dir: No such file or directory\n"},
 237          $mkdir, $rmdir, {EXIT => 2}],
 238
 239      ['recursive-2', '-R d', {OUT => "d:\ne\n\nd/e:\n"}, $mkdir2, $rmdir2],
 240
 241      ['setuid-etc', '-1 -d --color=always owr owt setgid setuid sticky',
 242          {OUT =>
 243             "$e\e[34;42mowr$e\n"
 244             . "\e[30;42mowt$e\n"
 245             . "\e[30;43msetgid$e\n"
 246             . "\e[37;41msetuid$e\n"
 247             . "\e[37;44msticky$e\n"
 248             . "\e[m"
 249          },
 250
 251         {POST => sub {
 252          unlink qw(setuid setgid);
 253          foreach my $dir (qw(owr owt sticky)) {rmdir $dir} }},
 254          ],
 255
 256      # For 5.97 and earlier, --file-type acted like --indicator-style=slash.
 257      ['file-type', '--file-type d', {OUT => "s@\n"},
 258       $mkdir_d_slink, $rmdir_d_slink],
 259
 260      # 7.1 had a regression in how -v -a ordered some files
 261      ['version-sort', '-v -A ' . join (' ', @v_files),
 262       {OUT => join ("\n", @v_files) . "\n"},
 263       {PRE => sub { mk_file @v_files }},
 264       {POST => sub { unlink @v_files }},
 265       ],
 266
 267      # Test for the ls -1U bug fixed in coreutils-7.5.
 268      # It is triggered only with -1U and with two or more arguments,
 269      # at least one of which is a nonempty directory.
 270      ['multi-arg-U1', '-U1 d no-such',
 271       {OUT => "d:\nf\n"},
 272       {ERR_SUBST=>'s/ch:.*/ch:/'},
 273       {ERR => "$prog: cannot access no-such:\n"},
 274       $mkdir_reg,
 275       $rmdir_reg,
 276       {EXIT => 2},
 277      ],
 278     );
 279
 280 umask 022;
 281
 282 # Start with an unset LS_COLORS environment variable.
 283 delete $ENV{LS_COLORS};
 284
 285 my $save_temps = $ENV{SAVE_TEMPS};
 286 my $verbose = $ENV{VERBOSE};
 287
 288 setuid_setup;
 289 my $fail = run_tests ($program_name, $prog, \@Tests, $save_temps, $verbose);
 290 $fail
 291   and exit 1;
 292
 293 # Be careful to use the just-build dircolors.
 294 my $env = `$ENV{abs_top_builddir}/src/dircolors -b`;
 295 $env =~ s/^LS_COLORS=\'//;
 296 $env =~ s/\';.*//sm;
 297 $ENV{LS_COLORS} = $env;
 298
 299 setuid_setup;
 300 $fail = run_tests ($program_name, $prog, \@Tests, $save_temps, $verbose);
 301 exit $fail;