| 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; | ||||||