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