File Coverage

blib/lib/File/Codeowners/Util.pm
Criterion Covered Total %
statement 67 84 79.7
branch 19 32 59.3
condition 4 9 44.4
subroutine 17 19 89.4
pod 6 6 100.0
total 113 150 75.3


line stmt bran cond sub pod time code
1             package File::Codeowners::Util;
2             # ABSTRACT: Grab bag of utility subs for Codeowners modules
3              
4              
5 1     1   402 use warnings;
  1         6  
  1         25  
6 1     1   5 use strict;
  1         1  
  1         20  
7              
8 1     1   473 use Encode qw(decode);
  1         8440  
  1         55  
9 1     1   6 use Exporter qw(import);
  1         2  
  1         20  
10 1     1   628 use Path::Tiny;
  1         12329  
  1         1052  
11              
12             our @EXPORT_OK = qw(
13             find_codeowners_in_directory
14             find_nearest_codeowners
15             git_ls_files
16             git_toplevel
17             run_command
18             run_git
19             );
20              
21             our $VERSION = '0.55'; # VERSION
22              
23              
24             sub find_nearest_codeowners {
25 1   50 1 1 6066 my $path = path(shift || '.')->absolute;
26              
27 1         99 while (!$path->is_rootdir) {
28 4         202 my $filepath = find_codeowners_in_directory($path);
29 4 100       92 return $filepath if $filepath;
30 3         10 $path = $path->parent;
31             }
32             }
33              
34              
35             sub find_codeowners_in_directory {
36 6 50   6 1 3333 my $path = path(shift) or die;
37              
38 6         192 my @tries = (
39             [qw(CODEOWNERS)],
40             [qw(docs CODEOWNERS)],
41             [qw(.bitbucket CODEOWNERS)],
42             [qw(.github CODEOWNERS)],
43             [qw(.gitlab CODEOWNERS)],
44             );
45              
46 6         14 for my $parts (@tries) {
47 20         329 my $try = $path->child(@$parts);
48 20 100       605 return $try if $try->is_file;
49             }
50             }
51              
52              
53             sub run_command {
54 19     19 1 89 my $filter;
55 19 100       65 $filter = pop if ref($_[-1]) eq 'CODE';
56              
57 19 50       50 print STDERR "# @_\n" if $ENV{FILE_CODEOWNERS_DEBUG};
58              
59 19         29 my ($child_in, $child_out);
60 19         580 require IPC::Open2;
61 19         3776 my $pid = IPC::Open2::open2($child_out, $child_in, @_);
62 19         57737 close($child_in);
63              
64 1     1   14 binmode($child_out, ':encoding(UTF-8)');
  1         3  
  1         35  
  19         625  
65              
66 19         4279 my $proc = File::Codeowners::Util::Process->new(
67             pid => $pid,
68             fh => $child_out,
69             filter => $filter,
70             );
71              
72 19 100       270 return wantarray ? ($proc, @{$proc->all}) : $proc;
  5         14  
73             }
74              
75              
76             sub run_git {
77 19     19 1 43195 return run_command('git', @_);
78             }
79              
80              
81             sub git_toplevel {
82 2   50 2 1 3664 my $dir = shift || '.';
83              
84 2         20 my ($proc, $path) = run_git('-C', $dir, qw{rev-parse --show-toplevel});
85              
86 2 50 33     28 return if $proc->wait != 0 || !$path;
87 2         40 return path($path);
88             }
89              
90              
91             sub git_ls_files {
92 2   50 2 1 1728 my $dir = shift || '.';
93 2         17 return run_git('-C', $dir, 'ls-files', @_, \&_unescape_git_filepath);
94             }
95              
96             # Depending on git's "core.quotepath" config, non-ASCII chars may be
97             # escaped (identified by surrounding dquotes), so try to unescape.
98             sub _unescape_git_filepath {
99 2 50   2   51 return $_ if $_ !~ /^"(.+)"$/;
100 0         0 return decode('UTF-8', _unbackslash($1));
101             }
102              
103             # The unbacklash code is from String::Escape (thanks EVO), with changes:
104             # - Handle \a, \b, \f and \v (thanks Berk Akinci)
105             my %unbackslash;
106             sub _unbackslash {
107 0     0   0 my $str = shift;
108             # Earlier definitions are preferred to later ones, thus we output \n not \x0d
109             %unbackslash = (
110 0         0 ( map { $_ => $_ } ( '\\', '"', '$', '@' ) ),
111             ( 'r' => "\r", 'n' => "\n", 't' => "\t" ),
112 0         0 ( map { 'x' . unpack('H2', chr($_)) => chr($_) } (0..255) ),
113 0 0       0 ( map { sprintf('%03o', $_) => chr($_) } (0..255) ),
  0         0  
114             ( 'a' => "\x07", 'b' => "\x08", 'f' => "\x0c", 'v' => "\x0b" ),
115             ) if !%unbackslash;
116 0         0 $str =~ s/ (\A|\G|[^\\]) \\ ( [0-7]{3} | x[\da-fA-F]{2} | . ) / $1 . $unbackslash{lc($2)} /gsxe;
  0         0  
117 0         0 return $str;
118             }
119              
120             {
121             package File::Codeowners::Util::Process;
122              
123             sub new {
124 19     19   121 my $class = shift;
125 19         206 return bless {@_}, $class;
126             }
127              
128             sub next {
129 0     0   0 my $self = shift;
130 0         0 my $line = readline($self->{fh});
131 0 0       0 if (defined $line) {
132 0         0 chomp $line;
133 0 0       0 if (my $filter = $self->{filter}) {
134 0         0 local $_ = $line;
135 0         0 $line = $filter->($line);
136             }
137             }
138 0         0 $line;
139             }
140              
141             sub all {
142 5     5   35 my $self = shift;
143 5         4973 chomp(my @lines = readline($self->{fh}));
144 5 100       550 if (my $filter = $self->{filter}) {
145 2         40 $_ = $filter->($_) for @lines;
146             }
147 5         111 \@lines;
148             }
149              
150             sub wait {
151 35     35   63 my $self = shift;
152 35 100       400 my $pid = $self->{pid} or return;
153 19 50       58 if (my $fh = $self->{fh}) {
154 19         250 close($fh);
155 19         60 delete $self->{fh};
156             }
157 19         34804 waitpid($pid, 0);
158 19         205 my $status = $?;
159 19 50       85 print STDERR "# -> status $status\n" if $ENV{FILE_CODEOWNERS_DEBUG};
160 19         42 delete $self->{pid};
161 19         310 return $status;
162             }
163              
164             sub DESTROY {
165 19     19   248 my ($self, $global_destruction) = @_;
166 19 50       42 return if $global_destruction;
167 19         53 $self->wait;
168             }
169             }
170              
171             1;
172              
173             __END__