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_command
  24     run_git
  25     stringf
  26     stringify
  27     unbackslash
  28     zip
  29 );
  30
  31 our $VERSION = '9999.999'; # VERSION
  32
  33 =func find_nearest_codeowners
  34
  35     $filepath = find_nearest_codeowners($dirpath);
  36
  37 Find the F<CODEOWNERS> file in the current working directory, or search in the
  38 parent directory recursively until a F<CODEOWNERS> file is found.
  39
  40 Returns C<undef> if no F<CODEOWNERS> is found.
  41
  42 =cut
  43
  44 sub find_nearest_codeowners {
  45     my $path = path(shift || '.')->absolute;
  46
  47     while (!$path->is_rootdir) {
  48         my $filepath = find_codeowners_in_directory($path);
  49         return $filepath if $filepath;
  50         $path = $path->parent;
  51     }
  52 }
  53
  54 =func find_codeowners_in_directory
  55
  56     $filepath = find_codeowners_in_directory($dirpath);
  57
  58 Find the F<CODEOWNERS> file in a given directory. No recursive searching is done.
  59
  60 Returns the first of (or undef if none found):
  61
  62 =for :list
  63 * F<CODEOWNERS>
  64 * F<docs/CODEOWNERS>
  65 * F<.bitbucket/CODEOWNERS>
  66 * F<.github/CODEOWNERS>
  67 * F<.gitlab/CODEOWNERS>
  68
  69 =cut
  70
  71 sub find_codeowners_in_directory {
  72     my $path = path(shift) or die;
  73
  74     my @tries = (
  75         [qw(CODEOWNERS)],
  76         [qw(docs CODEOWNERS)],
  77         [qw(.bitbucket CODEOWNERS)],
  78         [qw(.github CODEOWNERS)],
  79         [qw(.gitlab CODEOWNERS)],
  80     );
  81
  82     for my $parts (@tries) {
  83         my $try = $path->child(@$parts);
  84         return $try if $try->is_file;
  85     }
  86 }
  87
  88 sub run_command {
  89     my $filter;
  90     $filter = pop if ref($_[-1]) eq 'CODE';
  91
  92     print STDERR "# @_\n" if $ENV{GIT_CODEOWNERS_DEBUG};
  93
  94     my ($child_in, $child_out);
  95     require IPC::Open2;
  96     my $pid = IPC::Open2::open2($child_out, $child_in, @_);
  97     close($child_in);
  98
  99     binmode($child_out, ':encoding(UTF-8)');
 100
 101     my $proc = App::Codeowners::Util::Process->new(
 102         pid     => $pid,
 103         fh      => $child_out,
 104         filter  => $filter,
 105     );
 106
 107     return wantarray ? ($proc, @{$proc->all}) : $proc;
 108 }
 109
 110 sub run_git {
 111     return run_command('git', @_);
 112 }
 113
 114 sub git_ls_files {
 115     my $dir = shift || '.';
 116     return run_git('-C', $dir, 'ls-files', @_, \&_unescape_git_filepath);
 117 }
 118
 119 # Depending on git's "core.quotepath" config, non-ASCII chars may be
 120 # escaped (identified by surrounding dquotes), so try to unescape.
 121 sub _unescape_git_filepath {
 122     return $_ if $_ !~ /^"(.+)"$/;
 123     return decode('UTF-8', unbackslash($1));
 124 }
 125
 126 sub git_toplevel {
 127     my $dir = shift || '.';
 128
 129     my ($proc, $path) = run_git('-C', $dir, qw{rev-parse --show-toplevel});
 130
 131     return if $proc->wait != 0 || !$path;
 132     return path($path);
 133 }
 134
 135 sub colorstrip {
 136     my $str = shift || '';
 137     $str =~ s/\e\[[\d;]*m//g;
 138     return $str;
 139 }
 140
 141 sub stringify {
 142     my $item = shift;
 143     return ref($item) eq 'ARRAY' ? join(',', @$item) : $item;
 144 }
 145
 146 # The zip code is from List::SomeUtils (thanks DROLSKY), copied just so as not
 147 # to bring in the extra dependency.
 148 sub zip (\@\@) {    ## no critic (Subroutines::ProhibitSubroutinePrototypes)
 149     my $max = -1;
 150     $max < $#$_ && ( $max = $#$_ ) foreach @_;
 151     map {
 152         my $ix = $_;
 153         map $_->[$ix], @_;
 154     } 0 .. $max;
 155 }
 156
 157 # The stringf code is from String::Format (thanks SREZIC), with changes:
 158 # - Use Unicode::GCString for better Unicode character padding,
 159 # - Strip ANSI color sequences,
 160 # - Prevent 'Negative repeat count does nothing' warnings
 161 sub _replace {
 162     my ($args, $orig, $alignment, $min_width,
 163         $max_width, $passme, $formchar) = @_;
 164
 165     # For unknown escapes, return the orignial
 166     return $orig unless defined $args->{$formchar};
 167
 168     $alignment = '+' unless defined $alignment;
 169
 170     my $replacement = $args->{$formchar};
 171     if (ref $replacement eq 'CODE') {
 172         # $passme gets passed to subrefs.
 173         $passme ||= "";
 174         $passme =~ tr/{}//d;
 175         $replacement = $replacement->($passme);
 176     }
 177
 178     my $replength;
 179     if (eval { require Unicode::GCString }) {
 180         my $gcstring = Unicode::GCString->new(colorstrip($replacement));
 181         $replength = $gcstring->columns;
 182     }
 183     else {
 184         $replength = length colorstrip($replacement);
 185     }
 186
 187     $min_width  ||= $replength;
 188     $max_width  ||= $replength;
 189
 190     # length of replacement is between min and max
 191     if (($replength > $min_width) && ($replength < $max_width)) {
 192         return $replacement;
 193     }
 194
 195     # length of replacement is longer than max; truncate
 196     if ($replength > $max_width) {
 197         return substr($replacement, 0, $max_width);
 198     }
 199
 200     my $padding = $min_width - $replength;
 201     $padding = 0 if $padding < 0;
 202
 203     # length of replacement is less than min: pad
 204     if ($alignment eq '-') {
 205         # left align; pad in front
 206         return $replacement . ' ' x $padding;
 207     }
 208
 209     # right align, pad at end
 210     return ' ' x $padding . $replacement;
 211 }
 212 my $regex = qr/
 213                (%             # leading '%'
 214                 (-)?          # left-align, rather than right
 215                 (\d*)?        # (optional) minimum field width
 216                 (?:\.(\d*))?  # (optional) maximum field width
 217                 (\{.*?\})?    # (optional) stuff inside
 218                 (\S)          # actual format character
 219              )/x;
 220 sub stringf {
 221     my $format = shift || return;
 222     my $args = UNIVERSAL::isa($_[0], 'HASH') ? shift : { @_ };
 223        $args->{'n'} = "\n" unless exists $args->{'n'};
 224        $args->{'t'} = "\t" unless exists $args->{'t'};
 225        $args->{'%'} = "%"  unless exists $args->{'%'};
 226
 227     $format =~ s/$regex/_replace($args, $1, $2, $3, $4, $5, $6)/ge;
 228
 229     return $format;
 230 }
 231
 232 # The unbacklash code is from String::Escape (thanks EVO), with changes:
 233 # - Handle \a, \b, \f and \v (thanks Berk Akinci)
 234 my %unbackslash;
 235 sub unbackslash {
 236     my $str = shift;
 237     # Earlier definitions are preferred to later ones, thus we output \n not \x0d
 238     %unbackslash = (
 239         ( map { $_ => $_ } ( '\\', '"', '$', '@' ) ),
 240         ( 'r' => "\r", 'n' => "\n", 't' => "\t" ),
 241         ( map { 'x' . unpack('H2', chr($_)) => chr($_) } (0..255) ),
 242         ( map { sprintf('%03o', $_) => chr($_) } (0..255) ),
 243         ( 'a' => "\x07", 'b' => "\x08", 'f' => "\x0c", 'v' => "\x0b" ),
 244     ) if !%unbackslash;
 245     $str =~ s/ (\A|\G|[^\\]) \\ ( [0-7]{3} | x[\da-fA-F]{2} | . ) / $1 . $unbackslash{lc($2)} /gsxe;
 246     return $str;
 247 }
 248
 249 {
 250     package App::Codeowners::Util::Process;
 251
 252     sub new {
 253         my $class = shift;
 254         return bless {@_}, $class;
 255     }
 256
 257     sub next {
 258         my $self = shift;
 259         my $line = readline($self->{fh});
 260         if (defined $line) {
 261             chomp $line;
 262             if (my $filter = $self->{filter}) {
 263                 local $_ = $line;
 264                 $line = $filter->($line);
 265             }
 266         }
 267         $line;
 268     }
 269
 270     sub all {
 271         my $self = shift;
 272         chomp(my @lines = readline($self->{fh}));
 273         if (my $filter = $self->{filter}) {
 274             $_ = $filter->($_) for @lines;
 275         }
 276         \@lines;
 277     }
 278
 279     sub wait {
 280         my $self = shift;
 281         my $pid  = $self->{pid} or return;
 282         if (my $fh = $self->{fh}) {
 283             close($fh);
 284             delete $self->{fh};
 285         }
 286         waitpid($pid, 0);
 287         my $status = $?;
 288         print STDERR "# -> status $status\n" if $ENV{GIT_CODEOWNERS_DEBUG};
 289         delete $self->{pid};
 290         return $status;
 291     }
 292
 293     sub DESTROY {
 294         my ($self, $global_destruction) = @_;
 295         return if $global_destruction;
 296         $self->wait;
 297     }
 298 }
 299
 300 1;