File Coverage

blib/lib/System/Introspector/Probe/Repositories/Git.pm
Criterion Covered Total %
statement 39 58 67.2
branch 1 8 12.5
condition n/a
subroutine 11 16 68.7
pod 0 1 0.0
total 51 83 61.4


line stmt bran cond sub pod time code
1             package System::Introspector::Probe::Repositories::Git;
2 1     1   69096 use Moo;
  1         17880  
  1         8  
3              
4 1         1196 use System::Introspector::Util qw(
5             handle_from_command
6             transform_exceptions
7             lines_from_command
8 1     1   2704 );
  1         5  
9              
10             has root => (
11             is => 'ro',
12             default => sub { '/' },
13             );
14              
15             sub gather {
16 1     1 0 20675 my ($self) = @_;
17             return transform_exceptions {
18 1     1   7 my $pipe = $self->_open_locate_git_config_pipe;
19 1         1567 my %location;
20 1         12 while (defined( my $line = <$pipe> )) {
21 1         4 chomp $line;
22 1 50       14 next unless $line =~ m{^(.+)/\.git/config$};
23 1         3 my $base = $1;
24 1         14 $location{ $base } = $self->_gather_git_info($line);
25             }
26 1         38 return { git => \%location };
27 1         25 };
28             }
29              
30             sub _gather_git_info {
31 1     1   3 my ($self, $config) = @_;
32             return {
33             config_file => $config,
34             config => transform_exceptions {
35 1     1   7 $self->_gather_git_config($config);
36             },
37             tracked => transform_exceptions {
38 1     1   5 $self->_gather_track_info($config);
39             },
40 1         16 };
41             }
42              
43             sub _gather_track_info {
44 1     1   2 my ($self, $config) = @_;
45 1         14 (my $git_dir = $config) =~ s{/config$}{};
46 1         5 return $self->_find_tracking($git_dir);
47             }
48              
49             sub _find_tracking {
50 1     1   2 my ($self, $dir) = @_;
51 1         18 local $ENV{GIT_DIR} = $dir;
52 1         10 my @lines = lines_from_command
53             ['git', 'for-each-ref',
54             '--format', q{OK %(refname:short) %(upstream:short)},
55             'refs/heads',
56             ];
57 1         10 my %branch;
58 1         9 for my $line (@lines) {
59 0 0       0 if ($line =~ m{^OK\s+(\S+)\s+(\S+)?$}) {
60 0         0 my ($local, $remote) = ($1, $2);
61             $branch{ $local } = {
62             upstream => $remote,
63             changed_files => transform_exceptions {
64 0     0   0 $self->_find_changes($dir, $local, $remote);
65             },
66             local_commit_count => transform_exceptions {
67 0     0   0 $self->_find_commit_count($dir, $local, $remote);
68             },
69             }
70 0         0 }
71             else {
72 0         0 return { __error__ => join "\n", @lines };
73             }
74             }
75 1         48 return { branches => \%branch };
76             }
77              
78             sub _find_commit_count {
79 0     0   0 my ($self, $dir, $local, $remote) = @_;
80 0 0       0 return { __error__ => "No remote" }
81             unless defined $remote;
82 0         0 local $ENV{GIT_DIR} = $dir;
83 0         0 my @lines = lines_from_command
84             ['git', 'log', '--oneline', "$remote..$local"];
85 0         0 return scalar @lines;
86             }
87              
88             sub _find_changes {
89 0     0   0 my ($self, $dir, $local, $remote) = @_;
90 0 0       0 return { __error__ => "No remote" }
91             unless defined $remote;
92 0         0 local $ENV{GIT_DIR} = $dir;
93 0         0 my @lines = lines_from_command
94             ['git', 'diff', '--name-only', $local, $remote];
95 0         0 return \@lines;
96             }
97              
98             sub _gather_git_config {
99 1     1   5 my ($self, $config) = @_;
100 1         5 my $pipe = $self->_open_git_config_pipe($config);
101 1         3 my %config;
102 1         5 while (defined( my $line = <$pipe> )) {
103 4         5 chomp $line;
104 4         21 my ($name, $value) = split m{=}, $line, 2;
105 4         23 $config{ $name } = $value;
106             }
107 1         20 return { contents => \%config };
108             }
109              
110             sub _open_git_config_pipe {
111 1     1   2 my ($self, $config) = @_;
112 1         11 return handle_from_command "git config --file $config --list";
113             }
114              
115             sub _open_locate_git_config_pipe {
116 0     0     my ($self) = @_;
117 0           (my $root = $self->root) =~ s{/$}{};
118 0           return handle_from_command sprintf
119             q{locate --regex '^%s/.*\\.git/config$'}, $root;
120             }
121              
122             1;
123              
124             __END__