← Back to branch summary

~ubuntu-branches/ubuntu/utopic/coreutils/utopic-proposed

« back to all changes in this revision

Viewing changes to tests/misc/ls-misc

  • Committer: Package Import Robot
  • Author(s): Colin Watson
  • Date: 2012-11-28 03:03:42 UTC
  • mfrom: (8.3.4 sid)
  • Revision ID: package-import@ubuntu.com-20121128030342-21zanj8354gas5gr
Tags: 8.20-3ubuntu1
* Resynchronise with Debian.  Remaining changes:
  - Make 'uname -i -p' return the real processor/hardware, instead of
    unknown.
  - Build-depend on gettext:any instead of on gettext, so that apt-get can
    properly resolve build-dependencies on the tool when cross-building.

Show diffs side-by-side

added added

removed removed

Lines of Context:
tests/misc/ls-misc
1
 
#!/usr/bin/perl
2
 
 
3
 
# Copyright (C) 1998, 2000-2011 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 $ME = $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 CuSkip::skip "$ME: cannot create setuid/setgid/sticky files,"
65
 
                 . "so can't run this test\n";
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"},
160
 
                                  $slink_d, $unlink_d],
161
 
     ['sl-dF-color', '-dF --color=always d',
162
 
                                 {OUT => "$e\e[01;36md$e\@\n"},
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"}, $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"},
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 --time-style=+:TIME: --color=always l',
190
 
      {OUT_SUBST => 's/.*:TIME: //'},
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 --time-style=+:TIME: --color=always l',
199
 
      {OUT_SUBST => 's/.*:TIME: //'},
200
 
      {OUT => "$e\e[40ml$e -> \e[34mnowhere$e\n"},
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 --time-style=+:TIME: --color=always l',
208
 
      {OUT_SUBST => 's/.*:TIME: //'},
209
 
      {OUT => "$e\e[36ml$e -> \e[35mnowhere$e\n"},
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 --time-style=+:TIME: --color=always l',
217
 
      {OUT_SUBST => 's/.*:TIME: //'},
218
 
      {OUT => "$e\e[34ml$e -> \e[35mnowhere$e\n"},
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"},
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
 
         },
249
 
 
250
 
        {POST => sub {
251
 
         unlink qw(setuid setgid);
252
 
         foreach my $dir (qw(owr owt sticky)) {rmdir $dir} }},
253
 
         ],
254
 
 
255
 
     # For 5.97 and earlier, --file-type acted like --indicator-style=slash.
256
 
     ['file-type', '--file-type d', {OUT => "s@\n"},
257
 
      $mkdir_d_slink, $rmdir_d_slink],
258
 
 
259
 
     # 7.1 had a regression in how -v -a ordered some files
260
 
     ['version-sort', '-v -A ' . join (' ', @v_files),
261
 
      {OUT => join ("\n", @v_files) . "\n"},
262
 
      {PRE => sub { mk_file @v_files }},
263
 
      {POST => sub { unlink @v_files }},
264
 
      ],
265
 
 
266
 
     # Test for the ls -1U bug fixed in coreutils-7.5.
267
 
     # It is triggered only with -1U and with two or more arguments,
268
 
     # at least one of which is a nonempty directory.
269
 
     ['multi-arg-U1', '-U1 d no-such',
270
 
      {OUT => "d:\nf\n"},
271
 
      {ERR_SUBST=>'s/ch:.*/ch:/'},
272
 
      {ERR => "$prog: cannot access no-such:\n"},
273
 
      $mkdir_reg,
274
 
      $rmdir_reg,
275
 
      {EXIT => 2},
276
 
     ],
277
 
    );
278
 
 
279
 
umask 022;
280
 
 
281
 
# Start with an unset LS_COLORS environment variable.
282
 
delete $ENV{LS_COLORS};
283
 
 
284
 
my $save_temps = $ENV{SAVE_TEMPS};
285
 
my $verbose = $ENV{VERBOSE};
286
 
 
287
 
setuid_setup;
288
 
my $fail = run_tests ($ME, $prog, \@Tests, $save_temps, $verbose);
289
 
$fail
290
 
  and exit 1;
291
 
 
292
 
# Be careful to use the just-build dircolors.
293
 
my $env = `$ENV{abs_top_builddir}/src/dircolors -b`;
294
 
$env =~ s/^LS_COLORS=\'//;
295
 
$env =~ s/\';.*//sm;
296
 
$ENV{LS_COLORS} = $env;
297
 
 
298
 
setuid_setup;
299
 
$fail = run_tests ($ME, $prog, \@Tests, $save_temps, $verbose);
300
 
exit $fail;