File: | blib/lib/Git/ReleaseRepo/Repository.pm |
Coverage: | 86.8% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Git::ReleaseRepo::Repository; | ||||||
2 | |||||||
3 | 2 2 2 | 2074 2 6 | use Moose; | ||||
4 | extends '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 | ||||||
18 | has release_prefix => ( | ||||||
19 | is => 'rw', | ||||||
20 | isa => 'Str', | ||||||
21 | default => 'v', | ||||||
22 | ); | ||||||
23 | |||||||
24 | sub 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 | |||||||
35 | sub 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 | |||||||
44 | sub 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 | |||||||
60 | sub 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 | |||||||
91 | sub 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 | |||||||
99 | sub list_versions { | ||||||
100 | 20 | 0 | 30 | my ( $self, $rel_branch ) = @_; | |||
101 | 20 | 61 | return $self->list_version_refs( 'tags', $rel_branch ); | ||||
102 | } | ||||||
103 | |||||||
104 | sub 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 | |||||||
110 | sub list_release_branches { | ||||||
111 | 24 | 0 | 37 | my ( $self ) = @_; | |||
112 | 24 | 58 | return $self->list_version_refs( 'heads' ); | ||||
113 | } | ||||||
114 | |||||||
115 | sub 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 | |||||||
121 | sub 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 | |||||||
135 | sub 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 | |||||||
147 | sub 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 | |||||||
159 | sub has_remote { | ||||||
160 | 59 | 0 | 127 | my ( $self, $name ) = @_; | |||
161 | 59 19 | 157 108472 | return grep { $_ eq $name } $self->run( 'remote' ); | ||||
162 | } | ||||||
163 | |||||||
164 | sub 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 | |||||||
169 | sub 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 | |||||||
189 | 1; |