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