Dogcows Code - chaz/git-codeowners/blob - lib/App/Codeowners/Util.pm

   1 package App::Codeowners::Util;
   2 # ABSTRACT: Grab bag of utility subs for Codeowners modules
   3
   4 =head1 DESCRIPTION
   5
   6 B<DO NOT USE> except in L<App::Codeowners> and related modules.
   7
   8 =cut
   9
  10 use warnings;
  11 use strict;
  12
  13 use Encode qw(decode);
  14 use Exporter qw(import);
  15 use Path::Tiny;
  16
  17 our @EXPORT_OK = qw(
  18     colorstrip
  19     find_codeowners_in_directory
  20     find_nearest_codeowners
  21     git_ls_files
  22     git_toplevel
  23     run_git
  24     stringf
  25     unbackslash
  26 );
  27
  28 our $VERSION = '9999.999'; # VERSION
  29
  30 =func find_nearest_codeowners
  31
  32     $filepath = find_nearest_codeowners($dirpath);
  33
  34 Find the F<CODEOWNERS> file in the current working directory, or search in the
  35 parent directory recursively until a F<CODEOWNERS> file is found.
  36
  37 Returns C<undef> if no F<CODEOWNERS> is found.
  38
  39 =cut
  40
  41 sub find_nearest_codeowners {
  42     my $path = path(shift || '.')->absolute;
  43
  44     while (!$path->is_rootdir) {
  45         my $filepath = find_codeowners_in_directory($path);
  46         return $filepath if $filepath;
  47         $path = $path->parent;
  48     }
  49 }
  50
  51 =func find_codeowners_in_directory
  52
  53     $filepath = find_codeowners_in_directory($dirpath);
  54
  55 Find the F<CODEOWNERS> file in a given directory. No recursive searching is done.
  56
  57 Returns the first of (or undef if none found):
  58
  59 =for :list
  60 * F<CODEOWNERS>
  61 * F<docs/CODEOWNERS>
  62 * F<.bitbucket/CODEOWNERS>
  63 * F<.github/CODEOWNERS>
  64 * F<.gitlab/CODEOWNERS>
  65
  66 =cut
  67
  68 sub find_codeowners_in_directory {
  69     my $path = path(shift) or die;
  70
  71     my @tries = (
  72         [qw(CODEOWNERS)],
  73         [qw(docs CODEOWNERS)],
  74         [qw(.bitbucket CODEOWNERS)],
  75         [qw(.github CODEOWNERS)],
  76         [qw(.gitlab CODEOWNERS)],
  77     );
  78
  79     for my $parts (@tries) {
  80         my $try = $path->child(@$parts);
  81         return $try if $try->is_file;
  82     }
  83 }
  84
  85 sub run_git {
  86     my @cmd = ('git', @_);
  87
  88     require IPC::Open2;
  89
  90     my ($child_in, $child_out);
  91     my $pid = IPC::Open2::open2($child_out, $child_in, @cmd);
  92     close($child_in);
  93
  94     binmode($child_out, ':encoding(UTF-8)');
  95     chomp(my @lines = <$child_out>);
  96
  97     waitpid($pid, 0);
  98     return if $? != 0;
  99
 100     return @lines;
 101 }
 102
 103 sub git_ls_files {
 104     my $dir = shift || '.';
 105
 106     my @files = run_git('-C', $dir, qw{ls-files}, @_);
 107
 108     return undef if !@files;    ## no critic (Subroutines::ProhibitExplicitReturn)
 109
 110     # Depending on git's "core.quotepath" config, non-ASCII chars may be
 111     # escaped (identified by surrounding dquotes), so try to unescape.
 112     for my $file (@files) {
 113         next if $file !~ /^"(.+)"$/;
 114         $file = $1;
 115         $file = unbackslash($file);
 116         $file = decode('UTF-8', $file);
 117     }
 118
 119     return \@files;
 120 }
 121
 122 sub git_toplevel {
 123     my $dir = shift || '.';
 124
 125     my ($path) = run_git('-C', $dir, qw{rev-parse --show-toplevel});
 126
 127     return if !$path;
 128     return path($path);
 129 }
 130
 131 sub colorstrip {
 132     my $str = shift || '';
 133     $str =~ s/\e\[[\d;]*m//g;
 134     return $str;
 135 }
 136
 137 # The stringf code is from String::Format (thanks SREZIC), with changes:
 138 # - Use Unicode::GCString for better Unicode character padding,
 139 # - Strip ANSI color sequences,
 140 # - Prevent 'Negative repeat count does nothing' warnings
 141 sub _replace {
 142     my ($args, $orig, $alignment, $min_width,
 143         $max_width, $passme, $formchar) = @_;
 144
 145     # For unknown escapes, return the orignial
 146     return $orig unless defined $args->{$formchar};
 147
 148     $alignment = '+' unless defined $alignment;
 149
 150     my $replacement = $args->{$formchar};
 151     if (ref $replacement eq 'CODE') {
 152         # $passme gets passed to subrefs.
 153         $passme ||= "";
 154         $passme =~ tr/{}//d;
 155         $replacement = $replacement->($passme);
 156     }
 157
 158     my $replength;
 159     if (eval { require Unicode::GCString }) {
 160         my $gcstring = Unicode::GCString->new(colorstrip($replacement));
 161         $replength = $gcstring->columns;
 162     }
 163     else {
 164         $replength = length colorstrip($replacement);
 165     }
 166
 167     $min_width  ||= $replength;
 168     $max_width  ||= $replength;
 169
 170     # length of replacement is between min and max
 171     if (($replength > $min_width) && ($replength < $max_width)) {
 172         return $replacement;
 173     }
 174
 175     # length of replacement is longer than max; truncate
 176     if ($replength > $max_width) {
 177         return substr($replacement, 0, $max_width);
 178     }
 179
 180     my $padding = $min_width - $replength;
 181     $padding = 0 if $padding < 0;
 182
 183     # length of replacement is less than min: pad
 184     if ($alignment eq '-') {
 185         # left align; pad in front
 186         return $replacement . ' ' x $padding;
 187     }
 188
 189     # right align, pad at end
 190     return ' ' x $padding . $replacement;
 191 }
 192 my $regex = qr/
 193                (%             # leading '%'
 194                 (-)?          # left-align, rather than right
 195                 (\d*)?        # (optional) minimum field width
 196                 (?:\.(\d*))?  # (optional) maximum field width
 197                 (\{.*?\})?    # (optional) stuff inside
 198                 (\S)          # actual format character
 199              )/x;
 200 sub stringf {
 201     my $format = shift || return;
 202     my $args = UNIVERSAL::isa($_[0], 'HASH') ? shift : { @_ };
 203        $args->{'n'} = "\n" unless exists $args->{'n'};
 204        $args->{'t'} = "\t" unless exists $args->{'t'};
 205        $args->{'%'} = "%"  unless exists $args->{'%'};
 206
 207     $format =~ s/$regex/_replace($args, $1, $2, $3, $4, $5, $6)/ge;
 208
 209     return $format;
 210 }
 211
 212 # The unbacklash code is from String::Escape (thanks EVO), with changes:
 213 # - Handle \a, \b, \f and \v (thanks Berk Akinci)
 214 my %unbackslash;
 215 sub unbackslash {
 216     my $str = shift;
 217     # Earlier definitions are preferred to later ones, thus we output \n not \x0d
 218     %unbackslash = (
 219         ( map { $_ => $_ } ( '\\', '"', '$', '@' ) ),
 220         ( 'r' => "\r", 'n' => "\n", 't' => "\t" ),
 221         ( map { 'x' . unpack('H2', chr($_)) => chr($_) } (0..255) ),
 222         ( map { sprintf('%03o', $_) => chr($_) } (0..255) ),
 223         ( 'a' => "\x07", 'b' => "\x08", 'f' => "\x0c", 'v' => "\x0b" ),
 224     ) if !%unbackslash;
 225     $str =~ s/ (\A|\G|[^\\]) \\ ( [0-7]{3} | x[\da-fA-F]{2} | . ) / $1 . $unbackslash{lc($2)} /gsxe;
 226     return $str;
 227 }
 228
 229 1;