Commit | Line | Data |
---|---|---|
69c406f3 S |
1 | #!perl |
2 | use strict; | |
3 | use warnings; | |
4 | use Getopt::Long qw/GetOptions/; | |
5 | use Term::ANSIColor qw/color/; | |
6 | use constant GITCMD => 'git'; | |
7 | ||
8 | sub usage { | |
9 | print <<HERE; | |
a45a6dbc | 10 | Usage: $0 [options] [<start-commit> [<end-commit>]] |
69c406f3 S |
11 | |
12 | Scans the commit logs for commits that are potentially, illegitimately | |
13 | touching modules that are primarily maintained outside of the perl core. | |
14 | Also checks for commits that span multiple distributions in cpan/ or dist/. | |
a45a6dbc S |
15 | Makes sure that updated CPAN distributions also update Porting/Maintainers.pl, |
16 | but otherwise ignores changes to that file (and MANIFEST). | |
69c406f3 S |
17 | |
18 | Skip the <start-commit> to go back indefinitely. <end-commit> defaults to | |
19 | HEAD. | |
20 | ||
21 | -h/--help shows this help | |
22 | -v/--verbose shows the output of "git show --stat <commit>" for each commit | |
23 | -c/--color uses colored output | |
24 | HERE | |
25 | exit(1); | |
26 | } | |
27 | ||
28 | our $Verbose = 0; | |
29 | our $Color = 0; | |
30 | GetOptions( | |
31 | 'h|help' => \&usage, | |
32 | 'v|verbose' => \$Verbose, | |
33 | 'c|color|colour' => \$Color, | |
34 | ); | |
35 | ||
36 | my $start_commit = shift; | |
37 | my $end_commit = shift; | |
38 | $end_commit = 'HEAD' if not defined $end_commit; | |
39 | my $commit_range_cmd = defined($start_commit) ? " $start_commit..$end_commit" : ""; | |
40 | ||
41 | # format: hash\0author\0committer\0short_msg | |
42 | our $LogCmd = GITCMD() . q{ log --no-color -M -C --name-only '--pretty=format:%h%x00%an%x00%cn%x00%s'} . $commit_range_cmd; | |
43 | our @ColumnSpec = qw(hash author committer commit_msg); | |
44 | ||
45 | open my $fh, '-|', $LogCmd | |
46 | or die "Can't run '$LogCmd' to get the commit log: $!"; | |
47 | ||
48 | my ($safe_commits, $unsafe_commits) = parse_log($fh); | |
49 | ||
50 | if (@$unsafe_commits) { | |
51 | my $header = "Potentially unsafe commits:"; | |
52 | print color("red") if $Color; | |
53 | print $header, "\n"; | |
54 | print("=" x length($header), "\n\n") if $Verbose; | |
55 | print color("reset") if $Color; | |
56 | print_commit_info($_) foreach reverse @$unsafe_commits; | |
57 | print "\n"; | |
58 | } | |
59 | ||
60 | if (@$safe_commits) { | |
61 | my $header = "Presumably safe commits:"; | |
62 | print color("green") if $Color; | |
63 | print $header, "\n"; | |
64 | print("=" x length($header), "\n") if $Verbose; | |
65 | print color("reset") if $Color; | |
66 | print_commit_info($_) foreach reverse @$safe_commits; | |
67 | print "\n"; | |
68 | } | |
69 | ||
70 | exit(0); | |
71 | ||
72 | ||
73 | ||
74 | # single-line info about the commit at hand | |
75 | sub print_commit_info { | |
76 | my $commit = shift; | |
77 | ||
78 | my $author_info = "by $commit->{author}" | |
79 | . ($commit->{author} eq $commit->{committer} | |
80 | ? '' | |
81 | : " committed by $commit->{committer}"); | |
82 | ||
83 | if ($Verbose) { | |
84 | print color("yellow") if $Color; | |
85 | my $header = "$commit->{hash} $author_info: $commit->{msg}"; | |
86 | print "$header\n", ("-" x length($header)), "\n"; | |
87 | print color("reset") if $Color; | |
88 | ||
89 | my $cmd = GITCMD() . ' show --stat ' . ($Color?'--color ':'') | |
90 | . $commit->{hash}; | |
91 | print `$cmd`; # make sure git knows this isn't a terminal | |
92 | print "\n"; | |
93 | } | |
94 | else { | |
95 | print color("yellow") if $Color; | |
96 | print " $commit->{hash} $author_info: $commit->{msg}\n"; | |
97 | print color("reset") if $Color; | |
98 | } | |
99 | } | |
100 | ||
101 | ||
102 | # check whether the commit at hand is safe, unsafe or uninteresting | |
103 | sub check_commit { | |
104 | my $commit = shift; | |
105 | my $safe = shift; | |
106 | my $unsafe = shift; | |
107 | ||
a45a6dbc S |
108 | # Note to self: Adding any more greps and such will make this |
109 | # look even more silly. Just use a single foreach, smart guy! | |
110 | my $touches_maintainers_pl = 0; | |
111 | my @files = grep { | |
112 | $touches_maintainers_pl = 1 | |
113 | if $_ eq 'Porting/Maintainers.pl'; | |
114 | $_ ne 'MANIFEST' and $_ ne 'Porting/Maintainers.pl' | |
115 | } | |
69c406f3 S |
116 | @{$commit->{files}}; |
117 | my @touching_cpan = grep {/^cpan\//} @files; | |
118 | return if not @touching_cpan; | |
119 | ||
120 | # check for unsafe commits to cpan/ | |
121 | my %touched_cpan_dirs; | |
122 | $touched_cpan_dirs{$_}++ for grep {defined $_} | |
123 | map {s/^cpan\/([^\/]*).*$/$1/; $_} | |
124 | @touching_cpan; | |
125 | ||
126 | my $touches_multiple_cpan_dists = (keys(%touched_cpan_dirs) > 1); | |
127 | ||
128 | my $touches_others = @files - @touching_cpan; | |
129 | ||
130 | if (@touching_cpan) { | |
131 | if ($touches_others) { | |
132 | $commit->{msg} = 'Touched files under cpan/ and other locations'; | |
133 | push @$unsafe, $commit; | |
134 | } | |
135 | elsif ($touches_multiple_cpan_dists) { | |
136 | $commit->{msg} = 'Touched multiple directories under cpan/'; | |
137 | push @$unsafe, $commit; | |
138 | } | |
a45a6dbc S |
139 | elsif (not $touches_maintainers_pl) { |
140 | $commit->{msg} = 'Touched files under cpan/, but does not update ' | |
141 | . 'Porting/Maintainers.pl'; | |
142 | push @$unsafe, $commit; | |
143 | } | |
69c406f3 S |
144 | elsif ($commit->{commit_msg} =~ /(?:up(?:grad|dat)|import)(?:ed?|ing)/i) { |
145 | $commit->{msg} = 'Touched files under cpan/ with ' | |
146 | . '"upgrading"-like commit message'; | |
147 | push @$safe, $commit; | |
148 | } | |
149 | else { | |
150 | $commit->{msg} = 'Touched files under cpan/ without ' | |
151 | . '"upgrading"-like commit message'; | |
152 | push @$unsafe, $commit; | |
153 | } | |
154 | } | |
155 | ||
156 | # check for unsafe commits to dist/ | |
157 | my @touching_dist = grep {/^dist\//} @files; | |
158 | my %touched_dist_dirs; | |
159 | $touched_dist_dirs{$_}++ for grep {defined $_} | |
160 | map {s/^dist\/([^\/]*).*$/$1/; $_} | |
161 | @touching_dist; | |
162 | $touches_others = @files - @touching_dist; | |
163 | my $touches_multiple_dists = (keys(%touched_dist_dirs) > 1); | |
a45a6dbc | 164 | |
69c406f3 S |
165 | if (@touching_dist) { |
166 | if ($touches_others) { | |
167 | $commit->{msg} = 'Touched files under dist/ and other locations'; | |
168 | push @$unsafe, $commit; | |
169 | } | |
170 | elsif ($touches_multiple_dists) { | |
171 | $commit->{msg} = 'Touched multiple directories under cpan/'; | |
172 | push @$unsafe, $commit; | |
173 | } | |
174 | } | |
175 | } | |
176 | ||
177 | # given file handle, parse the git log output and put the resulting commit | |
178 | # structure into safe/unsafe compartments | |
179 | sub parse_log { | |
180 | my $fh = shift; | |
181 | my @safe_commits; | |
182 | my @unsafe_commits; | |
183 | my $commit; | |
184 | while (defined(my $line = <$fh>)) { | |
185 | chomp $line; | |
186 | if (not $commit) { | |
187 | next if $line =~ /^\s*$/; | |
188 | my @cols = split /\0/, $line; | |
189 | @cols == @ColumnSpec && !grep {!defined($_)} @cols | |
190 | or die "Malformed commit header line: '$line'"; | |
191 | $commit = { | |
192 | files => [], | |
193 | map {$ColumnSpec[$_] => $cols[$_]} (0..$#cols) | |
194 | }; | |
195 | next; | |
196 | } | |
197 | elsif ($line =~ /^\s*$/) { # within commit, blank line | |
198 | check_commit($commit, \@safe_commits, \@unsafe_commits); | |
199 | $commit = undef; | |
200 | } | |
201 | else { # within commit, non-blank (file) line | |
202 | push @{$commit->{files}}, $line; | |
203 | } | |
204 | } | |
205 | ||
206 | return(\@safe_commits, \@unsafe_commits); | |
207 | } | |
208 |