File Coverage

File:blib/lib/Git/ReleaseRepo/Repository.pm
Coverage:86.8%

linestmtbrancondsubpodtimecode
1package Git::ReleaseRepo::Repository;
2
3
2
2
2
2074
2
6
use Moose;
4extends 'Git::Repository::Plugin';
5
2
2
2
7078
3
54
use File::Path qw( remove_tree );
6
2
2
2
4
2
1456
use File::Spec::Functions qw( catfile catdir );
7
8# The list of subs to install into the object
9
2
40
sub _keywords { qw(
10    submodule submodule_git outdated checkout list_version_refs
11    list_versions latest_version list_release_branches latest_release_branch
12    version_sort show_ref ls_remote has_remote has_branch release_prefix
13    current_release
14) }
15
16# I do not like this, but I can't think of any better way to have a default
17# that does the right thing and does what I mean
18has release_prefix => (
19    is => 'rw',
20    isa => 'Str',
21    default => 'v',
22);
23
24sub submodule {
25
79
0
121
    my ( $self ) = @_;
26
79
111
    my %submodules;
27
79
154
    for my $line ( $self->run( 'submodule' ) ) {
28        # <status><SHA1 hash> <submodule> (ref name)
29
116
3981269
        $line =~ m{^.(\S+)\s(\S+)};
30
116
852
        $submodules{ $2 } = $1;
31    }
32
79
767
    return wantarray ? %submodules : \%submodules;
33}
34
35sub submodule_git {
36
62
0
153
    my ( $self, $module ) = @_;
37
62
308
    my $git = Git::Repository->new(
38        work_tree => catdir( $self->work_tree, $module ),
39    );
40
62
1225836
    $git->release_prefix( $self->release_prefix );
41
62
270
    return $git;
42}
43
44sub outdated {
45
35
0
80
    my ( $self, $ref ) = @_;
46
35
79
    $ref ||= "refs/heads/master";
47
35
99
    my %submod_refs = $self->submodule;
48
35
95
    my @outdated;
49
35
95
    for my $submod ( keys %submod_refs ) {
50
53
211
        my $subgit = $self->submodule_git( $submod );
51
53
249
        my %remote = $subgit->ls_remote;
52
53
597
        if ( !exists $remote{ $ref } || $submod_refs{ $submod } ne $remote{$ref} ) {
53            #print "OUTDATED $submod: $submod_refs{$submod} ne $remote{$ref}\n";
54
7
63
            push @outdated, $submod;
55        }
56    }
57
35
285
    return @outdated;
58}
59
60sub checkout {
61
34
0
94
    my ( $self, $commit ) = @_;
62    # git will not remove submodule directories, in case they have stuff in them
63    # So let's compare the list and see what we need to remove
64
34
116
    my %current_submodule = $self->submodule;
65
34
206
    $commit //= "master";
66
34
117
    my $cmd = $self->command( checkout => $commit );
67
34
154253
    my @stderr = readline $cmd->stderr;
68
34
199409
    my @stdout = readline $cmd->stdout;
69
34
340
    $cmd->close;
70
34
1892
    if ( $cmd->exit != 0 ) {
71
0
0
        die "Could not checkout '$commit'.\nEXIT: " . $cmd->exit . "\nSTDERR: " . ( join "\n", @stderr )
72            . "\nSTDOUT: " . ( join "\n", @stdout );
73    }
74
34
219
    $cmd = $self->command( submodule => update => '--init' );
75
34
149576
    @stderr = readline $cmd->stderr;
76
34
2132286
    @stdout = readline $cmd->stdout;
77
34
503
    $cmd->close;
78
34
2416
    if ( $cmd->exit != 0 ) {
79
0
0
        die "Could not update submodules to '$commit'.\nEXIT: " . $cmd->exit . "\nSTDERR: " . ( join "\n", @stderr )
80            . "\nSTDOUT: " . ( join "\n", @stdout );
81    }
82
83    # Remove any submodule directories that no longer belong
84
1
1
6
6
    my @missing = grep { exists $current_submodule{ $_ } }
85
1
1
5
9873
                map { s{^[?]*\s+|/$}{}g; $_ }
86
34
263
                grep { /^[?]{2}/ }
87                $self->run( status => '--porcelain' );
88
34
377975
    remove_tree( catdir( $self->work_tree, $_ ) ) for @missing;
89}
90
91sub list_version_refs {
92
44
0
96
    my ( $self, $match, $rel_branch ) = @_;
93
44
1135
    my $prefix = $rel_branch // $self->release_prefix;
94
44
188
    my %refs = $self->has_remote( 'origin') ? $self->ls_remote( 'origin' ) : $self->show_ref;
95
44
109
109
252
124
717
226
849
    my @versions = reverse sort version_sort grep { m{^$prefix} } map { (split "/", $_)[-1] } grep { m{^refs/$match/} } keys %refs;
96
44
231
    return @versions;
97}
98
99sub list_versions {
100
20
0
30
    my ( $self, $rel_branch ) = @_;
101
20
61
    return $self->list_version_refs( 'tags', $rel_branch );
102}
103
104sub latest_version {
105
20
0
57
    my ( $self, $rel_branch ) = @_;
106
20
62
    my @versions = $self->list_versions( $rel_branch );
107
20
82
    return $versions[0];
108}
109
110sub list_release_branches {
111
24
0
37
    my ( $self ) = @_;
112
24
58
    return $self->list_version_refs( 'heads' );
113}
114
115sub latest_release_branch {
116
24
0
44
    my ( $self ) = @_;
117
24
80
    my @branches = $self->list_release_branches;
118
24
79
    return $branches[0];
119}
120
121sub version_sort {
122    # Assume Semantic Versioning style, plus prefix
123    # %s.%i.%i%s
124
25
0
187
    my @a = $a =~ /^\D*(\d+)[.](\d+)(?:[.](\d+))?/;
125
25
84
    my @b = $b =~ /^\D*(\d+)[.](\d+)(?:[.](\d+))?/;
126
127    # Assume the 3rd number is 0 if not given
128
25
95
    $a[2] //= 0;
129
25
69
    $b[2] //= 0;
130
131
25
61
    my $format = ( "%03i" x @a );
132
25
233
    return sprintf( $format, @a ) cmp sprintf( $format, @b );
133}
134
135sub show_ref {
136
46
0
196625
    my ( $self ) = @_;
137
46
115
    my %refs;
138
46
171
    my $cmd = $self->command( 'show-ref', '--head' );
139
46
202131
    while ( defined( my $line = readline $cmd->stdout ) ) {
140        # <SHA1 hash> <symbolic ref>
141
291
53011
        my ( $ref_id, $ref_name ) = split /\s+/, $line;
142
291
857
        $refs{ $ref_name } = $ref_id;
143    }
144
46
3033
    return wantarray ? %refs : \%refs;
145}
146
147sub ls_remote {
148
63
0
103
    my ( $self ) = @_;
149
63
101
    my %refs;
150
63
206
    my $cmd = $self->command( 'ls-remote', 'origin' );
151
63
279275
    while ( defined( my $line = readline $cmd->stdout ) ) {
152        # <SHA1 hash> <symbolic ref>
153
335
243419
        my ( $ref_id, $ref_name ) = split /\s+/, $line;
154
335
1054
        $refs{ $ref_name } = $ref_id;
155    }
156
63
3222
    return wantarray ? %refs : \%refs;
157}
158
159sub has_remote {
160
59
0
127
    my ( $self, $name ) = @_;
161
59
19
157
108472
    return grep { $_ eq $name } $self->run( 'remote' );
162}
163
164sub has_branch {
165
5
0
11
    my ( $self, $name ) = @_;
166
5
8
8
8
11
28
23940
22
    return grep { $_ eq $name } map { s/[*]?\s+//; $_ } $self->run( 'branch' );
167}
168
169sub current_release {
170
12
0
18
    my ( $self ) = @_;
171
12
29
    $self->command( 'fetch', '--tags' );
172
12
51845
    my %ref = $self->show_ref;
173
12
36
    my @tags = ();
174# ; use Data::Dumper;
175# ; warn Dumper \%ref;
176
12
39
    for my $key ( keys %ref ) {
177
114
215
        next unless $key =~ m{^refs/tags};
178
42
64
        if ( $ref{$key} eq $ref{HEAD} ) {
179
12
60
            my ( $tag ) = $key =~ m{/([^/]+)$};
180
12
23
            push @tags, $tag;
181        }
182    }
183# ; warn "Found: " . Dumper \@tags;
184
12
51
    my $version = [ sort version_sort @tags ]->[0];
185# ; warn "Current release: $version";
186
12
62
    return $version;
187}
188
1891;