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