tests/misc/ls-misc

   1 #!/usr/bin/perl
   2
   3 # Copyright (C) 1998, 2000-2008 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
  22 # Turn off localization of executable's output.
  23 @ENV{qw(LANGUAGE LANG LC_ALL)} = ('C') x 3;
  24
  25 my $saved_ls_colors;
  26
  27 sub push_ls_colors($)
  28 {
  29   $saved_ls_colors = $ENV{LS_COLORS};
  30   $ENV{LS_COLORS} = $_[0];
  31 }
  32
  33 sub restore_ls_colors()
  34 {
  35   $ENV{LS_COLORS} = $saved_ls_colors;
  36 }
  37
  38 # If the string $S is a well-behaved file name, simply return it.
  39 # If it contains white space, quotes, etc., quote it, and return the new string.
  40 sub shell_quote($)
  41 {
  42   my ($s) = @_;
  43   if ($s =~ m![^\w+/.,-]!)
  44     {
  45       # Convert each single quote to '\''
  46       $s =~ s/\'/\'\\\'\'/g;
  47       # Then single quote the string.
  48       $s = "'$s'";
  49     }
  50   return $s;
  51 }
  52
  53 # Set up files used by the setuid-etc tests; skip this entire test if
  54 # that cannot be done.
  55 sub setuid_setup()
  56 {
  57   my $test = shell_quote "$ENV{abs_top_builddir}/src/test";
  58   system (qq(touch setuid && chmod u+s setuid && $test -u setuid &&
  59            touch setgid && chmod g+s setgid && $test -g setgid &&
  60            mkdir sticky && chmod +t sticky  && $test -k sticky &&
  61            mkdir owt    && chmod +t,o+w owt && $test -k owt &&
  62            mkdir owr    && chmod o+w owr)) == 0
  63              or (warn "$program_name: cannot create setuid/setgid/sticky files,"
  64                  . "so can't run this test\n"), exit 77;
  65 }
  66
  67 sub mkdir_d {mkdir 'd',0755 or die "d: $!\n"}
  68 sub rmdir_d {rmdir 'd'      or die "d: $!\n"}
  69 my $mkdir = {PRE => sub {mkdir_d}};
  70 my $rmdir = {POST => sub {rmdir_d}};
  71 my $mkdir_reg = {PRE => sub {mkdir_d; open (FH, '>d/f') && close FH
  72                                or die "d/f: $!\n" }};
  73 my $rmdir_reg = {POST => sub {unlink 'd/f' or die "d/f: $!\n";
  74                               rmdir 'd' or die "d: $!\n"}};
  75
  76 my $mkdir2 = {PRE => sub {mkdir 'd',0755 or die "d: $!\n";
  77                           mkdir 'd/e',0755 or die "d/e: $!\n" }};
  78 my $rmdir2 = {POST => sub {rmdir 'd/e' or die "d/e: $!\n";
  79                            rmdir 'd' or die "d: $!\n" }};
  80
  81 my $target = {PRE => sub {
  82                 mkdir 'd',0755 or die "d: $!\n";
  83                 symlink '.', 'd/X' or die "d/X: $!\n";
  84                 push_ls_colors('ln=target')
  85               }};
  86 my $target2 = {POST => sub {unlink 'd/X' or die "d/X: $!\n";
  87                             rmdir 'd' or die "d: $!\n";
  88                             restore_ls_colors
  89                             }};
  90 my $slink_d = {PRE => sub {symlink '/', 'd' or die "d: $!\n";
  91                            push_ls_colors('ln=01;36:di=01;34:or=40;31;01')
  92                            }};
  93 my $unlink_d = {POST => sub {unlink 'd' or die "d: $!\n"; restore_ls_colors}};
  94
  95 my $mkdir_d_slink = {PRE => sub {mkdir 'd',0755 or die "d: $!\n";
  96                                  symlink '/', 'd/s' or die "d/s: $!\n" }};
  97 my $rmdir_d_slink = {POST => sub {unlink 'd/s' or die "d/s: $!\n";
  98                                   rmdir 'd' or die "d: $!\n" }};
  99
 100 sub make_j_d ()
 101 {
 102   mkdir 'j', 0700 or die "creating j: $!\n";
 103   (open F, '>j/d') && close F or die "creating j/d: $!\n";
 104   chmod 0555, 'j/d' or die "making j/d executable: $!\n";
 105 }
 106
 107 my $exe_in_subdir = {PRE => sub { make_j_d (); push_ls_colors('ex=01;32') }};
 108 my $remove_j = {POST => sub {unlink 'j/d' or die "j/d: $!\n";
 109                              rmdir 'j' or die "j: $!\n";
 110                              restore_ls_colors }};
 111
 112 my $q_bell = {IN => {"q\a" => ''}};
 113 my @Tests =
 114     (
 115      # test-name options input expected-output
 116      #
 117      # quoting tests............................................
 118      ['q-',        $q_bell, {OUT => "q\a\n"}, {EXIT => 0}],
 119      ['q-N', '-N', $q_bell, {OUT => "q\a\n"}, {ERR => ''}],
 120      ['q-q', '-q', $q_bell, {OUT => "q?\n"}],
 121      ['q-Q', '-Q', $q_bell, {OUT => "\"q\\a\"\n"}],
 122
 123      ['q-lit-q', '--quoting=literal -q',     $q_bell, {OUT => "q?\n"}],
 124      ['q-qs-lit', '--quoting=literal',       $q_bell, {OUT => "q\a\n"}],
 125      ['q-qs-sh', '--quoting=shell',          $q_bell, {OUT => "q\a\n"}],
 126      ['q-qs-sh-a', '--quoting=shell-always', $q_bell, {OUT => "'q\a'\n"}],
 127      ['q-qs-c', '--quoting=c',               $q_bell, {OUT => "\"q\\a\"\n"}],
 128      ['q-qs-esc', '--quoting=escape',        $q_bell, {OUT => "q\\a\n"}],
 129      ['q-qs-c-1', '--quoting=c',
 130       {IN => {"t\004" => ''}}, {OUT => "\"t\\004\"\n"}],
 131
 132      ['emptydir', 'd',  {OUT => ''}, $mkdir, $rmdir],
 133      ['emptydir-x2', 'd d',  {OUT => "d:\n\nd:\n"}, $mkdir, $rmdir],
 134      ['emptydir-R', '-R d',  {OUT => "d:\n"}, $mkdir, $rmdir],
 135
 136      # test `ls -R .' ............................................
 137      ['R-dot', '--ignore="[a-ce-zA-Z]*" -R .',  {OUT => ".:\nd\n\n\./d:\n"},
 138       $mkdir, $rmdir],
 139
 140      ['slink-dir-F',     '-F d', {OUT => "d@\n"}, $slink_d, $unlink_d],
 141      ['slink-dir-dF',   '-dF d', {OUT => "d@\n"}, $slink_d, $unlink_d],
 142      ['slinkdir-dFH',  '-dFH d', {OUT => "d/\n"}, $slink_d, $unlink_d],
 143      ['slinkdir-dFL',  '-dFL d', {OUT => "d/\n"}, $slink_d, $unlink_d],
 144
 145      # Test for a bug that was fixed in coreutils-4.5.4.
 146      ['sl-F-color', '-F --color=always d',
 147                                  {OUT => "\e[0m\e[01;36md\e[0m\@\n\e[m"},
 148                                   $slink_d, $unlink_d],
 149      ['sl-dF-color', '-dF --color=always d',
 150                                  {OUT => "\e[0m\e[01;36md\e[0m\@\n\e[m"},
 151                                   $slink_d, $unlink_d],
 152
 153      # A listing with no output should have no color sequences at all.
 154      ['no-c-empty', '--color=always d', {OUT => ""}, $mkdir, $rmdir],
 155      # A listing with only regular files should have no color sequences at all.
 156      ['no-c-reg', '--color=always d', {OUT => "f\n"}, $mkdir_reg, $rmdir_reg],
 157
 158      # Test for a bug fixed after coreutils-6.9.
 159      ['sl-target', '--color=always d',
 160       {OUT => "\e[0m\e[01;34mX\e[0m\n\e[m"}, $target, $target2],
 161
 162      # Test for another bug fixed after coreutils-6.9.
 163      # This one bites only for a system/file system with d_type support.
 164      ['sl-dangle', '--color=always d',
 165       {OUT => "\e[0m\e[40;31;01mX\e[0m\n\e[m"},
 166       {PRE => sub {
 167                 mkdir 'd',0755 or die "d: $!\n";
 168                 symlink 'non-existent', 'd/X' or die "d/X: $!\n";
 169                 push_ls_colors('or=40;31;01')
 170               }},
 171       {POST => sub {unlink 'd/X' or die "d/X: $!\n";
 172                     rmdir 'd' or die "d: $!\n";
 173                     restore_ls_colors; }},
 174      ],
 175
 176      # Test for a bug that was introduced in coreutils-4.5.4; fixed in 4.5.5.
 177      # To demonstrate it, the file in question (with executable bit set)
 178      # must not be a command line argument.
 179      ['color-exe1', '--color=always j',
 180                                  {OUT => "\e[0m\e[01;32md\e[0m\n\e[m"},
 181                                   $exe_in_subdir, $remove_j],
 182
 183      # From Stéphane Chazelas.
 184      ['no-a-isdir-b', 'no-dir d',
 185          {OUT => "d:\n"},
 186          {ERR => "ls: cannot access no-dir: No such file or directory\n"},
 187          $mkdir, $rmdir, {EXIT => 2}],
 188
 189      ['recursive-2', '-R d', {OUT => "d:\ne\n\nd/e:\n"}, $mkdir2, $rmdir2],
 190
 191      ['setuid-etc', '-1 -d --color=always owr owt setgid setuid sticky',
 192          {OUT =>
 193             "\e[0m\e[34;42mowr\e[0m\n"
 194             . "\e[30;42mowt\e[0m\n"
 195             . "\e[30;43msetgid\e[0m\n"
 196             . "\e[37;41msetuid\e[0m\n"
 197             . "\e[37;44msticky\e[0m\n"
 198             . "\e[m"
 199          },
 200
 201         {POST => sub {
 202          unlink qw(setuid setgid);
 203          foreach my $dir (qw(owr owt sticky)) {rmdir $dir} }},
 204          ],
 205
 206      # For 5.97 and earlier, --file-type acted like --indicator-style=slash.
 207      ['file-type', '--file-type d', {OUT => "s@\n"},
 208       $mkdir_d_slink, $rmdir_d_slink],
 209     );
 210
 211 # Start with an unset LS_COLORS environment variable.
 212 delete $ENV{LS_COLORS};
 213
 214 my $save_temps = $ENV{SAVE_TEMPS};
 215 my $verbose = $ENV{VERBOSE};
 216
 217 my $prog = 'ls';
 218
 219 setuid_setup;
 220 my $fail = run_tests ($program_name, $prog, \@Tests, $save_temps, $verbose);
 221 $fail
 222   and exit 1;
 223
 224 # Be careful to use the just-build dircolors.
 225 my $e = `$ENV{abs_top_builddir}/src/dircolors -b`;
 226 $e =~ s/^LS_COLORS=\'//;
 227 $e =~ s/\';.*//sm;
 228 $ENV{LS_COLORS} = $e;
 229
 230 setuid_setup;
 231 $fail = run_tests ($program_name, $prog, \@Tests, $save_temps, $verbose);
 232 exit $fail;