├── .github └── FUNDING.yml ├── extra ├── ls_color_all.png ├── ls_color_find.png ├── ls_color_rm.png ├── ls_color_lookup.png └── ls_color_pacman.png ├── t ├── 00-load.t ├── 021-synopsis.t ├── 01-pod.t ├── 20-synopsis.t ├── 80-minperl.t ├── 30-notabs.t ├── 60-pod-syntax.t ├── 30-eol.t ├── 10-strict.t ├── 30-fixme.t ├── 60-pod-coverage.t ├── 02-pod-coverage.t ├── 40-kwalitee.t ├── 50-complexity.t └── 03-ls_color.t ├── testscripts ├── run.sh ├── lsc-env.sh ├── lsc-default.sh └── lsc-internal.sh ├── bin ├── get_ls_colors ├── ls_color_conditional ├── ls_color_lookup ├── can_ls_color ├── ls_color_nostat ├── ls_color_internal ├── ls_color_default ├── ls_color_ignorecase └── ls_color ├── MANIFEST ├── Changes ├── Makefile.PL ├── README.md ├── README └── lib └── File └── LsColor.pm /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: trapd00r 2 | -------------------------------------------------------------------------------- /extra/ls_color_all.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/trapd00r/File-LsColor/HEAD/extra/ls_color_all.png -------------------------------------------------------------------------------- /extra/ls_color_find.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/trapd00r/File-LsColor/HEAD/extra/ls_color_find.png -------------------------------------------------------------------------------- /extra/ls_color_rm.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/trapd00r/File-LsColor/HEAD/extra/ls_color_rm.png -------------------------------------------------------------------------------- /extra/ls_color_lookup.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/trapd00r/File-LsColor/HEAD/extra/ls_color_lookup.png -------------------------------------------------------------------------------- /extra/ls_color_pacman.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/trapd00r/File-LsColor/HEAD/extra/ls_color_pacman.png -------------------------------------------------------------------------------- /t/00-load.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use Test::More tests => 1; 4 | 5 | BEGIN { 6 | use_ok('File::LsColor'); 7 | } 8 | 9 | -------------------------------------------------------------------------------- /testscripts/run.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | perl -MFile::LsColor -E 'say " \e[4mFile::LsColor v" . $File::LsColor::VERSION . "\e[m"' 3 | for x in lsc-*.sh; do sh $x; echo; done 4 | -------------------------------------------------------------------------------- /t/021-synopsis.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | 4 | eval q{use Test::Synopsis}; 5 | plan skip_all => q{Test::Synopsis required for testing synopsis} if $@; 6 | 7 | all_synopsis_ok() 8 | -------------------------------------------------------------------------------- /t/01-pod.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | eval "use Test::Pod 1.00"; 4 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 5 | all_pod_files_ok(all_pod_files(qw(blib))); 6 | -------------------------------------------------------------------------------- /testscripts/lsc-env.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | printf "> environment LSCOLORS\n" 3 | for x in /a/longer/path/file.flac Makefile{,.PL} foo.{p{l,m},tar,gz,zip,png,mp3,flac,jpg,JPG} dir/ README; do 4 | echo " $x"; 5 | done | ls_color 6 | -------------------------------------------------------------------------------- /testscripts/lsc-default.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | printf "> default LSCOLORS\n" 3 | for x in /a/longer/path/file.flac Makefile{,.PL} foo.{p{l,m},tar,gz,zip,png,mp3,flac,jpg,JPG} dir/ README; do 4 | echo "$x"; 5 | done | ls_color_default 6 | -------------------------------------------------------------------------------- /testscripts/lsc-internal.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | printf "> internal LSCOLORS\n" 3 | for x in /a/longer/path/file.flac Makefile{,.PL} foo.{p{l,m},tar,gz,zip,png,mp3,flac,jpg,JPG} dir/ README; do 4 | echo " $x"; 5 | done | ls_color_internal 6 | -------------------------------------------------------------------------------- /bin/get_ls_colors: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use File::LsColor qw(get_ls_colors ls_color); 6 | 7 | for my $e(sort(keys(%{ get_ls_colors() }))) { 8 | printf("%s\n", ls_color("$e", )); 9 | } 10 | 11 | __END__ 12 | -------------------------------------------------------------------------------- /t/20-synopsis.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | eval "use Test::Synopsis"; ## no critic 7 | 8 | unless(exists($ENV{RELEASE_TESTING})) { 9 | plan skip_all => 'these tests are for release candidate testing'; 10 | } 11 | 12 | plan skip_all => 'Test::Synopsis required for testing synopsis' if $@; 13 | 14 | all_synopsis_ok() 15 | -------------------------------------------------------------------------------- /t/80-minperl.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | unless(exists($ENV{RELEASE_TESTING})) { 8 | plan skip_all => 'these tests are for release candidate testing'; 9 | } 10 | 11 | eval 'use Test::MinimumVersion'; ## no critic 12 | 13 | plan skip_all => 'Test::MinimumVersion required' if $@; 14 | 15 | all_minimum_version_ok('5.010'); 16 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | bin/get_ls_colors 2 | bin/ls_color 3 | bin/ls_color_default 4 | bin/ls_color_internal 5 | lib/File/LsColor.pm 6 | Makefile.PL 7 | MANIFEST 8 | t/00-load.t 9 | t/01-pod.t 10 | t/02-pod-coverage.t 11 | t/021-synopsis.t 12 | t/03-ls_color.t 13 | Changes 14 | README 15 | testscripts/lsc-default.sh 16 | testscripts/lsc-env.sh 17 | testscripts/lsc-internal.sh 18 | testscripts/run.sh 19 | -------------------------------------------------------------------------------- /bin/ls_color_conditional: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | 4 | 5 | use Term::ExtendedColor qw(fg); 6 | use File::LsColor qw(ls_color can_ls_color get_ls_colors); 7 | 8 | my @files = @ARGV ? @ARGV : map { chomp; $_ } <>; 9 | 10 | my $colors = get_ls_colors(); 11 | 12 | 13 | for my $file(@files) { 14 | printf "%s\n", 15 | can_ls_color($file) ? ls_color($file) : fg($colors->{di}, $file); 16 | } 17 | -------------------------------------------------------------------------------- /t/30-notabs.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # test for presence of tabs in sources 3 | 4 | use strict; 5 | use warnings; 6 | use Test::More; 7 | 8 | unless(exists($ENV{RELEASE_TESTING})) { 9 | plan skip_all => 'these tests are for release candidate testing'; 10 | } 11 | 12 | eval 'use Test::NoTabs'; ## no critic 13 | plan skip_all => 'Test::NoTabs required' if $@; 14 | 15 | all_perl_files_ok(qw/ lib t /); 16 | 17 | -------------------------------------------------------------------------------- /t/60-pod-syntax.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # test sources for POD syntax 3 | 4 | use strict; 5 | use warnings; 6 | use Test::More; 7 | 8 | unless(exists($ENV{RELEASE_TESTING})) { 9 | plan skip_all => 'these tests are for release candidate testing'; 10 | } 11 | 12 | eval 'use Test::Pod 1.22'; ## no critic 13 | plan skip_all => 'Test::Pod (>=1.22) is required' if $@; 14 | 15 | all_pod_files_ok(qw/ lib t /); 16 | 17 | -------------------------------------------------------------------------------- /t/30-eol.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # test for correct line endings 3 | 4 | use strict; 5 | use warnings; 6 | use Test::More; 7 | 8 | unless(exists($ENV{RELEASE_TESTING})) { 9 | plan skip_all => 'these tests are for release candidate testing'; 10 | } 11 | 12 | eval 'use Test::EOL'; ## no critic 13 | plan skip_all => 'Test::EOL required' if $@; 14 | 15 | all_perl_files_ok( { trailing_whitespace => 1 }, qw/ lib t / ); 16 | -------------------------------------------------------------------------------- /bin/ls_color_lookup: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use File::LsColor qw(ls_color_lookup ls_color); 6 | 7 | print "What to lookup?\n" and exit if !@ARGV; 8 | 9 | 10 | for my $what(@ARGV) { 11 | # the longest entry in my LS_COLORS is *CONTRIBUTORS 12 | my $attr = ls_color_lookup($what); 13 | $attr = '-' if ! defined $attr; 14 | 15 | printf("% 12s: %s\n", $what, $attr); 16 | } 17 | 18 | 19 | __END__ 20 | -------------------------------------------------------------------------------- /t/10-strict.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # test for syntax, strict and warnings 3 | 4 | use strict; 5 | use warnings; 6 | use Test::More; 7 | 8 | unless(exists($ENV{RELEASE_TESTING})) { 9 | plan skip_all => 'these tests are for release candidate testing'; 10 | } 11 | 12 | eval 'use Test::Strict'; ## no critic 13 | plan skip_all => 'Test::Strict required' if $@; 14 | 15 | { 16 | no warnings 'once'; 17 | $Test::Strict::TEST_WARNINGS = 0; 18 | } 19 | 20 | all_perl_files_ok(qw/ lib t /); 21 | -------------------------------------------------------------------------------- /t/30-fixme.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # test code for FIXME/BUG/TODO/XXX/NOTE labels 3 | 4 | use strict; 5 | use warnings; 6 | use Test::More; 7 | 8 | unless(exists($ENV{RELEASE_TESTING})) { 9 | plan skip_all => 'these tests are for release candidate testing'; 10 | } 11 | 12 | eval 'use Test::Fixme'; ## no critic 13 | plan skip_all => 'Test::Fixme required' if $@; 14 | 15 | run_tests( 16 | match => qr/FIXME|BUG\b|XXX/, 17 | filename_match => qr/\.(pm)$/, 18 | where => [ qw( lib ) ] 19 | ); 20 | 21 | -------------------------------------------------------------------------------- /bin/can_ls_color: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Check if a filetype or glob is defined in LS_COLORS. If it is, display it in 4 | # its color using Term::ExtendedColor::fg which can take the raw format string, 5 | # e.g 38;5;30 6 | 7 | use strict; 8 | use File::LsColor qw(can_ls_color); 9 | use Term::ExtendedColor qw(fg); 10 | 11 | my $what = $ARGV[0] // 'di'; # directory 12 | my $attr = can_ls_color($what); 13 | 14 | printf "%s: %s\n", 15 | fg(($attr ? $attr : $what) , $what), 16 | fg( ($attr ? fg(34, 'YES') : fg(196, 'NO')) ); 17 | -------------------------------------------------------------------------------- /t/60-pod-coverage.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # test sources for pod coverage 3 | 4 | use strict; 5 | use warnings; 6 | use Test::More; 7 | 8 | unless(exists($ENV{RELEASE_TESTING})) { 9 | plan skip_all => 'these tests are for release candidate testing'; 10 | } 11 | 12 | { 13 | ## no critic 14 | eval ' 15 | use Test::Pod::Coverage 1.08; 16 | use Pod::Coverage 0.18; 17 | '; 18 | } 19 | plan skip_all => 'Test::Pod::Coverage (>=1.08) and Pod::Coverage (>=0.18) are required' if $@; 20 | 21 | all_pod_coverage_ok(qw/ lib t /); 22 | 23 | -------------------------------------------------------------------------------- /t/02-pod-coverage.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | 4 | # Ensure a recent version of Test::Pod::Coverage 5 | my $min_tpc = 1.08; 6 | eval "use Test::Pod::Coverage $min_tpc"; 7 | plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" 8 | if $@; 9 | 10 | # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, 11 | # but older versions don't recognize some common documentation styles 12 | my $min_pc = 0.18; 13 | eval "use Pod::Coverage $min_pc"; 14 | plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" 15 | if $@; 16 | 17 | all_pod_coverage_ok(); 18 | -------------------------------------------------------------------------------- /t/40-kwalitee.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # test the kwalitee of a distribution 3 | 4 | use strict; 5 | use warnings; 6 | use Test::More; 7 | 8 | unless(exists($ENV{RELEASE_TESTING})) { 9 | plan skip_all => 'these tests are for release candidate testing'; 10 | } 11 | 12 | eval { 13 | require Test::Kwalitee; 14 | Test::Kwalitee->import( 15 | tests => [ 16 | qw( 17 | -has_test_pod 18 | -has_test_pod_coverage 19 | -has_readme 20 | -has_manifest 21 | -has_changelog 22 | -has_meta_yml 23 | ) 24 | ] 25 | ); 26 | }; 27 | 28 | plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@; 29 | 30 | -------------------------------------------------------------------------------- /bin/ls_color_nostat: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use lib '../lib'; 4 | use File::LsColor qw(ls_color); 5 | 6 | $File::LsColor::NO_STAT = 1; 7 | 8 | if(@ARGV) { 9 | print "$_\n" for ls_color(\@ARGV); 10 | } 11 | else { 12 | while(<>) { 13 | print ls_color($_), "\n"; 14 | } 15 | } 16 | 17 | 18 | 19 | 20 | __END__ 21 | 22 | =pod 23 | 24 | =head1 NAME 25 | 26 | ls_color - colorize input filenames just like ls does 27 | 28 | =head1 USAGE 29 | 30 | command | ls_color 31 | 32 | =head1 DESCRIPTION 33 | 34 | B demonstrates the Perl module L. 35 | 36 | =head1 EXAMPLES 37 | 38 | find $HOME/ | ls_color 39 | 40 | =head1 AUTHOR 41 | 42 | Magnus Woldrich 43 | CPAN ID: WOLDRICH 44 | m@japh.se 45 | http://japh.se 46 | 47 | =head1 REPORTING BUGS 48 | 49 | Report bugs on rt.cpan.org or to m@japh.se 50 | 51 | =head1 COPYRIGHT 52 | 53 | Copyright (C) 2011 Magnus Woldrich. All right reserved. 54 | This program is free software; you can redistribute it and/or modify 55 | it under the same terms as Perl itself. 56 | 57 | =cut 58 | 59 | # vim: set ts=2 et sw=2: 60 | -------------------------------------------------------------------------------- /bin/ls_color_internal: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use lib '../lib'; 4 | use File::LsColor qw(ls_color_internal); 5 | 6 | if(@ARGV) { 7 | print "$_\n" for ls_color_internal(\@ARGV); 8 | } 9 | else { 10 | while(<>) { 11 | print ls_color_internal($_), "\n"; 12 | } 13 | } 14 | 15 | 16 | 17 | 18 | __END__ 19 | 20 | =pod 21 | 22 | =head1 NAME 23 | 24 | ls_color_internal - colorize input filenames just like ls does 25 | 26 | =head1 USAGE 27 | 28 | command | ls_color_internal 29 | 30 | =head1 DESCRIPTION 31 | 32 | B demonstrates the Perl module L. 33 | 34 | =head1 EXAMPLES 35 | 36 | find $HOME/ | ls_color_internal 37 | 38 | =head1 AUTHOR 39 | 40 | Magnus Woldrich 41 | CPAN ID: WOLDRICH 42 | m@japh.se 43 | http://japh.se 44 | 45 | =head1 REPORTING BUGS 46 | 47 | Report bugs on rt.cpan.org or to m@japh.se 48 | 49 | =head1 COPYRIGHT 50 | 51 | Copyright (C) 2011 Magnus Woldrich. All right reserved. 52 | This program is free software; you can redistribute it and/or modify 53 | it under the same terms as Perl itself. 54 | 55 | =cut 56 | 57 | # vim: set ts=2 et sw=2: 58 | -------------------------------------------------------------------------------- /bin/ls_color_default: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use lib '../lib'; 4 | use File::LsColor qw(ls_color_default); 5 | 6 | { 7 | package File::LsColor; 8 | no strict 'vars'; 9 | $NO_STAT = $COLORIZE_PATH = $IGNORE_CASE = 0; 10 | } 11 | 12 | if(@ARGV) { 13 | print "$_\n" for ls_color_default(\@ARGV); 14 | } 15 | else { 16 | while(<>) { 17 | print ls_color_default($_), "\n"; 18 | } 19 | } 20 | 21 | 22 | 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =head1 NAME 29 | 30 | ls_color_default - colorize input filenames just like ls does 31 | 32 | =head1 USAGE 33 | 34 | command | ls_color_default 35 | 36 | =head1 DESCRIPTION 37 | 38 | B demonstrates the Perl module L. 39 | 40 | =head1 EXAMPLES 41 | 42 | find $HOME/ | ls_color_default 43 | 44 | =head1 AUTHOR 45 | 46 | Magnus Woldrich 47 | CPAN ID: WOLDRICH 48 | m@japh.se 49 | http://japh.se 50 | 51 | =head1 REPORTING BUGS 52 | 53 | Report bugs on rt.cpan.org or to m@japh.se 54 | 55 | =head1 COPYRIGHT 56 | 57 | Copyright (C) 2011 Magnus Woldrich. All right reserved. 58 | This program is free software; you can redistribute it and/or modify 59 | it under the same terms as Perl itself. 60 | 61 | =cut 62 | 63 | # vim: set ts=2 et sw=2: 64 | -------------------------------------------------------------------------------- /t/50-complexity.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # test sources by Perl Code Metrics System 3 | 4 | use strict; 5 | use warnings; 6 | use Test::More; 7 | 8 | unless(exists($ENV{RELEASE_TESTING})) { 9 | plan skip_all => 'these tests are for release candidate testing'; 10 | } 11 | 12 | { 13 | ## no critic 14 | eval ' 15 | use Perl::Metrics::Simple; 16 | use File::Find::Rule (); 17 | use File::Find::Rule::Perl (); 18 | '; 19 | } 20 | plan skip_all => 'Perl::Metrics::Simple, File::Find::Rule and File::Find::Rule::Perl required' if $@; 21 | 22 | # configure this to match your needs 23 | my $max_complexity = 40; 24 | my $max_lines = 80; 25 | 26 | my @files = File::Find::Rule->perl_file->in(qw/ lib t /); 27 | my $analzyer = Perl::Metrics::Simple->new; 28 | my @subs; 29 | 30 | foreach (@files) { 31 | my $analysis = $analzyer->analyze_files($_); 32 | push( @subs, $_ ) foreach ( @{ $analysis->subs } ); 33 | } 34 | 35 | plan tests => ( scalar @subs ) * 2; 36 | 37 | foreach my $sub (@subs) { 38 | my $name = $sub->{name} . ' in ' . $sub->{path}; 39 | my $complexity = $sub->{mccabe_complexity}; 40 | my $lines = $sub->{lines}; 41 | 42 | ok( $complexity <= $max_complexity, "Cyclomatic comlexity for $name is too big ($complexity > $max_complexity)" ); 43 | ok( $lines <= $max_lines, "Lines count for $name is too big ($lines > $max_lines)" ); 44 | } 45 | 46 | -------------------------------------------------------------------------------- /bin/ls_color_ignorecase: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use lib '../lib'; 4 | use vars qw($VERSION); 5 | 6 | $VERSION = '0.052'; 7 | 8 | use Pod::Usage; 9 | use Getopt::Long; 10 | use File::LsColor qw(ls_color); 11 | 12 | Getopt::Long::Configure qw(bundling auto_version); 13 | 14 | $File::LsColor::IGNORE_CASE = 1; 15 | 16 | my %option; 17 | 18 | $option{IFS} = '/'; 19 | 20 | GetOptions( 21 | 'k:i' => \$option{key}, 22 | 'ifs:s' => \$option{IFS}, 23 | 'h|help' => sub { pod2usage(verbose => 1); exit }, 24 | ); 25 | 26 | 27 | while(<>) { 28 | chomp; 29 | printf "%s\n", $option{key} ? by_key($_) : ls_color($_); 30 | } 31 | 32 | 33 | 34 | sub by_key { 35 | my $line = shift; 36 | my $filename; 37 | 38 | my ($delimiter) = $line =~ m/($option{IFS})/; 39 | 40 | my @line_parts = split(/$option{IFS}/g, $line); 41 | 42 | # -k2 equals array index 1 43 | my $requested_column = $line_parts[$option{key} - 1]; 44 | 45 | $line_parts[$option{key} -1] = ls_color($requested_column); 46 | 47 | 48 | return join($delimiter, @line_parts); 49 | 50 | } 51 | 52 | 53 | 54 | 55 | __END__ 56 | 57 | =pod 58 | 59 | =head1 NAME 60 | 61 | ls_color - colorize input filenames just like ls does 62 | 63 | =head1 USAGE 64 | 65 | command | ls_color [OPTIONS] 66 | 67 | =head1 DESCRIPTION 68 | 69 | B demonstrates the Perl module L. 70 | 71 | =head1 OPTIONS 72 | 73 | -k, --key look for filenames in field n 74 | --ifs set input field separator 75 | 76 | -h, --help display this help and exit 77 | 78 | =head1 EXAMPLES 79 | 80 | find $HOME/ | ls_color 81 | 82 | du -h --max-depth=1 "$@" | sort -k 1,1hr -k 2,2f | ls_color -k2 83 | 84 | # cheap mans ls++ 85 | find "$@" -printf "%M | %TY-%Tm-%Td | %d%y %f -> (%.20P)\n" | ls_color -k6 86 | 87 | =head1 AUTHOR 88 | 89 | Magnus Woldrich 90 | CPAN ID: WOLDRICH 91 | m@japh.se 92 | http://japh.se 93 | https://github.com/trapd00r 94 | 95 | =head1 REPORTING BUGS 96 | 97 | Report bugs on rt.cpan.org or to m@japh.se 98 | 99 | =head1 COPYRIGHT 100 | 101 | Copyright (C) 2011, 2019- Magnus Woldrich. All right reserved. This 102 | program is free software; you can redistribute it and/or modify it under 103 | the same terms as Perl itself. 104 | 105 | 106 | =cut 107 | 108 | # vim: set ts=2 et sw=2: 109 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | 2 | 0.544 2023-12-23 3 | - fix a bug introduced by the $File::LsColor::COLORIZE_PATH variable 4 | that manifested itself when the variable was set and no definition 5 | to color the file by extension or other means was found. 6 | 0.540 2021-10-09 7 | - introducing $File::LsColor::COLORIZE_PATH variable. 8 | If set (new default), given a path like ~/foo/bar.flac, everything 9 | prior to the basename will be colored as per the LS_COLORS directory 10 | specification, while the actual base filename will be colored 11 | according to the file extension specification. 12 | 13 | 0.530 2021-05-24 14 | - introducing File::LsColor::slack_code_to_ls_code. 15 | Given a 'slack name', returns the short form of the ls code. 16 | 17 | 0.520 2021-04-27 18 | - introducing $File::LsColor::IGNORE_CASE variable. If set, case is ignored 19 | for file extensions. 20 | 21 | 0.506 2019-04-15 22 | - No functional changes. 23 | - add meta 'provides' field for kwalitee. 24 | 25 | 0.504 2019-04-08 26 | - bin/ls_color now properly splits a line and adds back the input field 27 | separator. Added some advanced examples to the docs. 28 | 29 | 0.501 2019-04-04 30 | - bin/ls_color now accepts a --key option similar to sort(1). The input field 31 | separator can be set as well. Useful to colorize filenames that can be 32 | aligned in columns other than the first; see examples section. 33 | 34 | 0.500 2019-03-24 35 | - Fix character device indicator to be cd, not ca 36 | 37 | 0.499 2019-03-22 38 | - introducing $File::LsColor::NO_STAT variable. If set, no stat() will be 39 | made. This can be desired if the filenames aren't real files, or for 40 | performance reasons. 41 | 42 | 0.498 2019-03-17 43 | - fix bug in can_ls_color() that made the function return undef when it 44 | shouldn't 45 | 46 | 0.495 2019-03-11 47 | - if LS_COLORS env var is unset, use the default gnu specification from 48 | dircolors. 49 | 50 | 0.492 2019-03-09 51 | - properly support dircolors keys with a wildcard and no extension, for 52 | example *MANIFEST, *README 53 | - can_ls_color() can now accept whitespace padded queries as well as both a 54 | naked extension and a full filname, e.g perl_is_best.pm 55 | - now properly support the following file attributes: 56 | * symlink 57 | * executable 58 | * directories 59 | * sockets 60 | * named pipes 61 | * block devices 62 | * character special files 63 | 64 | keep in mind that since a stat() needs to take place, this will only work 65 | with resolvable paths to real files. 66 | - the GNU default dircolors have been updated. 67 | -------------------------------------------------------------------------------- /bin/ls_color: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use lib '../lib'; 4 | use vars qw($VERSION); 5 | 6 | $VERSION = '0.056'; 7 | 8 | use Pod::Usage; 9 | use Getopt::Long; 10 | use File::LsColor qw(ls_color); 11 | 12 | Getopt::Long::Configure qw(bundling auto_version); 13 | 14 | my %option; 15 | 16 | $option{IFS} = '/'; 17 | 18 | GetOptions( 19 | 'k:i' => \$option{key}, 20 | 'ifs:s' => \$option{IFS}, 21 | 'paths' => sub { $File::LsColor::COLORIZE_PATH = 0; }, 22 | 'h|help' => sub { pod2usage(verbose => 1); exit }, 23 | ); 24 | 25 | my $filename = shift; 26 | 27 | # we do not really care if the filename is a real file or not. 28 | if(not defined($filename)) { 29 | while(<>) { 30 | chomp; 31 | printf "%s\n", $option{key} ? by_key($_) : ls_color($_); 32 | } 33 | } 34 | else { 35 | printf "%s\n", ls_color($filename); 36 | } 37 | 38 | 39 | 40 | sub by_key { 41 | my $line = shift; 42 | my $filename; 43 | 44 | my ($delimiter) = $line =~ m/($option{IFS})/; 45 | 46 | my @line_parts = split(/$option{IFS}/g, $line); 47 | 48 | # -k2 equals array index 1 49 | my $requested_column = $line_parts[$option{key} - 1]; 50 | 51 | $line_parts[$option{key} -1] = ls_color($requested_column); 52 | 53 | 54 | return join($delimiter, @line_parts); 55 | 56 | } 57 | 58 | 59 | 60 | 61 | __END__ 62 | 63 | =pod 64 | 65 | =head1 NAME 66 | 67 | ls_color - colorize input filenames just like ls does 68 | 69 | =head1 USAGE 70 | 71 | command | ls_color [OPTIONS] 72 | 73 | =head1 DESCRIPTION 74 | 75 | B demonstrates the Perl module L. 76 | 77 | =head1 OPTIONS 78 | 79 | -k, --key look for filenames in field n 80 | --ifs set input field separator 81 | --paths colorize the entire path as per old default 82 | 83 | -h, --help display this help and exit 84 | 85 | =head1 EXAMPLES 86 | 87 | find $HOME/ | ls_color 88 | 89 | du -h --max-depth=1 "$@" | sort -k 1,1hr -k 2,2f | ls_color -k2 90 | 91 | # cheap mans ls++ 92 | find "$@" -printf "%M | %TY-%Tm-%Td | %d%y %f -> (%.20P)\n" | ls_color -k6 93 | 94 | =head1 AUTHOR 95 | 96 | Magnus Woldrich 97 | CPAN ID: WOLDRICH 98 | m@japh.se 99 | http://japh.se 100 | https://github.com/trapd00r 101 | 102 | =head1 REPORTING BUGS 103 | 104 | Report bugs on rt.cpan.org or to m@japh.se 105 | 106 | =head1 COPYRIGHT 107 | 108 | Copyright (C) 2011, 2019- Magnus Woldrich. All right reserved. This 109 | program is free software; you can redistribute it and/or modify it under 110 | the same terms as Perl itself. 111 | 112 | 113 | =cut 114 | 115 | # vim: set ts=2 et sw=2: 116 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use ExtUtils::MakeMaker; 4 | 5 | WriteMakefile1( 6 | META_MERGE => { 7 | q(meta-spec) => { 8 | version => 2 9 | }, 10 | 11 | resources => { 12 | homepage => q{http://japh.se/dev/file-lscolor/}, 13 | bugtracker => { 14 | web => q{https://github.com/trapd00r/File-LsColor/issues}, 15 | mailto => q{m@japh.se}, 16 | }, 17 | repository => { 18 | type => 'git', 19 | url => 'https://github.com/trapd00r/File-LsColor.git', 20 | web => 'https://github.com/trapd00r/File-LsColor', 21 | }, 22 | }, 23 | }, 24 | 25 | # this makes version from logic fail - why? 26 | # META_ADD => { 27 | # provides => { 28 | # 'File::LsColor' => { 29 | # file => 'lib/File/LsColor.pm', 30 | # }, 31 | # }, 32 | # }, 33 | 34 | NAME => q{File::LsColor}, 35 | AUTHOR => q{Magnus Woldrich }, 36 | ABSTRACT => q{Colorize input filenames like ls(1)}, 37 | VERSION_FROM => q{lib/File/LsColor.pm}, 38 | LICENSE => q{perl}, 39 | MIN_PERL_VERSION => 5.0040, 40 | EXE_FILES => [ glob("bin/*") ], 41 | 42 | PREREQ_PM => { 43 | q{Term::ExtendedColor} => q{0.500}, 44 | }, 45 | 46 | MAN1PODS => { }, 47 | dist => { COMPRESS => q{gzip -9f}, SUFFIX => q{gz}, }, 48 | clean => { FILES => q{File-LsColor-*}, }, 49 | ); 50 | 51 | sub WriteMakefile1 { 52 | my %params = @_; 53 | my $eumm_version = $ExtUtils::MakeMaker::VERSION; 54 | $eumm_version = eval $eumm_version; 55 | die "EXTRA_META is deprecated" if exists $params{EXTRA_META}; 56 | die "License not specified" if not exists $params{LICENSE}; 57 | if ($params{AUTHOR} and ref($params{AUTHOR}) eq q{ARRAY} 58 | and $eumm_version < 6.5705) { 59 | $params{META_ADD}->{author}=$params{AUTHOR}; 60 | $params{AUTHOR}=join(', ',@{$params{AUTHOR}}); 61 | } 62 | if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) { 63 | #EUMM 6.5502 has problems with BUILD_REQUIRES 64 | $params{PREREQ_PM}={ 65 | %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} 66 | }; 67 | delete $params{BUILD_REQUIRES}; 68 | } 69 | delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52; 70 | delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48; 71 | delete $params{META_MERGE} if $eumm_version < 6.46; 72 | delete $params{META_ADD} if $eumm_version < 6.46; 73 | delete $params{LICENSE} if $eumm_version < 6.31; 74 | delete $params{AUTHOR} if $] < 5.005; 75 | delete $params{ABSTRACT_FROM} if $] < 5.005; 76 | delete $params{BINARY_LOCATION} if $] < 5.005; 77 | 78 | #delete $params{MAN3PODS}->{'README.pod'}; 79 | 80 | WriteMakefile(%params); 81 | } 82 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Donate](https://img.shields.io/badge/Donate-PayPal-green.svg)](https://www.paypal.com/cgi-bin/webscr?cmd=_donations&business=65SFZJ25PSKG8¤cy_code=SEK&source=url) - Every tiny cent helps a lot! 2 | 3 | # NAME 4 | 5 | File::LsColor - Colorize input filenames just like ls does 6 | 7 | 8 | 9 | 10 | # SYNOPSIS 11 | 12 | use File::LsColor qw(:all); 13 | # Is equal to: 14 | use File::LsColor qw( 15 | ls_color 16 | ls_color_custom 17 | ls_color_default 18 | ls_color_internal 19 | ); 20 | 21 | my @files = glob("$ENV{HOME}/*"); 22 | 23 | print ls_color($_), "\n" for(@files); 24 | 25 | # or specify own pattern 26 | 27 | @files = ls_color_custom('*.pl=38;5;196;1:*.pm=38;5;220', @files); 28 | 29 | # or use the internal mappings 30 | 31 | @files = ls_color_internal(@files); 32 | 33 | # or use the defaults (only ANSI colors) 34 | 35 | @files = ls_color_default(@files); 36 | 37 | ... 38 | 39 | # returns a hashref with all defined filetypes and their attributes 40 | my $ls_colors = get_ls_colors(); 41 | 42 | # what's the defined attributes for directories? 43 | 44 | my $dir_color = lookup_ls_color('di'); 45 | 46 | 47 | # DESCRIPTION 48 | 49 | This module provides functionality for using the LS\_COLORS variable for 50 | colorizing output in a way that's immediately recognized. 51 | 52 | Say that you have a list of filenames that's the result of some complex 53 | operation, and you wish to present the result to the user. 54 | 55 | If said files have an extension and that extension is present in the users 56 | LS\_COLORS variable, they will be colored just like they would have been if the 57 | filenames were output from [ls(1)](http://man.he.net/man1/ls) or [tree(1)](http://man.he.net/man1/tree). 58 | 59 | # EXPORTS 60 | 61 | None by default. 62 | 63 | # FUNCTIONS 64 | 65 | ## ls\_color() 66 | 67 | Arguments: @files | \\@files 68 | 69 | Returns: $files | @files 70 | 71 | Returns a list of filenames colored as specified by the environment `LS_COLORS` 72 | variable. If the `LS_COLORS` variable is not set, throws an exception. 73 | In this case, `ls_color_internal()` can be used. 74 | 75 | In scalar context a string joined by '' is returned. 76 | 77 | ## ls\_color\_default() 78 | 79 | The same thing as `ls_color()`, but uses the default LS\_COLORS values from GNU 80 | ls. Those are only ANSI colors. 81 | 82 | ## ls\_color\_internal() 83 | 84 | The same as `ls_color()`, with one minor difference; Instead of using the 85 | LS\_COLORS variable from the environment, an internal specification is used. 86 | This specification contains about 250 extensions as of this writing. 87 | 88 | ## ls\_color\_custom() 89 | 90 | The first argument to `ls_color_custom()` should be a valid LS\_COLORS 91 | definition, like so: 92 | 93 | ls_color_custom("*.pl=38;5;196:*.pm=38;5;197;1", @perl_files); 94 | 95 | ## get\_ls\_colors() 96 | 97 | Returns a hash reference where a key is the extension and its value is the 98 | attributes attached to it. 99 | 100 | ## lookup\_ls\_color() 101 | 102 | Given a valid name, returns the defined attributes associated with it. 103 | Else, returns undef. 104 | 105 | 106 | ## File::LsColor out in the wild 107 | 108 | * [fileutils-color](https://github.com/trapd00r/fileutils-color) 109 | 110 | * [pimpd2](https://github.com/trapd00r/pimpd2) 111 | 112 | * [time-spent-in-vim](https://github.com/trapd00r/time-spent-in-vim) 113 | 114 | * [accesstail](https://github.com/trapd00r/accesstail) 115 | 116 | * [makedist](https://github.com/trapd00r/makedist) 117 | 118 | 119 | # AUTHOR 120 | 121 | Magnus Woldrich 122 | CPAN ID: WOLDRICH 123 | m@japh.se 124 | http://japh.se 125 | https://github.com/trapd00r 126 | 127 | # REPORTING BUGS 128 | 129 | Report bugs on [https://github.com/trapd00r/File-LsColor](https://github.com/trapd00r/File-LsColor) or to m@japh.se 130 | 131 | # COPYRIGHT 132 | 133 | Copyright 2011, 2018, 2019- the **File::LsColor** ["AUTHOR"](#author) and 134 | ["CONTRIBUTORS"](#contributors) as listed above. 135 | 136 | # LICENSE 137 | 138 | This library is free software; you may redistribute it and/or modify it under 139 | the same terms as Perl itself. 140 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | NAME 2 | File::LsColor - Colorize input filenames just like ls does 3 | 4 | SYNOPSIS 5 | use File::LsColor qw(:all); 6 | # Is equal to: 7 | use File::LsColor qw( 8 | ls_color 9 | ls_color_custom 10 | ls_color_default 11 | ls_color_internal 12 | get_ls_colors 13 | can_ls_color 14 | ls_color_lookup 15 | parse_ls_colors 16 | ); 17 | 18 | 19 | my @files = glob("$ENV{HOME}/*"); 20 | 21 | print "$_\n" for ls_color @files; 22 | 23 | # or specify own pattern 24 | 25 | @files = ls_color_custom('*.pl=38;5;196;1:*.pm=38;5;220', @files); 26 | 27 | # or use the internal mappings 28 | 29 | @files = ls_color_internal(@files); 30 | 31 | # or use the defaults (only ANSI colors) 32 | 33 | @files = ls_color_default(@files); 34 | 35 | 36 | # returns a hashref with all defined filetypes and their attributes 37 | my $ls_colors = get_ls_colors(); 38 | 39 | # what's the defined attributes for directories? 40 | 41 | my $dir_color = can_ls_color('di'); 42 | 43 | # can we apply attributes to this filetype? 44 | my $filetype = shift; 45 | printf "%s can be colored.\n" if can_ls_color($filetype); 46 | 47 | # apply terminal color even if we can't use LS_COLORS to do so. 48 | my $file_with_extension = 'foobar.flac'; 49 | printf "%s looks nice.\n", can_ls_color($file_with_extension) 50 | ? ls_color($file_with_extension) 51 | : Term::ExtendedColor::fg(32, $file_with_extension); 52 | 53 | DESCRIPTION 54 | This module provides functionality for using the LS_COLORS variable for 55 | colorizing output in a way that's immediately recognized. 56 | 57 | Say that you have a list of filenames that's the result of some complex 58 | operation, and you wish to present the result to the user. 59 | 60 | If said files have an extension and that extension is present in the 61 | users LS_COLORS variable, they will be colored just like they would have 62 | been if the filenames were output from ls(1) or tree(1). 63 | 64 | EXPORTS 65 | None by default. 66 | 67 | FUNCTIONS 68 | ls_color() 69 | Arguments: @files | \@files 70 | 71 | Returns: @files | @files 72 | 73 | Returns a list of filenames colored as specified by the environment 74 | "LS_COLORS" variable. If the "LS_COLORS" variable is not set, throws an 75 | exception. In this case, "ls_color_internal()" can be used. 76 | 77 | In scalar context a string joined by '' is returned. 78 | 79 | ls_color_default() 80 | The same thing as "ls_color()", but uses the default LS_COLORS values 81 | from GNU ls. Those are only ANSI colors. 82 | 83 | ls_color_internal() 84 | The same as "ls_color()", with one minor difference; Instead of using 85 | the LS_COLORS variable from the environment, an internal specification 86 | is used. This specification contains about 250 extensions as of this 87 | writing. 88 | 89 | ls_color_custom() 90 | The first argument to "ls_color_custom()" should be a valid LS_COLORS 91 | definition, like so: 92 | 93 | ls_color_custom("*.pl=38;5;196:*.pm=38;5;197;1", @perl_files); 94 | 95 | get_ls_colors() 96 | Returns a hash reference where a key is the extension and its value is 97 | the attributes attached to it. 98 | 99 | can_ls_color() 100 | Arguments: $file Returns: $attributes 101 | 102 | Given a valid name, returns the defined attributes associated with it. 103 | Else, returns undef. 104 | 105 | ls_color_lookup() 106 | The same as can_ls_color(), exportable because of compatibility reasons. 107 | 108 | parse_ls_colors() 109 | Arguments: $string 110 | Returns: \%hash 111 | Returns a hashref with extension => attribute mappings, i.e: 112 | 113 | '7z' => '01;31', 114 | 'aac' => '00;36', 115 | 'ace' => '01;31', 116 | 'anx' => '01;35', 117 | 'arj' => '01;31', 118 | 119 | AUTHOR 120 | Magnus Woldrich 121 | CPAN ID: WOLDRICH 122 | m@japh.se 123 | http://japh.se 124 | https://github.com/trapd00r 125 | 126 | REPORTING BUGS 127 | Report bugs on or to 128 | m@japh.se 129 | 130 | CONTRIBUTORS 131 | None required yet. 132 | 133 | COPYRIGHT 134 | Copyright 2011, 2018, 2019- the File::LsColor "AUTHOR" and 135 | "CONTRIBUTORS" as listed above. 136 | 137 | LICENSE 138 | This library is free software; you may redistribute it and/or modify it 139 | under the same terms as Perl itself. 140 | 141 | -------------------------------------------------------------------------------- /t/03-ls_color.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # vim: ft=perl:fdm=marker:fmr=#<,#>:fen:et:sw=2: 3 | 4 | ################################################################################ 5 | # Be aware that we have to enclose the escape sequences in double quotes 6 | # while testing, or else the compare will fail. 7 | ################################################################################ 8 | 9 | 10 | use strict; 11 | use warnings; 12 | use Test::More tests => 9; 13 | #use Data::Dumper; 14 | # 15 | #{ 16 | # package Data::Dumper; 17 | # no strict 'vars'; 18 | # $Terse = $Indent = $Useqq = $Deparse = $Sortkeys = 1; 19 | # $Quotekeys = 0; 20 | #} 21 | 22 | use File::LsColor qw( 23 | ls_color 24 | ls_color_default 25 | parse_ls_colors 26 | can_ls_color 27 | ); 28 | 29 | ################################################################################ 30 | # Due to the nature of environment variables, we can't predict the value 31 | # on other systems. Therefore, we have to override the internal function 32 | # for parsing LS_COLORS from the system. 33 | ################################################################################ 34 | 35 | *File::LsColor::parse_ls_colors = *mocklscolors; 36 | 37 | sub mocklscolors { 38 | my $mock = { 39 | '.pl' => '38;5;197', 40 | '.pm' => '38;5;220;1;3;4;7;48;5;196', 41 | 'di' => '38;5;31', 42 | '.pl' => '38;5;197', 43 | '.txt' => '38;5;42', 44 | '.mp3' => '38;5;44', 45 | 'case.flac' => '48;5;196', 46 | 'case.FLAC' => '38;5;65', 47 | 'README' => '38;5;220;1', 48 | }; 49 | 50 | return $mock; 51 | } 52 | 53 | 54 | my $fullpath = '/usr/share/perl5/core_perl/laleh.pm'; 55 | my $file_with_extension = '~/tmp/laleh.mp3'; 56 | my $file_without_extension = '~/tmp/Makefile.PL'; 57 | 58 | 59 | ################################################################################ 60 | # Test 1: A full path with $COLORIZE_PATH set, using nested escape sequences. 61 | ################################################################################ 62 | $File::LsColor::COLORIZE_PATH = 1; 63 | 64 | is( 65 | ls_color_default($fullpath), 66 | "\e[38;5;31m/usr/share/perl5/core_perl/\e[m\e[38;5;220;1;3;4;7;48;5;196mlaleh.pm\e[m", 67 | '+COLORIZE_PATH path with nested escape sequences', 68 | ); 69 | 70 | ################################################################################ 71 | # Test 1: A full path with $COLORIZE_PATH unset, using nested escape sequences. 72 | ################################################################################ 73 | $File::LsColor::COLORIZE_PATH = 0; 74 | 75 | is( 76 | ls_color_default($fullpath), 77 | "\e[38;5;220;1;3;4;7;48;5;196m/usr/share/perl5/core_perl/laleh.pm\e[m", 78 | '-COLORIZE_PATH path with extension', 79 | ); 80 | 81 | 82 | ################################################################################ 83 | # Test 3: 84 | ################################################################################ 85 | $File::LsColor::COLORIZE_PATH = 1; 86 | 87 | is( 88 | ls_color_default($file_with_extension), 89 | "\e[38;5;31m~/tmp/\e[m\e[38;5;44mlaleh.mp3\e[m", 90 | '+COLORIZE_PATH path with extension', 91 | ); 92 | 93 | ################################################################################ 94 | # Test 4: Can we color file? 95 | ################################################################################ 96 | 97 | is( 98 | can_ls_color('file.pl'), 99 | '38;5;197', 100 | 'can_ls_color("file.pl")', 101 | ); 102 | 103 | ################################################################################ 104 | # Test 5: Can we color a directory by 'di' key? 105 | ################################################################################ 106 | 107 | 108 | is( 109 | can_ls_color('di'), 110 | '38;5;31', 111 | 'can_ls_color("di")', 112 | ); 113 | 114 | ################################################################################ 115 | # Test 6: Can we color a file with no extension? 116 | ################################################################################ 117 | 118 | is( 119 | can_ls_color('README'), 120 | '38;5;220;1', 121 | 'can_ls_color("README"), (file without extension)', 122 | ); 123 | 124 | ################################################################################ 125 | # Test 7, 8: Can we color a file differently with an uppercase extension? 126 | ################################################################################ 127 | $File::LsColor::IGNORE_CASE = 0; 128 | 129 | is( 130 | can_ls_color('case.flac'), 131 | '48;5;196', 132 | 'color uppercase extension differently', 133 | ); 134 | 135 | $File::LsColor::IGNORE_CASE = 1; 136 | is( 137 | can_ls_color('case.FLAC'), 138 | '48;5;196', 139 | 'color uppercase extension as lowercase when IGNORE_CASE set', 140 | ); 141 | ################################################################################ 142 | # Test 9: Parsing of LS_COLORS 143 | ################################################################################ 144 | 145 | my $parsed = parse_ls_colors('.patch=31;1:*MANIFEST=38;5;243'); 146 | 147 | is($parsed->{'.patch'}, '31;1', 'parse_ls_colors() OK'); 148 | 149 | 150 | done_testing(); 151 | -------------------------------------------------------------------------------- /lib/File/LsColor.pm: -------------------------------------------------------------------------------- 1 | package File::LsColor; 2 | use strict; 3 | #use warnings; 4 | 5 | BEGIN { 6 | use Exporter; 7 | use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS); 8 | 9 | $VERSION = '0.544'; 10 | @ISA = qw(Exporter); 11 | 12 | @EXPORT_OK = qw( 13 | ls_color 14 | ls_color_custom 15 | ls_color_default 16 | ls_color_internal 17 | get_ls_colors 18 | can_ls_color 19 | ls_color_lookup 20 | parse_ls_colors 21 | slack_code_to_ls_code 22 | ); 23 | 24 | %EXPORT_TAGS = ( 25 | all => [ 26 | qw( 27 | ls_color ls_color_custom ls_color_default ls_color_internal 28 | get_ls_colors can_ls_color ls_color_lookup parse_ls_colors 29 | slack_code_to_ls_code 30 | ) 31 | ], 32 | ); 33 | } 34 | 35 | ################################################################################ 36 | # If set, skip stat:ing files for attributes like +x. 37 | # This can be desired if the filename aren't real files, or for performance 38 | # reasons. 39 | # 40 | # Interesting read: https://github.com/trapd00r/File-LsColor/issues/7 41 | ################################################################################ 42 | our $NO_STAT = 0; 43 | 44 | ################################################################################ 45 | # If set, ignore case on file extensions. 46 | ################################################################################ 47 | our $IGNORE_CASE = 0; 48 | 49 | ################################################################################ 50 | # If set, given a path like ~/foo/bar.flac, everything prior to the basename 51 | # will be colored according to the LS_COLORS directory specification (the 'di' 52 | # key), while the actual base filename will be colored according to the file 53 | # extension specification. 54 | # 55 | # New default since v0.540, 2021-10-09! 56 | ################################################################################ 57 | our $COLORIZE_PATH = 1; 58 | 59 | ################################################################################ 60 | # This is an alias for compatibility reasons with File::LsColor prior to v0.300. 61 | ################################################################################ 62 | { 63 | no warnings 'once'; 64 | *ls_color_lookup = *can_ls_color; 65 | } 66 | 67 | use Term::ExtendedColor qw(fg); 68 | 69 | 70 | # 215 | 216 | ################################################################################ 217 | # If the $LS_COLORS environment variable is unset, use the default GNU 218 | # specification from dircolors. 219 | ################################################################################ 220 | my $extracted_ls_colors; 221 | my $LS_COLORS = defined($ENV{LS_COLORS}) ? $ENV{LS_COLORS} : $ls_colors_default; 222 | 223 | ################################################################################ 224 | # This is for situations like: 225 | # *.pl=38;5;196;1 (red with bold attribute) 226 | ################################################################################ 227 | my %attributes = ( 228 | 1 => 'bold', 229 | 2 => 'faint', 230 | 3 => 'italic', 231 | 4 => 'underline', 232 | 5 => 'blink', 233 | 6 => 'blink_ms', 234 | 7 => 'reverse', 235 | ); 236 | 237 | ################################################################################ 238 | # This is the internal LS_COLORS specification, taken from: 239 | # https://github.com/trapd00r/LS_COLORS 240 | ################################################################################ 241 | sub ls_color_internal { 242 | $LS_COLORS = $internal_ls_color; 243 | $extracted_ls_colors = parse_ls_colors($LS_COLORS); 244 | ls_color(@_); 245 | } 246 | 247 | ################################################################################ 248 | # Ability to use a custom specification, like so: 249 | # 250 | # ls_color_custom( 251 | # { 252 | # '.pl' => '38;5;196;1', 253 | # 'Changes' => '48;5;197;38;5;220;1;3;4;8', 254 | # } 255 | # ); 256 | ################################################################################ 257 | sub ls_color_custom { 258 | $LS_COLORS = shift; 259 | $extracted_ls_colors = parse_ls_colors($LS_COLORS); 260 | ls_color(@_); 261 | } 262 | 263 | ################################################################################ 264 | # These are the default dircolors mappings from GNU dircolors/ls. This is what 265 | # ls defaults to when the $LS_COLORS environment variable is unset. 266 | ################################################################################ 267 | sub ls_color_default { 268 | $LS_COLORS= ' 269 | rs=0:di=01;34:ln=01;36:mh=00:pi=40;33:so=01;35:do=01;35:bd=40;33;01: 270 | cd=40;33;01:or=40;31;01:mi=00:su=37;41:sg=30;43:ca=30;41:tw=30;42: 271 | ow=34;42:st=37;44:ex=01;32:*.tar=01;31:*.tgz=01;31:*.arc=01;31:*.arj=01;31: 272 | *.taz=01;31:*.lha=01;31:*.lz4=01;31:*.lzh=01;31:*.lzma=01;31:*.tlz=01;31: 273 | *.txz=01;31:*.tzo=01;31:*.t7z=01;31:*.zip=01;31:*.z=01;31:*.dz=01;31: 274 | *.gz=01;31:*.lrz=01;31:*.lz=01;31:*.lzo=01;31:*.xz=01;31:*.zst=01;31: 275 | *.tzst=01;31:*.bz2=01;31:*.bz=01;31:*.tbz=01;31:*.tbz2=01;31:*.tz=01;31: 276 | *.deb=01;31:*.rpm=01;31:*.jar=01;31:*.war=01;31:*.ear=01;31:*.sar=01;31: 277 | *.rar=01;31:*.alz=01;31:*.ace=01;31:*.zoo=01;31:*.cpio=01;31:*.7z=01;31: 278 | *.rz=01;31:*.cab=01;31:*.wim=01;31:*.swm=01;31:*.dwm=01;31:*.esd=01;31: 279 | *.jpg=01;35:*.jpeg=01;35:*.mjpg=01;35:*.mjpeg=01;35:*.gif=01;35:*.bmp=01;35 280 | :*.pbm=01;35:*.pgm=01;35:*.ppm=01;35:*.tga=01;35:*.xbm=01;35:*.xpm=01;35: 281 | *.tif=01;35:*.tiff=01;35:*.png=01;35:*.svg=01;35:*.svgz=01;35:*.mng=01;35: 282 | *.pcx=01;35:*.mov=01;35:*.mpg=01;35:*.mpeg=01;35:*.m2v=01;35:*.mkv=01;35: 283 | *.webm=01;35:*.ogm=01;35:*.mp4=01;35:*.m4v=01;35:*.mp4v=01;35:*.vob=01;35: 284 | *.qt=01;35:*.nuv=01;35:*.wmv=01;35:*.asf=01;35:*.rm=01;35:*.rmvb=01;35: 285 | *.flc=01;35:*.avi=01;35:*.fli=01;35:*.flv=01;35:*.gl=01;35:*.dl=01;35: 286 | *.xcf=01;35:*.xwd=01;35:*.yuv=01;35:*.cgm=01;35:*.emf=01;35:*.ogv=01;35: 287 | *.ogx=01;35:*.aac=00;36:*.au=00;36:*.flac=00;36:*.m4a=00;36:*.mid=00;36: 288 | *.midi=00;36:*.mka=00;36:*.mp3=00;36:*.mpc=00;36:*.ogg=00;36:*.ra=00;36: 289 | *.wav=00;36:*.oga=00;36:*.opus=00;36:*.spx=00;36:*.xspf=00;36'; 290 | 291 | $LS_COLORS =~ s/\n|\s+//g; 292 | 293 | $extracted_ls_colors = parse_ls_colors($LS_COLORS); 294 | ls_color(@_); 295 | } 296 | 297 | ################################################################################ 298 | # None of the ls_color_* variations are called, so use the LS_COLORS defined in 299 | # the environment variable. This is what most users would want to use. 300 | ################################################################################ 301 | $extracted_ls_colors = parse_ls_colors($LS_COLORS); 302 | 303 | 304 | sub ls_color { 305 | my @files; 306 | 307 | if(ref($_[0]) eq 'ARRAY') { 308 | push(@files, @{$_[0]}); 309 | shift @_; 310 | } 311 | else { 312 | push(@files, @_); 313 | } 314 | 315 | 316 | for my $file(@files) { 317 | chomp $file; 318 | 319 | next if $file =~ m/^\s+$/; 320 | 321 | ################################################################################ 322 | # It's important to keep the dot if there is one, or else miscolorings can 323 | # happen: 324 | # 325 | # *.bin=38;5;220 could color directories named bin/, for example. 326 | ################################################################################ 327 | my($ext) = $file =~ m/.*([.]+.+)$/; 328 | 329 | ################################################################################ 330 | # Since we need to stat files (unless $NO_STAT is set), we need a real filename 331 | # that's not padded with any whitespace. 332 | ################################################################################ 333 | my $real_file; 334 | if($file =~ m/^\s+(.+)/) { 335 | $real_file = $1; 336 | } 337 | else { 338 | $real_file = $file; 339 | } 340 | 341 | 342 | 343 | ################################################################################ 344 | # ./recup_dir.5/ 345 | # Invalid \0 character in pathname for ftdir: \0ls++.conf at LsColor.pm 346 | ################################################################################ 347 | if($real_file !~ m/\0/) { 348 | -d $real_file and $ext = 'di'; 349 | } 350 | 351 | ################################################################################ 352 | # No regular extension found. 353 | # Let's check file attributes. This will only work if called with absolute paths 354 | # or from ./, since we can't stat() files we cannot access. 355 | # 356 | # https://github.com/trapd00r/File-LsColor/issues/1 357 | ################################################################################ 358 | if(not defined($ext) and $NO_STAT == 0) { 359 | -l $real_file and $ext = 'ln'; # symlink 360 | -x $real_file and $ext = 'ex'; # executable 361 | -d $real_file and $ext = 'di'; # beware, dirs have +x 362 | -S $real_file and $ext = 'so'; # socket 363 | -p $real_file and $ext = 'pi'; # fifo, pipe 364 | -b $real_file and $ext = 'bd'; # block device 365 | -c $real_file and $ext = 'cd'; # character special file 366 | 367 | ################################################################################ 368 | # A special case for directories that we can't stat(), but we can still safely 369 | # assume that they are in fact directories. 370 | ################################################################################ 371 | $real_file =~ m{/$} and $ext = 'di'; 372 | } 373 | 374 | ################################################################################ 375 | # No regular extension found and no file attribute added. 376 | # The dircolors specification allows for matching with wildcards and full names, 377 | # though, so these are all perfectly valid keys: 378 | # 379 | # Makefile 380 | # README 381 | # *Makefile.PL 382 | ################################################################################ 383 | if(not defined($ext)) { 384 | $ext = basename($real_file); 385 | } 386 | 387 | if(exists($extracted_ls_colors->{$real_file})) { 388 | $file = fg($extracted_ls_colors->{$real_file}, basename($real_file)); 389 | } 390 | elsif(exists($extracted_ls_colors->{$ext})) { 391 | if($COLORIZE_PATH) { 392 | $file = sprintf("%s%s", _colorize_path($real_file), fg($extracted_ls_colors->{$ext}, basename($real_file))); 393 | } 394 | else { 395 | $file = fg($extracted_ls_colors->{$ext}, $real_file); 396 | } 397 | } 398 | 399 | ################################################################################ 400 | # We still haven't found a valid mapping yet, but if $IGNORE_CASE is set, check 401 | # if the lowercase version of the extension does in fact exist. 402 | # 403 | # Just make sure to use the non-lc:ed version while returning. 404 | # 405 | # https://github.com/trapd00r/File-LsColor/issues/9 406 | ################################################################################ 407 | elsif($IGNORE_CASE && $extracted_ls_colors->{lc($ext)}) { 408 | $file = fg($extracted_ls_colors->{lc($ext)}, $file); 409 | } 410 | 411 | else { 412 | if($COLORIZE_PATH) { 413 | $file = sprintf "%s%s", _colorize_path($file), 414 | exists($extracted_ls_colors->{basename($file)}) 415 | ? fg($extracted_ls_colors->{basename($file)},basename($file)) 416 | : basename($file); 417 | } 418 | # A file with no extension or other means of colorization? 419 | else { 420 | $file = exists($extracted_ls_colors->{basename($file)}) 421 | ? fg($extracted_ls_colors->{basename($file)}, $file) 422 | : $file; 423 | } 424 | } 425 | } 426 | return wantarray() ? @files : join('', @files); 427 | } 428 | 429 | 430 | sub get_ls_colors { 431 | return parse_ls_colors() 432 | } 433 | 434 | 435 | sub parse_ls_colors { 436 | if(@_) { 437 | $LS_COLORS = shift @_; 438 | } 439 | 440 | ################################################################################ 441 | # The way the dircolors specification is specified is actualy a bug. 442 | # ':' shouldn't be used as a delimiter, since the way colors are specified using 443 | # escape sequences are supposed to look like this: 444 | # 445 | # 38:5:196 446 | # 447 | # and not 448 | # 449 | # 38;5;196 450 | # 451 | # Someone, somewhere, a long time ago, read that specification wrong and here we 452 | # are today. 453 | ################################################################################ 454 | my @entities = split(/:/, $LS_COLORS); 455 | 456 | my %ft; 457 | for my $ent(@entities) { 458 | 459 | ################################################################################ 460 | # Account for: 461 | # · *.flac - but keep the dot in the extension 462 | # · *MANIFEST 463 | ################################################################################ 464 | my ($filetype, $attributes) = $ent =~ m/[*]*(.?\S+)=([\d;]+|target)/; 465 | $ft{$filetype} = $attributes; 466 | } 467 | 468 | # if symlink value is target, we use the target key's value 469 | # if($ft{ln} eq 'target') { 470 | # $ft{ln} = $ft{target}; 471 | # } 472 | return \%ft; 473 | } 474 | 475 | sub can_ls_color { 476 | my $ft = shift; 477 | my $table = get_ls_colors(); 478 | 479 | $ft =~ s/^\s+//; 480 | 481 | ################################################################################ 482 | # If $File::LsColor::IGNORE_CASE is set, we need to color according to the 483 | # lowercase definitions. 484 | ################################################################################ 485 | $ft = lc($ft) if $File::LsColor::IGNORE_CASE; 486 | 487 | ################################################################################ 488 | # If called with an extension that exists, return it. A special case here so we 489 | # can query for an extension with or without the period. 490 | ################################################################################ 491 | return $table->{$ft} if $table->{$ft}; 492 | return $table->{".$ft"} if $table->{".$ft"}; 493 | 494 | ################################################################################ 495 | # Else, check if called with a filename.ext 496 | # Return undef if all else fails. 497 | ################################################################################ 498 | { 499 | no warnings; 500 | my($ext) = $ft =~ m/^.*([.].+)$/; 501 | return $table->{$ext} ? $table->{$ext} : undef; 502 | } 503 | } 504 | 505 | sub slack_code_to_ls_code { 506 | my %slack = ( 507 | NORMAL => 'no', 508 | NORM => 'no', 509 | FILE => 'fi', 510 | RESET => 'rs', 511 | DIR => 'di', 512 | LNK => 'ln', 513 | LINK => 'ln', 514 | SYMLINK => 'ln', 515 | ORPHAN => 'or', 516 | MISSING => 'mi', 517 | FIFO => 'pi', 518 | PIPE => 'pi', 519 | SOCK => 'so', 520 | BLK => 'bd', 521 | BLOCK => 'bd', 522 | CHR => 'cd', 523 | CHAR => 'cd', 524 | DOOR => 'do', 525 | EXEC => 'ex', 526 | LEFT => 'lc', 527 | LEFTCODE => 'lc', 528 | RIGHT => 'rc', 529 | RIGHTCODE => 'rc', 530 | END => 'ec', 531 | ENDCODE => 'ec', 532 | SUID => 'su', 533 | SETUID => 'su', 534 | SGID => 'sg', 535 | SETGID => 'sg', 536 | STICKY => 'st', 537 | OTHER_WRITABLE => 'ow', 538 | OWR => 'ow', 539 | STICKY_OTHER_WRITABLE => 'tw', 540 | OWT => 'tw', 541 | CAPABILITY => 'ca', 542 | MULTIHARDLINK => 'mh', 543 | CLRTOEOL => 'cl', 544 | NULL => 'NULL', 545 | ); 546 | 547 | my $query = shift; 548 | return $slack{uc($query)} 549 | ? $slack{uc($query)} 550 | : undef; 551 | } 552 | 553 | sub _colorize_path { 554 | my $what = shift; 555 | use File::Basename; 556 | my $dirname = dirname($what); 557 | 558 | $dirname = ($dirname eq '.') 559 | ? '' 560 | : fg($extracted_ls_colors->{di}, $dirname . '/'); 561 | 562 | return $dirname; 563 | } 564 | 565 | 566 | 567 | 1; 568 | 569 | 570 | __END__ 571 | 572 | =pod 573 | 574 | =head1 NAME 575 | 576 | File::LsColor - Colorize input filenames just like ls does 577 | 578 | =head1 SYNOPSIS 579 | 580 | use File::LsColor qw(:all); 581 | # Is equal to: 582 | use File::LsColor qw( 583 | ls_color 584 | ls_color_custom 585 | ls_color_default 586 | ls_color_internal 587 | get_ls_colors 588 | can_ls_color 589 | ls_color_lookup 590 | parse_ls_colors 591 | slack_code_to_ls_code 592 | ); 593 | 594 | 595 | my @files = glob("$ENV{HOME}/*"); 596 | 597 | print "$_\n" for ls_color @files; 598 | 599 | # or specify own pattern 600 | 601 | @files = ls_color_custom('*.pl=38;5;196;1:*.pm=38;5;220', @files); 602 | 603 | # or use the internal mappings 604 | 605 | @files = ls_color_internal(@files); 606 | 607 | # or use the defaults (only ANSI colors) 608 | 609 | @files = ls_color_default(@files); 610 | 611 | 612 | # returns a hashref with all defined filetypes and their attributes 613 | my $ls_colors = get_ls_colors(); 614 | 615 | # what's the defined attributes for directories? 616 | 617 | my $dir_color = can_ls_color('di'); 618 | 619 | # can we apply attributes to this filetype? 620 | my $filetype = shift; 621 | printf "%s can be colored.\n" if can_ls_color($filetype); 622 | 623 | # apply terminal color even if we can't use LS_COLORS to do so. 624 | my $file_with_extension = 'foobar.flac'; 625 | printf "%s looks nice.\n", can_ls_color($file_with_extension) 626 | ? ls_color($file_with_extension) 627 | : Term::ExtendedColor::fg(32, $file_with_extension); 628 | 629 | 630 | =head1 DESCRIPTION 631 | 632 | This module provides functionality for using the LS_COLORS variable for 633 | colorizing output in a way that's immediately recognized. 634 | 635 | Say that you have a list of filenames that's the result of some complex 636 | operation, and you wish to present the result to the user. 637 | 638 | If said files have an extension and that extension is present in the users 639 | LS_COLORS variable, they will be colored just like they would have been if the 640 | filenames were output from L or L. 641 | 642 | =head1 EXPORTS 643 | 644 | None by default. 645 | 646 | =head1 FUNCTIONS 647 | 648 | =head2 ls_color() 649 | 650 | Arguments: @files | \@files 651 | 652 | Returns: @files | @files 653 | 654 | Returns a list of filenames colored as specified by the environment 655 | C variable. If the C variable is not set, use the 656 | default gnu specification. 657 | 658 | In scalar context a string joined by '' is returned. 659 | 660 | =head2 ls_color_default() 661 | 662 | The same thing as C, but uses the default LS_COLORS values from GNU 663 | ls. Those are only ANSI colors. 664 | 665 | =head2 ls_color_internal() 666 | 667 | The same as C, with one minor difference; Instead of using the 668 | LS_COLORS variable from the environment, an internal specification is used. 669 | This specification contains about 250 extensions as of this writing. 670 | 671 | =head2 ls_color_custom() 672 | 673 | The first argument to C should be a valid LS_COLORS 674 | definition, like so: 675 | 676 | ls_color_custom("*.pl=38;5;196:*.pm=38;5;197;1", @perl_files); 677 | 678 | =head2 get_ls_colors() 679 | 680 | Returns a hash reference where a key is the extension and its value is the 681 | attributes attached to it. 682 | 683 | =head2 can_ls_color() 684 | 685 | Arguments: $file 686 | Returns: $attributes 687 | 688 | Given a valid name, returns the defined attributes associated with it. 689 | Else, returns undef. 690 | 691 | =head2 ls_color_lookup() 692 | 693 | The same as can_ls_color(), exportable because of compatibility reasons. 694 | 695 | =head2 parse_ls_colors() 696 | 697 | Arguments: $string 698 | Returns: \%hash 699 | 700 | Returns a hashref with extension => attribute mappings, i.e: 701 | 702 | '7z' => '01;31', 703 | 'aac' => '00;36', 704 | 'ace' => '01;31', 705 | 'anx' => '01;35', 706 | 'arj' => '01;31', 707 | 708 | =head2 slack_code_to_ls_code() 709 | 710 | Arguments: $string 711 | Returns: $string 712 | 713 | Given a 'slack name', returns the short form of the ls code, like so: 714 | 715 | slack_code_to_ls_code('NORMAL'); # returns 'no' 716 | slack_code_to_ls_code('STICKY_OTHER_WRITABLE'); # returns 'tw' 717 | 718 | Returns undef if the slack name is not valid. 719 | 720 | =head1 NOTES 721 | 722 | If the internal C<$NO_STAT> variable is set, no stat call wil be made on 723 | the input filenames. This can be desired if the filenames aren't real 724 | files, or for performance reasons. 725 | 726 | If the internal C<$IGNORE_CASE> variable is set, case is ignored in file 727 | extensions. 728 | 729 | If the internal C<$COLORIZE_PATH> is set, given a path like 730 | ~/foo/bar.flac, everything prior to the basename will be colored as per 731 | the directory specification, while the actual base filename will be 732 | colored according to the file extension specification. 733 | 734 | =head1 AUTHOR 735 | 736 | Magnus Woldrich 737 | CPAN ID: WOLDRICH 738 | m@japh.se 739 | japh@irc.libera.chat 740 | http://japh.se 741 | https://github.com/trapd00r 742 | 743 | =head1 REPORTING BUGS 744 | 745 | Report bugs on L or to m@japh.se 746 | 747 | =head1 CONTRIBUTORS 748 | 749 | None required yet. 750 | 751 | =head1 COPYRIGHT 752 | 753 | Copyright 2011, 2018, 2019- the B L and 754 | L as listed above. 755 | 756 | =head1 LICENSE 757 | 758 | This library is free software; you may redistribute it and/or modify it under 759 | the same terms as Perl itself. 760 | 761 | =cut 762 | 763 | # vim: ft=perl:fdm=marker:fmr=#<,#>:fen:et:sw=2: 764 | --------------------------------------------------------------------------------