| |
|
|
| |
|
|
| |
| |
| |
| |
|
|
| |
| |
| |
| |
|
|
| |
| |
|
|
| use strict; |
|
|
| (my $ME = $0) =~ s|.*/||; |
| my $prog = 'ls'; |
| |
| # Turn off localization of executable's output. |
| @ENV{qw(LANGUAGE LANG LC_ALL)} = ('C') x 3; |
| |
| my $saved_ls_colors; |
| |
| sub push_ls_colors($) |
| { |
| $saved_ls_colors = $ENV{LS_COLORS} || ''; |
| $ENV{LS_COLORS} = $_[0]; |
| } |
| |
| sub restore_ls_colors() |
| { |
| $ENV{LS_COLORS} = $saved_ls_colors; |
| } |
| |
| # If the string $S is a well-behaved file name, simply return it. |
| # If it contains white space, quotes, etc., quote it, and return the new string. |
| sub shell_quote($) |
| { |
| my ($s) = @_; |
| if ($s =~ m![^\w+/.,-]!) |
| { |
| |
| $s =~ s/\'/\'\\\'\'/g; |
| |
| $s = "'$s'"; |
| } |
| return $s; |
| } |
|
|
| |
| |
| sub setuid_setup() |
| { |
| my $test = 'env test'; |
| system (qq(touch setuid && chmod u+s setuid && $test -u setuid && |
| touch setgid && chmod g+s setgid && $test -g setgid && |
| mkdir sticky && chmod +t sticky && $test -k sticky && |
| mkdir owt && chmod +t,o+w owt && $test -k owt && |
| mkdir owr && chmod o+w owr)) == 0 |
| or CuSkip::skip "$ME: cannot create setuid/setgid/sticky files," |
| . "so can't run this test\n"; |
| } |
|
|
| sub mk_file(@) |
| { |
| foreach my $f (@_) |
| { |
| open (F, '>', $f) && close F |
| or die "creating $f: $!\n"; |
| } |
| } |
|
|
| sub mkdir_d {mkdir 'd',0755 or die "d: $!\n"} |
| sub rmdir_d {rmdir 'd' or die "d: $!\n"} |
| my $mkdir = {PRE => sub {mkdir_d}}; |
| my $rmdir = {POST => sub {rmdir_d}}; |
| my $mkdir_reg = {PRE => sub {mkdir_d; mk_file 'd/f' }}; |
| my $rmdir_reg = {POST => sub {unlink 'd/f' or die "d/f: $!\n"; |
| rmdir 'd' or die "d: $!\n"}}; |
|
|
| my $mkdir2 = {PRE => sub {mkdir 'd',0755 or die "d: $!\n"; |
| mkdir 'd/e',0755 or die "d/e: $!\n" }}; |
| my $rmdir2 = {POST => sub {rmdir 'd/e' or die "d/e: $!\n"; |
| rmdir 'd' or die "d: $!\n" }}; |
|
|
| my $target = {PRE => sub { |
| mkdir 'd',0755 or die "d: $!\n"; |
| symlink '.', 'd/X' or die "d/X: $!\n"; |
| push_ls_colors('ln=target') |
| }}; |
| my $target2 = {POST => sub {unlink 'd/X' or die "d/X: $!\n"; |
| rmdir 'd' or die "d: $!\n"; |
| restore_ls_colors |
| }}; |
| my $slink_d = {PRE => sub {symlink '/', 'd' or die "d: $!\n"; |
| push_ls_colors('ln=01;36:di=01;34:or=40;31;01') |
| }}; |
| my $unlink_d = {POST => sub {unlink 'd' or die "d: $!\n"; restore_ls_colors}}; |
|
|
| my $mkdir_d_slink = {PRE => sub {mkdir 'd',0755 or die "d: $!\n"; |
| symlink '/', 'd/s' or die "d/s: $!\n" }}; |
| my $rmdir_d_slink = {POST => sub {unlink 'd/s' or die "d/s: $!\n"; |
| rmdir 'd' or die "d: $!\n" }}; |
|
|
| sub make_j_d () |
| { |
| mkdir 'j', 0700 or die "creating j: $!\n"; |
| mk_file 'j/d'; |
| chmod 0555, 'j/d' or die "making j/d executable: $!\n"; |
| } |
|
|
| my @v_files = ( |
| '.0', '.9', |
| '.A', '.Z', '.a', '.z', '.zz~', '.zz', '.zz.~1~', '.zz.0', |
| '0', '9', |
| 'A', 'Z', 'a', 'z', 'zz~', 'zz', 'zz.~1~', 'zz.0'); |
| my $exe_in_subdir = {PRE => sub { make_j_d (); push_ls_colors('ex=01;32') }}; |
| my $remove_j = {POST => sub {unlink 'j/d' or die "j/d: $!\n"; |
| rmdir 'j' or die "j: $!\n"; |
| restore_ls_colors }}; |
|
|
| my $e = "\e[0m"; |
| my $q_bell = {IN => {"q\a" => ''}}; |
| my @Tests = |
| ( |
| |
| |
| |
| ['q-', $q_bell, {OUT => "q\a\n"}, {EXIT => 0}], |
| ['q-N', '-N', $q_bell, {OUT => "q\a\n"}, {ERR => ''}], |
| ['q-q', '-q', $q_bell, {OUT => "q?\n"}], |
| ['q-Q', '-Q', $q_bell, {OUT => "\"q\\a\"\n"}], |
|
|
| ['q-qs-lit', '--quoting=literal', $q_bell, {OUT => "q\a\n"}], |
| ['q-qs-sh', '--quoting=shell', $q_bell, {OUT => "q\a\n"}], |
| ['q-qs-sh-a', '--quoting=shell-always',$q_bell, {OUT => "'q\a'\n"}], |
| ['q-qs-sh-e', '--quoting=shell-escape',$q_bell, {OUT => "'q'\$'\\a'\n"}], |
| ['q-qs-c', '--quoting=c', $q_bell, {OUT => "\"q\\a\"\n"}], |
| ['q-qs-esc', '--quoting=escape', $q_bell, {OUT => "q\\a\n"}], |
| ['q-qs-loc', '--quoting=locale', $q_bell, {OUT => "'q\\a'\n"}], |
| ['q-qs-cloc', '--quoting=clocale', $q_bell, {OUT => "\"q\\a\"\n"}], |
|
|
| ['q-qs-lit-q', '--quoting=literal -q', $q_bell, {OUT => "q?\n"}], |
| ['q-qs-sh-q', '--quoting=shell -q', $q_bell, {OUT => "q?\n"}], |
| ['q-qs-sh-a-q', '--quoting=shell-al -q', $q_bell, {OUT => "'q?'\n"}], |
| ['q-qs-sh-e-q', '--quoting=shell-escape -q', |
| $q_bell, {OUT => "'q'\$'\\a'\n"}], |
| ['q-qs-c-q', '--quoting=c -q', $q_bell, {OUT => "\"q\\a\"\n"}], |
| ['q-qs-esc-q', '--quoting=escape -q', $q_bell, {OUT => "q\\a\n"}], |
| ['q-qs-loc-q', '--quoting=locale -q', $q_bell, {OUT => "'q\\a'\n"}], |
| ['q-qs-cloc-q', '--quoting=clocale -q', $q_bell, {OUT => "\"q\\a\"\n"}], |
|
|
| ['q-qs-c-1', '--quoting=c', |
| {IN => {"t\004" => ''}}, {OUT => "\"t\\004\"\n"}], |
|
|
| ['emptydir', 'd', {OUT => ''}, $mkdir, $rmdir], |
| ['emptydir-x2', 'd d', {OUT => "d:\n\nd:\n"}, $mkdir, $rmdir], |
| ['emptydir-R', '-R d', {OUT => "d:\n"}, $mkdir, $rmdir], |
|
|
| |
| ['R-dot', '--ignore="[a-ce-zA-Z]*" -R .', {OUT => ".:\nd\n\n\./d:\n"}, |
| $mkdir, $rmdir], |
|
|
| ['slink-dir-F', '-F d', {OUT => "d@\n"}, $slink_d, $unlink_d], |
| ['slink-dir-dF', '-dF d', {OUT => "d@\n"}, $slink_d, $unlink_d], |
| ['slinkdir-dFH', '-dFH d', {OUT => "d/\n"}, $slink_d, $unlink_d], |
| ['slinkdir-dFL', '-dFL d', {OUT => "d/\n"}, $slink_d, $unlink_d], |
|
|
| |
| ['sl-F-color', '-F --color=always d', |
| {OUT => "$e\e[01;36md$e\@\n"}, |
| $slink_d, $unlink_d], |
| ['sl-dF-color', '-dF --color=always d', |
| {OUT => "$e\e[01;36md$e\@\n"}, |
| $slink_d, $unlink_d], |
|
|
| |
| ['no-c-empty', '--color=always d', {OUT => ""}, $mkdir, $rmdir], |
| |
| ['no-c-reg', '--color=always d', {OUT => "f\n"}, $mkdir_reg, $rmdir_reg], |
|
|
| |
| ['sl-target', '--color=always d', |
| {OUT => "$e\e[01;34mX$e\n"}, $target, $target2], |
|
|
| |
| |
| ['sl-dangle', '--color=always d', |
| {OUT => "$e\e[40;31;01mX$e\n"}, |
| {PRE => sub { |
| mkdir 'd',0755 or die "d: $!\n"; |
| symlink 'non-existent', 'd/X' or die "d/X: $!\n"; |
| push_ls_colors('or=40;31;01') |
| }}, |
| {POST => sub {unlink 'd/X' or die "d/X: $!\n"; |
| rmdir 'd' or die "d: $!\n"; |
| restore_ls_colors; }}, |
| ], |
|
|
| |
| ['sl-dangle2', '-o --time-style=+:TIME: --color=always l', |
| {OUT_SUBST => 's/.*:TIME: //'}, |
| {OUT => "l -> nowhere\n"}, |
| {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n"; |
| push_ls_colors('ln=target') |
| }}, |
| {POST => sub {unlink 'l' or die "l: $!\n"; |
| restore_ls_colors; }}, |
| ], |
| ['sl-dangle3', '-o --time-style=+:TIME: --color=always l', |
| {OUT_SUBST => 's/.*:TIME: //'}, |
| {OUT => "$e\e[40ml$e -> \e[34mnowhere$e\n"}, |
| {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n"; |
| push_ls_colors('ln=target:or=40:mi=34:') |
| }}, |
| {POST => sub {unlink 'l' or die "l: $!\n"; |
| restore_ls_colors; }}, |
| ], |
| ['sl-dangle4', '-o --time-style=+:TIME: --color=always l', |
| {OUT_SUBST => 's/.*:TIME: //'}, |
| {OUT => "$e\e[36ml$e -> \e[35mnowhere$e\n"}, |
| {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n"; |
| push_ls_colors('ln=34:mi=35:or=36:') |
| }}, |
| {POST => sub {unlink 'l' or die "l: $!\n"; |
| restore_ls_colors; }}, |
| ], |
| ['sl-dangle5', '-o --time-style=+:TIME: --color=always l', |
| {OUT_SUBST => 's/.*:TIME: //'}, |
| {OUT => "$e\e[34ml$e -> \e[35mnowhere$e\n"}, |
| {PRE => sub {symlink 'nowhere', 'l' or die "l: $!\n"; |
| push_ls_colors('ln=34:mi=35:') |
| }}, |
| {POST => sub {unlink 'l' or die "l: $!\n"; |
| restore_ls_colors; }}, |
| ], |
|
|
| |
| |
| |
| ['sl-dangle6', '-L --color=always d', |
| {OUT => "s\n"}, |
| {PRE => sub {mkdir 'd',0755 or die "d: $!\n"; |
| symlink 'dangle', 'd/s' or die "d/s: $!\n"; |
| push_ls_colors('ln=target') |
| }}, |
| {POST => sub {unlink 'd/s' or die "d/s: $!\n"; |
| rmdir 'd' or die "d: $!\n"; |
| restore_ls_colors; }}, |
| {ERR => "ls: cannot access 'd/s': No such file or directory\n"}, |
| {EXIT => 1} |
| ], |
| |
| |
| |
| |
| ['sl-dangle7', '--color=always d', |
| {OUT => "$e\e[ms$e\n"}, |
| {PRE => sub {mkdir 'd',0755 or die "d: $!\n"; |
| symlink 'dangle', 'd/s' or die "d/s: $!\n"; |
| push_ls_colors('ln=target:or=:ex=:') |
| }}, |
| {POST => sub {unlink 'd/s' or die "d/s: $!\n"; |
| rmdir 'd' or die "d: $!\n"; |
| restore_ls_colors; }}, |
| ], |
| |
| |
| |
| ['sl-dangle8', '--color=always s', |
| {OUT => "$e\e[1;36ms$e\n"}, |
| {PRE => sub {symlink 'dangle', 's' or die "s: $!\n"; |
| push_ls_colors('ln=1;36:or=:') |
| }}, |
| {POST => sub {unlink 's' or die "s: $!\n"; |
| restore_ls_colors; }}, |
| ], |
| |
| |
| |
| |
| |
| ['sl-dangle9', '--color=always d', |
| {OUT => "$e\e[1;36ms$e\n"}, |
| {PRE => sub {mkdir 'd',0755 or die "d: $!\n"; |
| symlink 'dangle', 'd/s' or die "d/s: $!\n"; |
| push_ls_colors('ln=1;36:or=:') |
| }}, |
| {POST => sub {unlink 'd/s' or die "d/s: $!\n"; |
| rmdir 'd' or die "d: $!\n"; |
| restore_ls_colors; }}, |
| ], |
|
|
| |
| |
| |
| ['color-exe1', '--color=always j', |
| {OUT => "$e\e[01;32md$e\n"}, |
| $exe_in_subdir, $remove_j], |
|
|
| |
| ['no-a-isdir-b', 'no-dir d', |
| {OUT => "d:\n"}, |
| {ERR => "ls: cannot access 'no-dir': No such file or directory\n"}, |
| $mkdir, $rmdir, {EXIT => 2}], |
|
|
| ['recursive-2', '-R d', {OUT => "d:\ne\n\nd/e:\n"}, $mkdir2, $rmdir2], |
|
|
| ['setuid-etc', '-1 -d --color=always owr owt setgid setuid sticky', |
| {OUT => |
| "$e\e[34;42mowr$e\n" |
| . "\e[30;42mowt$e\n" |
| . "\e[30;43msetgid$e\n" |
| . "\e[37;41msetuid$e\n" |
| . "\e[37;44msticky$e\n" |
| }, |
|
|
| {PRE => sub { |
| push_ls_colors('ow=34;42:tw=30;42:sg=30;43:su=37;41:st=37;44'); }}, |
| {POST => sub { |
| unlink qw(setuid setgid); |
| foreach my $dir (qw(owr owt sticky)) {rmdir $dir} |
| restore_ls_colors; }}, |
| ], |
|
|
| |
| ['file-type', '--file-type d', {OUT => "s@\n"}, |
| $mkdir_d_slink, $rmdir_d_slink], |
|
|
| |
| ['version-sort', '-v -A ' . join (' ', @v_files), |
| {OUT => join ("\n", @v_files) . "\n"}, |
| {PRE => sub { mk_file @v_files }}, |
| {POST => sub { unlink @v_files }}, |
| ], |
|
|
| |
| |
| |
| ['multi-arg-U1', '-U1 d no-such', |
| {OUT => "d:\nf\n"}, |
| {ERR_SUBST=>"s/ch':.*/ch':/"}, |
| {ERR => "$prog: cannot access 'no-such':\n"}, |
| $mkdir_reg, |
| $rmdir_reg, |
| {EXIT => 2}, |
| ], |
| ); |
|
|
| umask 022; |
|
|
| |
| delete $ENV{LS_COLORS}; |
|
|
| my $save_temps = $ENV{SAVE_TEMPS}; |
| my $verbose = $ENV{VERBOSE}; |
|
|
| setuid_setup; |
| my $fail = run_tests ($ME, $prog, \@Tests, $save_temps, $verbose); |
| $fail |
| and exit 1; |
|
|
| |
| my $env = qx/dircolors -b/; |
| $env =~ s/^LS_COLORS=\'//; |
| $env =~ s/\';.*//sm; |
| $ENV{LS_COLORS} = $env; |
|
|
| setuid_setup; |
| $fail = run_tests ($ME, $prog, \@Tests, $save_temps, $verbose); |
| exit $fail; |
|
|