1 package App
::Codeowners
::Util
;
2 # ABSTRACT: Grab bag of utility subs for Codeowners modules
6 B<DO NOT USE> except in L<App::Codeowners> and related modules.
13 use Encode
qw(decode);
14 use Exporter
qw(import);
19 find_codeowners_in_directory
20 find_nearest_codeowners
28 our $VERSION = '9999.999'; # VERSION
30 =func find_nearest_codeowners
32 $filepath = find_nearest_codeowners
($dirpath);
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
.
37 Returns C
<undef> if no F
<CODEOWNERS
> is found
.
41 sub find_nearest_codeowners
{
42 my $path = path
(shift || '.')->absolute;
44 while (!$path->is_rootdir) {
45 my $filepath = find_codeowners_in_directory
($path);
46 return $filepath if $filepath;
47 $path = $path->parent;
51 =func find_codeowners_in_directory
53 $filepath = find_codeowners_in_directory
($dirpath);
55 Find the F
<CODEOWNERS
> file
in a
given directory
. No recursive searching
is done
.
57 Returns the first of
(or undef if none found
):
62 * F<.bitbucket/CODEOWNERS>
63 * F<.github/CODEOWNERS>
64 * F<.gitlab/CODEOWNERS>
68 sub find_codeowners_in_directory
{
69 my $path = path
(shift) or die;
73 [qw(docs CODEOWNERS)],
74 [qw(.bitbucket CODEOWNERS)],
75 [qw(.github CODEOWNERS)],
76 [qw(.gitlab CODEOWNERS)],
79 for my $parts (@tries) {
80 my $try = $path->child(@$parts);
81 return $try if $try->is_file;
86 my @cmd = ('git', @_);
90 my ($child_in, $child_out);
91 my $pid = IPC
::Open2
::open2
($child_out, $child_in, @cmd);
94 binmode($child_out, ':encoding(UTF-8)');
95 chomp(my @lines = <$child_out>);
104 my $dir = shift || '.';
106 my @files = run_git
('-C', $dir, qw{ls-files}, @_);
108 return undef if !@files; ## no critic (Subroutines::ProhibitExplicitReturn)
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 !~ /^"(.+)"$/;
115 $file = unbackslash
($file);
116 $file = decode
('UTF-8', $file);
123 my $dir = shift || '.';
125 my ($path) = run_git
('-C', $dir, qw{rev-parse --show-toplevel});
132 my $str = shift || '';
133 $str =~ s/\e\[[\d;]*m//g;
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
142 my ($args, $orig, $alignment, $min_width,
143 $max_width, $passme, $formchar) = @_;
145 # For unknown escapes, return the orignial
146 return $orig unless defined $args->{$formchar};
148 $alignment = '+' unless defined $alignment;
150 my $replacement = $args->{$formchar};
151 if (ref $replacement eq 'CODE') {
152 # $passme gets passed to subrefs.
155 $replacement = $replacement->($passme);
159 if (eval { require Unicode
::GCString
}) {
160 my $gcstring = Unicode
::GCString-
>new(colorstrip
($replacement));
161 $replength = $gcstring->columns;
164 $replength = length colorstrip
($replacement);
167 $min_width ||= $replength;
168 $max_width ||= $replength;
170 # length of replacement is between min and max
171 if (($replength > $min_width) && ($replength < $max_width)) {
175 # length of replacement is longer than max; truncate
176 if ($replength > $max_width) {
177 return substr($replacement, 0, $max_width);
180 my $padding = $min_width - $replength;
181 $padding = 0 if $padding < 0;
183 # length of replacement is less than min: pad
184 if ($alignment eq '-') {
185 # left align; pad in front
186 return $replacement . ' ' x
$padding;
189 # right align, pad at end
190 return ' ' x
$padding . $replacement;
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
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->{'%'};
207 $format =~ s/$regex/_replace($args, $1, $2, $3, $4, $5, $6)/ge;
212 # The unbacklash code is from String::Escape (thanks EVO), with changes:
213 # - Handle \a, \b, \f and \v (thanks Berk Akinci)
217 # Earlier definitions are preferred to later ones, thus we output \n not \x0d
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" ),
225 $str =~ s/ (\A|\G|[^\\]) \\ ( [0-7]{3} | x[\da-fA-F]{2} | . ) / $1 . $unbackslash{lc($2)} /gsxe;