File Coverage

blib/lib/App/Git/Workflow/Command/BranchClean.pm
Criterion Covered Total %
statement 74 78 94.8
branch 42 44 95.4
condition 8 10 80.0
subroutine 11 11 100.0
pod 5 5 100.0
total 140 148 94.5


line stmt bran cond sub pod time code
1             package App::Git::Workflow::Command::BranchClean;
2              
3             # Created on: 2014-03-11 20:58:59
4             # Create by: Ivan Wills
5             # $Id$
6             # $Revision$, $HeadURL$, $Date$
7             # $Revision$, $Source$, $Date$
8              
9 3     3   194595 use strict;
  3         24  
  3         102  
10 3     3   17 use warnings;
  3         9  
  3         111  
11 3     3   844 use version;
  3         3539  
  3         19  
12 3     3   1157 use English qw/ -no_match_vars /;
  3         6985  
  3         21  
13 3     3   2046 use App::Git::Workflow;
  3         9  
  3         168  
14 3     3   969 use App::Git::Workflow::Command qw/get_options/;
  3         10  
  3         3387  
15              
16             our $VERSION = version->new(1.1.16);
17             our $workflow = App::Git::Workflow->new;
18             my ($name) = $PROGRAM_NAME =~ m{^.*/(.*?)$}mxs;
19             our %option;
20             our %p2u_extra;
21              
22             sub run {
23 11     11 1 30 my ($self) = @_;
24              
25             %option = (
26             exclude => [],
27 11   100     94 max_age => ( $ENV{GIT_WORKFLOW_MAX_AGE} || $workflow->config('workflow.max') || 120 ),
28             tag_prefix => '',
29             tag_suffix => '',
30             );
31 11 100       69 get_options(
32             \%option,
33             'remote|r',
34             'all|a',
35             'exclude|e=s@',
36             'exclude_file|exclude-file|f=s',
37             'max_age|max-age|m=i',
38             'min_age|min-age|n=i',
39             'tag|t!',
40             'tag_prefix|tag-prefix|p=s',
41             'tag_suffix|tag-suffix|s=s',
42             'test!',
43             ) or return;
44              
45             # get the list of branches to look at
46 10         23 my $max = 0;
47 10 100       65 my @branches = $workflow->branches($option{remote} ? 'remote' : $option{all} ? 'both' : undef );
    100          
48 10         19 my @excludes = @{ $option{exclude} };
  10         26  
49 10   50     49 my $action = 'do_' . ( $ARGV[0] || 'delete' );
50 10         28 my ($total, $deleted) = (0, 0);
51              
52 10 50       82 if (!$self->can($action)) {
53 0         0 warn "Unknown action $ARGV[0]!\n";
54 0         0 Pod::Usage::pod2usage( %p2u_extra, -verbose => 1 );
55 0         0 return 1;
56             }
57              
58 10 100       32 if ($option{exclude_file}) {
59 1         7 for my $exclude ($workflow->slurp($option{exclude_file})) {
60 3         8 chomp $exclude;
61 3 100       9 next if !$exclude;
62 2 100       11 next if $exclude =~ /^\s*(?:[#].*)$/xms;
63 1         5 push @excludes, $exclude;
64             }
65             }
66              
67             BRANCH:
68 10         32 for my $branch (@branches) {
69             # skip master branches
70 31 100       137 next BRANCH if $branch =~ m{^ (?:[^/]+/)? master $}xms;
71 19 100       50 next BRANCH if grep {$branch =~ /$_/} @excludes;
  2         21  
72              
73             # get branch details
74 18         85 my $details = $workflow->commit_details($branch, branches => 0);
75              
76             # don't delete young branches even if merged
77 18 100       53 next BRANCH if too_young_to_die($details);
78              
79 16 100       63 $max = $details->{time} if $max < $details->{time};
80 16         58 $deleted += __PACKAGE__->$action($branch, $details);
81 16         65 $total++;
82             }
83              
84 10         285 warn "Deleted $deleted of $total branches\nMax = " . (int $max/60/60/24) . "\n";
85              
86 10         82 return;
87             }
88              
89             sub do_delete {
90 16     16 1 41 my ($self, $branch, $details) = @_;
91              
92 16         36 my $too_old = too_old($details);
93 16         28 my $in_master;
94              
95 16 100       49 if (!$too_old) {
96 15         48 $in_master = in_master($details);
97             }
98              
99 16 100 100     59 if ( $in_master || $too_old ) {
100 10 100       491 warn 'deleting ' . ($in_master ? 'merged' : 'old') . " branch $branch\n";
101              
102 10 100       111 my ($remote, $name) = $branch =~ m{/} ? split m{/}, $branch, 2 : (undef, $branch);
103              
104 10 100       41 if ( $option{tag} ) {
105 5         19 my $tag = $option{tag_prefix} . $name . $option{tag_suffix};
106 5 100       35 $workflow->git->tag(qw/-a -m /, "Converting '$name' to the tag '$tag'", $tag) if !$option{test};
107             }
108              
109 10 100       53 if ( !$option{test} ) {
110 8 100       40 if ($remote) {
111             eval {
112 2         10 $workflow->git->push($remote, '--no-verify', ":refs/heads/$name");
113 2         9 1;
114 2 50       5 } or do {
115 0         0 return 0;
116             }
117             }
118             else {
119 6         25 $workflow->git->branch('-D', "$name");
120             }
121             }
122              
123 10         33 return 1;
124             }
125              
126 6         15 return 0;
127             }
128              
129             sub in_master {
130 15     15 1 35 my ($details) = @_;
131              
132 15         52 my %branches = map { $_ => 1 } $workflow->branches('both', $details->{sha});
  23         89  
133              
134 15   66     64 return $branches{master} || $branches{'origin/master'};
135             }
136              
137             sub too_old {
138 16     16 1 35 my ($details) = @_;
139              
140 16 100       45 return if !$option{max_age};
141              
142 15         60 return time - $option{max_age} * 60 * 60 * 24 > $details->{time};
143             }
144              
145             sub too_young_to_die {
146 18     18 1 37 my ($details) = @_;
147              
148 18 100       62 return if !$option{min_age};
149              
150 4         28 return time - $option{min_age} * 60 * 60 * 24 < $details->{time};
151             }
152              
153             1;
154              
155             __DATA__
156              
157             =head1 NAME
158              
159             git-branch-clean - Clean old branches out of the repository
160              
161             =head1 VERSION
162              
163             This documentation refers to git-branch-clean version 1.1.16
164              
165             =head1 SYNOPSIS
166              
167             git-branch-clean [option]
168              
169             OPTIONS:
170             -r --remote Only remote branches (defaults to local branches)
171             -a --all All branches
172             -m --max-age[=]days
173             Maximum age of a branch with out changes before it is cleaned
174             weather it's merged to master or not. (Default 0, no max age)
175             -n --min-age[=]days
176             Leave branches this number of days or new alone even if merged
177             to master. (default 7 days)
178             -e --exclude[=]regex
179             Regular expression to exclude specific branches from deletion.
180             You can specify --exclude multiple times for more control.
181             --exclude-file[=]file
182             A file of exclude regular expressions, blank lines and lines
183             starting with a hash (#) are ignored.
184             -t --tag Create tags of the same name as the branch
185             -p --tag-prefix[=]str
186             When converting a branch to a tag prepend it with "str"
187             -s --tag-suffix[=]str
188             When converting a branch to a tag apend it with "str"
189             --test Don't actually delete branches just report on what branches
190             would be deleted.
191              
192             -v --verbose Show more detailed option
193             --version Prints the version information
194             --help Prints this help information
195             --man Prints the full documentation for git-branch-clean
196              
197             =head1 DESCRIPTION
198              
199             C<git-branch-clean> deletes branches merged to master (but not newer than
200             C<--min-age> days). Optionally also deleting branches that haven't been
201             modified more than C<--max-age> days. When deleting branches they can be
202             converted to tags (C<--tag>) with optional an prefix (C<--tag-prefix>) and/or
203             an optional suffix (C<--tag-suffix>) added.
204              
205             =head1 SUBROUTINES/METHODS
206              
207             =head2 C<run ()>
208              
209             Executes the git workflow command
210              
211             =head2 C<do_delete ($branch, $details)>
212              
213             Performs the deleting of old branches.
214              
215             =head2 C<in_master ($details)>
216              
217             The branch with C<$details> has been merged to master
218              
219             =head2 C<too_old ($details)>
220              
221             The branch with C<$details> has not been modified in greater than C<--max-age>
222             days.
223              
224             =head2 C<too_young_to_die ($details)>
225              
226             The branch was only recently used and should be cleaned.
227              
228             =head1 DIAGNOSTICS
229              
230             =head1 CONFIGURATION AND ENVIRONMENT
231              
232             =head1 DEPENDENCIES
233              
234             =head1 INCOMPATIBILITIES
235              
236             =head1 BUGS AND LIMITATIONS
237              
238             There are no known bugs in this module.
239              
240             Please report problems to Ivan Wills (ivan.wills@gmail.com).
241              
242             Patches are welcome.
243              
244             =head1 AUTHOR
245              
246             Ivan Wills - (ivan.wills@gmail.com)
247              
248             =head1 LICENSE AND COPYRIGHT
249              
250             Copyright (c) 2014 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW Australia 2077).
251             All rights reserved.
252              
253             This module is free software; you can redistribute it and/or modify it under
254             the same terms as Perl itself. See L<perlartistic>. This program is
255             distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
256             without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
257             PARTICULAR PURPOSE.
258              
259             =cut