Commit | Line | Data |
---|---|---|
80fea865 DG |
1 | #!/usr/bin/perl |
2 | # | |
3 | # This is a rough draft of a tool to aid in generating a perldelta file | |
4 | # from a series of git commits. | |
5 | ||
6 | use 5.010; | |
7 | use strict; | |
8 | use warnings; | |
9 | package Git::DeltaTool; | |
10 | ||
11 | use Class::Struct; | |
0d083db3 | 12 | use File::Basename; |
80fea865 DG |
13 | use File::Temp; |
14 | use Getopt::Long; | |
15 | use Git::Wrapper; | |
16 | use Term::ReadKey; | |
17 | use Term::ANSIColor; | |
54972104 | 18 | use Pod::Usage; |
80fea865 | 19 | |
241240e5 | 20 | BEGIN { struct( git => '$', last_tag => '$', opt => '%', original_stdout => '$' ) } |
80fea865 DG |
21 | |
22 | __PACKAGE__->run; | |
23 | ||
24 | #--------------------------------------------------------------------------# | |
25 | # main program | |
26 | #--------------------------------------------------------------------------# | |
27 | ||
28 | sub run { | |
29 | my $class = shift; | |
30 | ||
31 | my %opt = ( | |
32 | mode => 'assign', | |
33 | ); | |
34 | ||
35 | GetOptions( \%opt, | |
36 | # inputs | |
37 | 'mode|m:s', # 'assign', 'review', 'render', 'update' | |
38 | 'type|t:s', # select by status | |
39 | 'status|s:s', # status to set for 'update' | |
40 | 'since:s', # origin commit | |
54972104 | 41 | 'help|h', # help |
80fea865 DG |
42 | ); |
43 | ||
54972104 DG |
44 | pod2usage() if $opt{help}; |
45 | ||
80fea865 DG |
46 | my $git = Git::Wrapper->new("."); |
47 | my $git_id = $opt{since}; | |
48 | if ( defined $git_id ) { | |
49 | die "Invalid git identifier '$git_id'\n" | |
50 | unless eval { $git->show($git_id); 1 }; | |
51 | } else { | |
52 | ($git_id) = $git->describe; | |
53 | $git_id =~ s/-.*$//; | |
54 | } | |
55 | my $gdt = $class->new( git => $git, last_tag => $git_id, opt => \%opt ); | |
56 | ||
57 | if ( $opt{mode} eq 'assign' ) { | |
58 | $opt{type} //= 'new'; | |
59 | $gdt->assign; | |
60 | } | |
61 | elsif ( $opt{mode} eq 'review' ) { | |
62 | $opt{type} //= 'pending'; | |
63 | $gdt->review; | |
64 | } | |
65 | elsif ( $opt{mode} eq 'render' ) { | |
66 | $opt{type} //= 'pending'; | |
67 | $gdt->render; | |
68 | } | |
0b7740a2 DG |
69 | elsif ( $opt{mode} eq 'summary' ) { |
70 | $opt{type} //= 'pending'; | |
71 | $gdt->summary; | |
72 | } | |
80fea865 DG |
73 | elsif ( $opt{mode} eq 'update' ) { |
74 | die "Explicit --type argument required for update mode\n" | |
75 | unless defined $opt{type}; | |
29e2aa06 | 76 | die "Explicit --status argument required for update mode\n" |
80fea865 DG |
77 | unless defined $opt{status}; |
78 | $gdt->update; | |
79 | } | |
80 | else { | |
81 | die "Unrecognized mode '$opt{mode}'\n"; | |
82 | } | |
83 | exit 0; | |
84 | } | |
85 | ||
86 | #--------------------------------------------------------------------------# | |
87 | # program modes (and iterator) | |
88 | #--------------------------------------------------------------------------# | |
89 | ||
90 | sub assign { | |
91 | my ($self) = @_; | |
92 | my @choices = ( $self->section_choices, $self->action_choices ); | |
93 | $self->_iterate_commits( | |
94 | sub { | |
e67bd9d2 DG |
95 | my ($log, $i, $count) = @_; |
96 | say "\n### Commit @{[$i+1]} of $count ###"; | |
80fea865 DG |
97 | say "-" x 75; |
98 | $self->show_header($log); | |
99 | $self->show_body($log, 1); | |
1d06a943 | 100 | $self->show_files($log); |
80fea865 DG |
101 | say "-" x 75; |
102 | return $self->dispatch( $self->prompt( @choices ), $log); | |
103 | } | |
104 | ); | |
105 | return; | |
106 | } | |
107 | ||
108 | sub review { | |
109 | my ($self) = @_; | |
110 | my @choices = ( $self->review_choices, $self->action_choices ); | |
111 | $self->_iterate_commits( | |
112 | sub { | |
e67bd9d2 DG |
113 | my ($log, $i, $count) = @_; |
114 | say "\n### Commit @{[$i+1]} of $count ###"; | |
80fea865 DG |
115 | say "-" x 75; |
116 | $self->show_header($log); | |
80fea865 DG |
117 | $self->show_notes($log, 1); |
118 | say "-" x 75; | |
119 | return $self->dispatch( $self->prompt( @choices ), $log); | |
120 | } | |
121 | ); | |
122 | return; | |
123 | } | |
124 | ||
125 | sub render { | |
126 | my ($self) = @_; | |
127 | my %sections; | |
128 | $self->_iterate_commits( | |
129 | sub { | |
130 | my $log = shift; | |
131 | my $section = $self->note_section($log) or return; | |
132 | push @{ $sections{$section} }, $self->note_delta($log); | |
133 | return 1; | |
134 | } | |
135 | ); | |
136 | my @order = $self->section_order; | |
137 | my %known = map { $_ => 1 } @order; | |
138 | my @rest = grep { ! $known{$_} } keys %sections; | |
139 | for my $s ( @order, @rest ) { | |
140 | next unless ref $sections{$s}; | |
141 | say "-"x75; | |
142 | say uc($s) . "\n"; | |
143 | say join ( "\n", @{ $sections{$s} }, "" ); | |
144 | } | |
145 | return; | |
146 | } | |
147 | ||
0b7740a2 DG |
148 | sub summary { |
149 | my ($self) = @_; | |
150 | $self->_iterate_commits( | |
151 | sub { | |
152 | my $log = shift; | |
153 | $self->show_header($log); | |
154 | return 1; | |
155 | } | |
156 | ); | |
157 | return; | |
158 | } | |
159 | ||
80fea865 DG |
160 | sub update { |
161 | my ($self) = @_; | |
162 | ||
163 | my $status = $self->opt('status') | |
164 | or die "The 'status' option must be supplied for update mode\n"; | |
165 | ||
166 | $self->_iterate_commits( | |
167 | sub { | |
168 | my $log = shift; | |
169 | my $note = $log->notes; | |
170 | $note =~ s{^(perldelta.*\[)\w+(\].*)}{$1$status$2}ms; | |
171 | $self->add_note( $log->id, $note ); | |
172 | return 1; | |
173 | } | |
174 | ); | |
175 | return; | |
176 | } | |
177 | ||
178 | sub _iterate_commits { | |
179 | my ($self, $fcn) = @_; | |
180 | my $type = $self->opt('type'); | |
680aa2c2 | 181 | say STDERR "Scanning for $type commits since " . $self->last_tag . "..."; |
05c03560 DG |
182 | my $list = [ $self->find_commits($type) ]; |
183 | my $count = @$list; | |
184 | while ( my ($i,$log) = each @$list ) { | |
e67bd9d2 | 185 | redo unless $fcn->($log, $i, $count); |
80fea865 DG |
186 | } |
187 | return 1; | |
188 | } | |
189 | ||
190 | #--------------------------------------------------------------------------# | |
191 | # methods | |
192 | #--------------------------------------------------------------------------# | |
193 | ||
194 | sub add_note { | |
195 | my ($self, $id, $note) = @_; | |
e0c73568 | 196 | my @lines = split "\n", _strip_comments($note); |
80fea865 DG |
197 | pop @lines while @lines && $lines[-1] =~ m{^\s*$}; |
198 | my $tempfh = File::Temp->new; | |
199 | if (@lines) { | |
200 | $tempfh->printflush( join( "\n", @lines), "\n" ); | |
201 | $self->git->notes('edit', '-F', "$tempfh", $id); | |
202 | } | |
203 | else { | |
204 | $tempfh->printflush( "\n" ); | |
205 | # git notes won't take an empty file as input | |
206 | system("git notes edit -F $tempfh $id"); | |
207 | } | |
208 | ||
209 | return; | |
210 | } | |
211 | ||
212 | sub dispatch { | |
213 | my ($self, $choice, $log) = @_; | |
214 | return unless $choice; | |
215 | my $method = "do_$choice->{handler}"; | |
216 | return 1 unless $self->can($method); # missing methods "succeed" | |
217 | return $self->$method($choice, $log); | |
218 | } | |
219 | ||
220 | sub edit_text { | |
221 | my ($self, $text, $args) = @_; | |
222 | $args //= {}; | |
223 | my $tempfh = File::Temp->new; | |
224 | $tempfh->printflush( $text ); | |
b06d1545 | 225 | if ( my @editor = split /\s+/, ($ENV{VISUAL} || $ENV{EDITOR}) ) { |
80fea865 DG |
226 | push @editor, "-f" if $editor[0] =~ /^gvim/; |
227 | system(@editor, "$tempfh"); | |
228 | } | |
229 | else { | |
230 | warn("No VISUAL or EDITOR defined"); | |
231 | } | |
b61d9735 | 232 | return do { local (@ARGV,$/) = "$tempfh"; <> }; |
80fea865 DG |
233 | } |
234 | ||
235 | sub find_commits { | |
236 | my ($self, $type) = @_; | |
237 | $type //= 'new'; | |
238 | my @commits = $self->git->log($self->last_tag . "..HEAD"); | |
1d06a943 | 239 | $_ = Git::Wrapper::XLog->from_log($_, $self->git) for @commits; |
80fea865 DG |
240 | my @list; |
241 | if ( $type eq 'new' ) { | |
242 | @list = grep { ! $_->notes } @commits; | |
243 | } | |
244 | else { | |
245 | @list = grep { $self->note_status( $_ ) eq $type } @commits; | |
246 | } | |
247 | return @list; | |
248 | } | |
249 | ||
250 | sub get_diff { | |
251 | my ($self, $log) = @_; | |
252 | my @diff = $self->git->show({ stat => 1, p => 1 }, $log->id); | |
253 | return join("\n", @diff); | |
254 | } | |
255 | ||
256 | sub note_delta { | |
257 | my ($self, $log) = @_; | |
258 | my @delta = split "\n", ($log->notes || ''); | |
259 | return '' unless @delta; | |
260 | splice @delta, 0, 2; | |
261 | return join( "\n", @delta, "" ); | |
262 | } | |
263 | ||
264 | sub note_section { | |
265 | my ($self, $log) = @_; | |
266 | my $note = $log->notes or return ''; | |
267 | my ($section) = $note =~ m{^perldelta:\s*([^\[]*)\s+}ms; | |
268 | return $section || ''; | |
269 | } | |
270 | ||
271 | sub note_status { | |
272 | my ($self, $log) = @_; | |
273 | my $note = $log->notes or return ''; | |
274 | my ($status) = $note =~ m{^perldelta:\s*[^\[]*\[(\w+)\]}ms; | |
275 | return $status || ''; | |
276 | } | |
277 | ||
278 | sub note_template { | |
279 | my ($self, $log, $text) = @_; | |
280 | my $diff = _prepend_comment( $self->get_diff($log) ); | |
281 | return << "HERE"; | |
282 | # Edit commit note below. Do not change the first line. Comments are stripped | |
283 | $text | |
284 | ||
285 | $diff | |
286 | HERE | |
287 | } | |
288 | ||
289 | sub prompt { | |
290 | my ($self, @choices) = @_; | |
291 | my ($valid, @menu, %keymap) = ''; | |
292 | for my $c ( map { @$_ } @choices ) { | |
293 | my ($item) = grep { /\(/ } split q{ }, $c->{name}; | |
294 | my ($button) = $item =~ m{\((.)\)}; | |
295 | die "No key shortcut found for '$item'" unless $button; | |
296 | die "Duplicate key shortcut found for '$item'" if $keymap{lc $button}; | |
297 | push @menu, $item; | |
298 | $valid .= lc $button; | |
299 | $keymap{lc $button} = $c; | |
300 | } | |
301 | my $keypress = $self->prompt_key( $self->wrap_list(@menu), $valid ); | |
302 | return $keymap{lc $keypress}; | |
303 | } | |
304 | ||
305 | sub prompt_key { | |
306 | my ($self, $prompt, $valid_keys) = @_; | |
307 | my $key; | |
308 | KEY: { | |
309 | say $prompt; | |
310 | ReadMode 3; | |
311 | $key = lc ReadKey(0); | |
312 | ReadMode 0; | |
313 | if ( $key !~ qr/\A[$valid_keys]\z/i ) { | |
314 | say ""; | |
315 | redo KEY; | |
316 | } | |
317 | } | |
318 | return $key; | |
319 | } | |
320 | ||
321 | sub show_body { | |
322 | my ($self, $log, $lf) = @_; | |
323 | return unless my $body = $log->body; | |
324 | say $lf ? "\n$body" : $body; | |
325 | return; | |
326 | } | |
327 | ||
1d06a943 DG |
328 | sub show_files { |
329 | my ($self, $log) = @_; | |
330 | my @files = $self->git->diff_tree({r => 1, abbrev => 1}, $log->id); | |
331 | shift @files; # throw away commit line | |
332 | return unless @files; | |
333 | say "\nChanged:"; | |
334 | say join("\n", map { " * $_" } sort map { /.*\s+(\S+)/; $1 } @files); | |
335 | return; | |
336 | } | |
337 | ||
80fea865 DG |
338 | sub show_header { |
339 | my ($self, $log) = @_; | |
340 | my $header = $log->short_id; | |
341 | $header .= " " . $log->subject if length $log->subject; | |
d83adb22 | 342 | $header .= sprintf(' (%s)', $log->author) if $log->author; |
80fea865 DG |
343 | say colored( $header, "yellow"); |
344 | return; | |
345 | } | |
346 | ||
347 | sub show_notes { | |
348 | my ($self, $log, $lf) = @_; | |
349 | return unless my $notes = $log->notes; | |
350 | say $lf ? "\n$notes" : $notes; | |
351 | return; | |
352 | } | |
353 | ||
354 | sub wrap_list { | |
355 | my ($self, @list) = @_; | |
356 | my $line = shift @list; | |
357 | my @wrap; | |
358 | for my $item ( @list ) { | |
359 | if ( length( $line . $item ) > 70 ) { | |
360 | push @wrap, $line; | |
361 | $line = $item ne $list[-1] ? $item : "or $item"; | |
362 | } | |
363 | else { | |
364 | $line .= $item ne $list[-1] ? ", $item" : " or $item"; | |
365 | } | |
366 | } | |
367 | return join("\n", @wrap, $line); | |
368 | } | |
369 | ||
370 | sub y_n { | |
371 | my ($self, $msg) = @_; | |
372 | my $key = $self->prompt_key($msg . " (y/n?)", 'yn'); | |
373 | return $key eq 'y'; | |
374 | } | |
375 | ||
376 | #--------------------------------------------------------------------------# | |
377 | # handlers | |
378 | #--------------------------------------------------------------------------# | |
379 | ||
f46711e6 DG |
380 | sub do_blocking { |
381 | my ($self, $choice, $log) = @_; | |
382 | my $note = "perldelta: Unknown [blocking]\n"; | |
383 | $self->add_note( $log->id, $note ); | |
384 | return 1; | |
385 | } | |
386 | ||
241240e5 FR |
387 | sub do_examine { |
388 | my ($self, $choice, $log) = @_; | |
389 | $self->start_pager; | |
390 | say $self->get_diff($log); | |
391 | $self->end_pager; | |
392 | return; | |
393 | } | |
394 | ||
0d083db3 DG |
395 | sub do_cherry { |
396 | my ($self, $choice, $log) = @_; | |
397 | my $id = $log->short_id; | |
398 | $self->y_n("Recommend a cherry pick of '$id' to maint?") or return; | |
399 | my $cherrymaint = dirname($0) . "/cherrymaint"; | |
400 | system("$^X $cherrymaint --vote $id"); | |
401 | return; # false will re-prompt the same commit | |
402 | } | |
403 | ||
80fea865 DG |
404 | sub do_done { |
405 | my ($self, $choice, $log) = @_; | |
406 | my $note = $log->notes; | |
407 | $note =~ s{^(perldelta.*\[)\w+(\].*)}{$1done$2}ms; | |
408 | $self->add_note( $log->id, $note ); | |
409 | return 1; | |
410 | } | |
411 | ||
412 | sub do_edit { | |
413 | my ($self, $choice, $log) = @_; | |
414 | my $old_note = $log->notes; | |
415 | my $new_note = $self->edit_text( $self->note_template( $log, $old_note) ); | |
e0c73568 | 416 | $self->add_note( $log->id, $new_note ); |
80fea865 DG |
417 | return 1; |
418 | } | |
419 | ||
420 | sub do_head2 { | |
421 | my ($self, $choice, $log) = @_; | |
422 | my $section = _strip_parens($choice->{name}); | |
423 | my $subject = $log->subject; | |
424 | my $body = $log->body; | |
80fea865 DG |
425 | |
426 | my $template = $self->note_template( $log, | |
08973043 | 427 | "perldelta: $section [pending]\n\n=head2 $subject\n\n$body\n" |
80fea865 DG |
428 | ); |
429 | ||
430 | my $note = $self->edit_text( $template ); | |
431 | if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) { | |
e0c73568 | 432 | $self->add_note( $log->id, $note ); |
80fea865 DG |
433 | return 1; |
434 | } | |
435 | return; | |
436 | } | |
437 | ||
29e2aa06 DG |
438 | sub do_linked_item { |
439 | my ($self, $choice, $log) = @_; | |
440 | my $section = _strip_parens($choice->{name}); | |
441 | my $subject = $log->subject; | |
442 | my $body = $log->body; | |
29e2aa06 DG |
443 | |
444 | my $template = $self->note_template( $log, | |
08973043 | 445 | "perldelta: $section [pending]\n\n=head3 L<LINK>\n\n=over\n\n=item *\n\n$subject\n\n$body\n\n=back\n" |
29e2aa06 DG |
446 | ); |
447 | ||
448 | my $note = $self->edit_text($template); | |
449 | if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) { | |
450 | $self->add_note( $log->id, $note ); | |
451 | return 1; | |
452 | } | |
453 | return; | |
454 | } | |
455 | ||
80fea865 DG |
456 | sub do_item { |
457 | my ($self, $choice, $log) = @_; | |
458 | my $section = _strip_parens($choice->{name}); | |
459 | my $subject = $log->subject; | |
460 | my $body = $log->body; | |
80fea865 | 461 | |
e6bf3f2c | 462 | my $template = $self->note_template( $log, |
08973043 | 463 | "perldelta: $section [pending]\n\n=item *\n\n$subject\n\n$body\n" |
e6bf3f2c | 464 | ); |
80fea865 DG |
465 | |
466 | my $note = $self->edit_text($template); | |
467 | if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) { | |
468 | $self->add_note( $log->id, $note ); | |
469 | return 1; | |
470 | } | |
471 | return; | |
472 | } | |
473 | ||
474 | sub do_none { | |
475 | my ($self, $choice, $log) = @_; | |
476 | my $note = "perldelta: None [ignored]\n"; | |
477 | $self->add_note( $log->id, $note ); | |
478 | return 1; | |
479 | } | |
480 | ||
29e2aa06 DG |
481 | sub do_platform { |
482 | my ($self, $choice, $log) = @_; | |
483 | my $section = _strip_parens($choice->{name}); | |
484 | my $subject = $log->subject; | |
485 | my $body = $log->body; | |
29e2aa06 DG |
486 | |
487 | my $template = $self->note_template( $log, | |
08973043 | 488 | "perldelta: $section [pending]\n\n=item PLATFORM-NAME\n\n$subject\n\n$body\n" |
29e2aa06 DG |
489 | ); |
490 | ||
491 | my $note = $self->edit_text($template); | |
492 | if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) { | |
493 | $self->add_note( $log->id, $note ); | |
494 | return 1; | |
495 | } | |
496 | return; | |
497 | } | |
498 | ||
80fea865 DG |
499 | sub do_quit { exit 0 } |
500 | ||
0d083db3 DG |
501 | sub do_repeat { return 0 } |
502 | ||
80fea865 DG |
503 | sub do_skip { return 1 } |
504 | ||
505 | sub do_special { | |
506 | my ($self, $choice, $log) = @_; | |
507 | my $section = _strip_parens($choice->{name}); | |
508 | my $subject = $log->subject; | |
509 | my $body = $log->body; | |
80fea865 DG |
510 | |
511 | my $template = $self->note_template( $log, << "HERE" ); | |
512 | perldelta: $section [pending] | |
513 | ||
514 | $subject | |
515 | ||
08973043 | 516 | $body |
80fea865 DG |
517 | HERE |
518 | ||
519 | my $note = $self->edit_text( $template ); | |
520 | if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) { | |
e0c73568 | 521 | $self->add_note( $log->id, $note ); |
80fea865 DG |
522 | return 1; |
523 | } | |
524 | return; | |
525 | } | |
526 | ||
527 | sub do_subsection { | |
528 | my ($self, $choice, $log) = @_; | |
0d083db3 | 529 | my @choices = ( $choice->{subsection}, $self->submenu_choices ); |
80fea865 | 530 | say "For " . _strip_parens($choice->{name}) . ":"; |
0d083db3 | 531 | return $self->dispatch( $self->prompt( @choices ), $log); |
80fea865 DG |
532 | } |
533 | ||
534 | #--------------------------------------------------------------------------# | |
535 | # define prompts | |
536 | #--------------------------------------------------------------------------# | |
537 | ||
538 | sub action_choices { | |
539 | my ($self) = @_; | |
540 | state $action_choices = [ | |
241240e5 | 541 | { name => 'E(x)amine', handler => 'examine' }, |
0d083db3 | 542 | { name => '(+)Cherrymaint', handler => 'cherry' }, |
f46711e6 | 543 | { name => '(?)NeedHelp', handler => 'blocking' }, |
80fea865 DG |
544 | { name => 'S(k)ip', handler => 'skip' }, |
545 | { name => '(Q)uit', handler => 'quit' }, | |
546 | ]; | |
547 | return $action_choices; | |
548 | } | |
549 | ||
0d083db3 DG |
550 | sub submenu_choices { |
551 | my ($self) = @_; | |
552 | state $submenu_choices = [ | |
553 | { name => '(B)ack', handler => 'repeat' }, | |
554 | ]; | |
555 | return $submenu_choices; | |
556 | } | |
557 | ||
558 | ||
80fea865 DG |
559 | sub review_choices { |
560 | my ($self) = @_; | |
561 | state $action_choices = [ | |
562 | { name => '(E)dit', handler => 'edit' }, | |
563 | { name => '(I)gnore', handler => 'none' }, | |
564 | { name => '(D)one', handler => 'done' }, | |
565 | ]; | |
566 | return $action_choices; | |
567 | } | |
568 | ||
569 | sub section_choices { | |
570 | my ($self, $key) = @_; | |
571 | state $section_choices = [ | |
572 | # Headline stuff that should go first | |
573 | { | |
574 | name => 'Core (E)nhancements', | |
575 | handler => 'head2', | |
576 | }, | |
577 | { | |
578 | name => 'Securit(y)', | |
579 | handler => 'head2', | |
580 | }, | |
581 | { | |
582 | name => '(I)ncompatible Changes', | |
583 | handler => 'head2', | |
584 | }, | |
585 | { | |
586 | name => 'Dep(r)ecations', | |
587 | handler => 'head2', | |
588 | }, | |
589 | { | |
590 | name => '(P)erformance Enhancements', | |
591 | handler => 'item', | |
592 | }, | |
593 | ||
594 | # Details on things installed with Perl (for Perl developers) | |
595 | { | |
596 | name => '(M)odules and Pragmata', | |
597 | handler => 'subsection', | |
598 | subsection => [ | |
599 | { | |
600 | name => '(N)ew Modules and Pragmata', | |
601 | handler => 'item', | |
602 | }, | |
603 | { | |
604 | name => '(U)pdated Modules and Pragmata', | |
605 | handler => 'item', | |
606 | }, | |
607 | { | |
608 | name => '(R)emoved Modules and Pragmata', | |
609 | handler => 'item', | |
610 | }, | |
611 | ], | |
612 | }, | |
613 | { | |
614 | name => '(D)ocumentation', | |
615 | handler => 'subsection', | |
616 | subsection => [ | |
617 | { | |
618 | name => '(N)ew Documentation', | |
29e2aa06 | 619 | handler => 'linked_item', |
80fea865 DG |
620 | }, |
621 | { | |
622 | name => '(C)hanges to Existing Documentation', | |
29e2aa06 | 623 | handler => 'linked_item', |
80fea865 DG |
624 | }, |
625 | ], | |
626 | }, | |
627 | { | |
628 | name => 'Dia(g)nostics', | |
629 | handler => 'subsection', | |
630 | subsection => [ | |
631 | { | |
632 | name => '(N)ew Diagnostics', | |
633 | handler => 'item', | |
634 | }, | |
635 | { | |
636 | name => '(C)hanges to Existing Diagnostics', | |
637 | handler => 'item', | |
638 | }, | |
639 | ], | |
640 | }, | |
641 | { | |
642 | name => '(U)tilities', | |
29e2aa06 | 643 | handler => 'linked_item', |
80fea865 DG |
644 | }, |
645 | ||
646 | # Details on building/testing Perl (for porters and packagers) | |
647 | { | |
648 | name => '(C)onfiguration and Compilation', | |
649 | handler => 'item', | |
650 | }, | |
651 | { | |
652 | name => '(T)esting', # new tests or significant notes about it | |
653 | handler => 'item', | |
654 | }, | |
655 | { | |
656 | name => 'Pl(a)tform Support', | |
657 | handler => 'subsection', | |
658 | subsection => [ | |
659 | { | |
660 | name => '(N)ew Platforms', | |
29e2aa06 | 661 | handler => 'platform', |
80fea865 DG |
662 | }, |
663 | { | |
664 | name => '(D)iscontinued Platforms', | |
29e2aa06 | 665 | handler => 'platform', |
80fea865 DG |
666 | }, |
667 | { | |
668 | name => '(P)latform-Specific Notes', | |
29e2aa06 | 669 | handler => 'platform', |
80fea865 DG |
670 | }, |
671 | ], | |
672 | }, | |
673 | ||
674 | # Details on perl internals (for porters and XS developers) | |
675 | { | |
676 | name => 'Inter(n)al Changes', | |
677 | handler => 'item', | |
678 | }, | |
679 | ||
680 | # Bugs fixed and related stuff | |
681 | { | |
682 | name => 'Selected Bug (F)ixes', | |
683 | handler => 'item', | |
684 | }, | |
685 | { | |
686 | name => 'Known Prob(l)ems', | |
687 | handler => 'item', | |
688 | }, | |
689 | ||
690 | # dummy options for special handling | |
691 | { | |
692 | name => '(S)pecial', | |
693 | handler => 'special', | |
694 | }, | |
695 | { | |
696 | name => '(*)None', | |
697 | handler => 'none', | |
698 | }, | |
699 | ]; | |
700 | return $section_choices; | |
701 | } | |
702 | ||
703 | sub section_order { | |
704 | my ($self) = @_; | |
705 | state @order; | |
706 | if ( ! @order ) { | |
707 | for my $c ( @{ $self->section_choices } ) { | |
708 | if ( $c->{subsection} ) { | |
709 | push @order, map { $_->{name} } @{$c->{subsection}}; | |
710 | } | |
711 | else { | |
712 | push @order, $c->{name}; | |
713 | } | |
714 | } | |
715 | } | |
716 | return @order; | |
717 | } | |
718 | ||
719 | #--------------------------------------------------------------------------# | |
241240e5 FR |
720 | # Pager handling |
721 | #--------------------------------------------------------------------------# | |
722 | ||
723 | sub get_pager { $ENV{'PAGER'} || `which less` || `which more` } | |
724 | ||
725 | sub in_pager { shift->original_stdout ? 1 : 0 } | |
726 | ||
727 | sub start_pager { | |
728 | my $self = shift; | |
729 | my $content = shift; | |
730 | if (!$self->in_pager) { | |
731 | local $ENV{'LESS'} ||= '-FXe'; | |
732 | local $ENV{'MORE'}; | |
733 | $ENV{'MORE'} ||= '-FXe' unless $^O =~ /^MSWin/; | |
734 | ||
735 | my $pager = $self->get_pager; | |
736 | return unless $pager; | |
737 | open (my $cmd, "|-", $pager) || return; | |
738 | $|++; | |
739 | $self->original_stdout(*STDOUT); | |
740 | ||
741 | # $pager will be closed once we restore STDOUT to $original_stdout | |
742 | *STDOUT = $cmd; | |
743 | } | |
744 | } | |
745 | ||
746 | sub end_pager { | |
747 | my $self = shift; | |
748 | return unless ($self->in_pager); | |
749 | *STDOUT = $self->original_stdout; | |
750 | ||
751 | # closes the pager | |
752 | $self->original_stdout(undef); | |
753 | } | |
754 | ||
755 | #--------------------------------------------------------------------------# | |
80fea865 DG |
756 | # Utility functions |
757 | #--------------------------------------------------------------------------# | |
758 | ||
759 | sub _strip_parens { | |
760 | my ($name) = @_; | |
761 | $name =~ s/[()]//g; | |
762 | return $name; | |
763 | } | |
764 | ||
765 | sub _prepend_comment { | |
766 | my ($text) = @_; | |
767 | return join ("\n", map { s/^/# /g; $_ } split "\n", $text); | |
768 | } | |
769 | ||
770 | sub _strip_comments { | |
771 | my ($text) = @_; | |
772 | return join ("\n", grep { ! /^#/ } split "\n", $text); | |
773 | } | |
774 | ||
775 | #--------------------------------------------------------------------------# | |
776 | # Extend Git::Wrapper::Log | |
777 | #--------------------------------------------------------------------------# | |
778 | ||
779 | package Git::Wrapper::XLog; | |
780 | BEGIN { our @ISA = qw/Git::Wrapper::Log/; } | |
781 | ||
782 | sub subject { shift->attr->{subject} } | |
783 | sub body { shift->attr->{body} } | |
784 | sub short_id { shift->attr->{short_id} } | |
d83adb22 | 785 | sub author { shift->attr->{author} } |
80fea865 DG |
786 | |
787 | sub from_log { | |
1d06a943 | 788 | my ($class, $log, $git) = @_; |
80fea865 DG |
789 | |
790 | my $msg = $log->message; | |
791 | my ($subject, $body) = $msg =~ m{^([^\n]+)\n*(.*)}ms; | |
792 | $subject //= ''; | |
793 | $body //= ''; | |
794 | $body =~ s/[\r\n]*\z//ms; | |
795 | ||
1d06a943 | 796 | my ($short) = $git->rev_parse({short => 1}, $log->id); |
80fea865 DG |
797 | |
798 | $log->attr->{subject} = $subject; | |
799 | $log->attr->{body} = $body; | |
800 | $log->attr->{short_id} = $short; | |
801 | return bless $log, $class; | |
802 | } | |
803 | ||
804 | sub notes { | |
805 | my ($self) = @_; | |
806 | my @notes = eval { Git::Wrapper->new(".")->notes('show', $self->id) }; | |
807 | pop @notes while @notes && $notes[-1] =~ m{^\s*$}; | |
808 | return unless @notes; | |
809 | return join ("\n", @notes); | |
810 | } | |
811 | ||
812 | __END__ | |
813 | ||
814 | =head1 NAME | |
815 | ||
54972104 | 816 | git-deltatool - Annotate commits for perldelta |
80fea865 DG |
817 | |
818 | =head1 SYNOPSIS | |
819 | ||
820 | # annotate commits back to last 'git describe' tag | |
821 | ||
54972104 | 822 | $ git-deltatool |
80fea865 DG |
823 | |
824 | # review annotations | |
825 | ||
54972104 | 826 | $ git-deltatool --mode review |
80fea865 | 827 | |
f46711e6 DG |
828 | # review commits needing help |
829 | ||
830 | $ git-deltatool --mode review --type blocking | |
831 | ||
0b7740a2 DG |
832 | # summarize commits needing help |
833 | ||
834 | $ git-deltatool --mode summary --type blocking | |
835 | ||
836 | # assemble annotations by section to STDOUT | |
80fea865 | 837 | |
54972104 | 838 | $ git-deltatool --mode render |
80fea865 | 839 | |
b66a639c AB |
840 | # Get a list of commits needing further review, e.g. for peer review |
841 | ||
842 | $ git-deltatool --mode summary --type blocking | |
843 | ||
80fea865 DG |
844 | # mark 'pending' annotations as 'done' (i.e. added to perldelta) |
845 | ||
54972104 | 846 | $ git-deltatool --mode update --type pending --status done |
80fea865 DG |
847 | |
848 | =head1 OPTIONS | |
849 | ||
850 | =over | |
851 | ||
852 | =item B<--mode>|B<-m> MODE | |
853 | ||
854 | Indicates the run mode for the program. The default is 'assign' which | |
855 | assigns categories and marks the notes as 'pending' (or 'ignored'). Other | |
92e59e0a | 856 | modes are 'review', 'render', 'summary' and 'update'. |
80fea865 DG |
857 | |
858 | =item B<--type>|B<-t> TYPE | |
859 | ||
0b7740a2 DG |
860 | Indicates what types of commits to process. The default for 'assign' mode is |
861 | 'new', which processes commits without any perldelta notes. The default for | |
92e59e0a | 862 | 'review', 'summary' and 'render' modes is 'pending'. The options must be set |
0b7740a2 | 863 | explicitly for 'update' mode. |
80fea865 | 864 | |
f46711e6 DG |
865 | The type 'blocking' is reserved for commits needing further review. |
866 | ||
80fea865 DG |
867 | =item B<--status>|B<-s> STATUS |
868 | ||
869 | For 'update' mode only, sets a new status. While there is no restriction, | |
f46711e6 | 870 | it should be one of 'new', 'pending', 'blocking', 'ignored' or 'done'. |
80fea865 DG |
871 | |
872 | =item B<--since> REVISION | |
873 | ||
874 | Defines the boundary for searching git commits. Defaults to the last | |
875 | major tag (as would be given by 'git describe'). | |
876 | ||
54972104 DG |
877 | =item B<--help> |
878 | ||
879 | Shows the manual. | |
880 | ||
80fea865 DG |
881 | =back |
882 | ||
29e2aa06 DG |
883 | =head1 TODO |
884 | ||
885 | It would be nice to make some of the structured sections smarter -- e.g. | |
886 | look at changed files in pod/* for Documentation section entries. Likewise | |
887 | it would be nice to collate them during the render phase -- e.g. cluster | |
888 | all platform-specific things properly. | |
889 | ||
80fea865 DG |
890 | =head1 AUTHOR |
891 | ||
892 | David Golden <dagolden@cpan.org> | |
893 | ||
894 | =head1 COPYRIGHT AND LICENSE | |
895 | ||
896 | This software is copyright (c) 2010 by David Golden. | |
897 | ||
898 | This is free software; you can redistribute it and/or modify it under the same | |
899 | terms as the Perl 5 programming language system itself. | |
900 | ||
901 | =cut | |
902 |