3 # This is a rough draft of a tool to aid in generating a perldelta file
4 # from a series of git commits.
9 package Git::DeltaTool;
20 BEGIN { struct( git => '$', last_tag => '$', opt => '%', original_stdout => '$' ) }
24 #--------------------------------------------------------------------------#
26 #--------------------------------------------------------------------------#
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
44 pod2usage() if $opt{help};
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 };
52 ($git_id) = $git->describe;
55 my $gdt = $class->new( git => $git, last_tag => $git_id, opt => \%opt );
57 if ( $opt{mode} eq 'assign' ) {
61 elsif ( $opt{mode} eq 'review' ) {
62 $opt{type} //= 'pending';
65 elsif ( $opt{mode} eq 'render' ) {
66 $opt{type} //= 'pending';
69 elsif ( $opt{mode} eq 'summary' ) {
70 $opt{type} //= 'pending';
73 elsif ( $opt{mode} eq 'update' ) {
74 die "Explicit --type argument required for update mode\n"
75 unless defined $opt{type};
76 die "Explicit --status argument required for update mode\n"
77 unless defined $opt{status};
81 die "Unrecognized mode '$opt{mode}'\n";
86 #--------------------------------------------------------------------------#
87 # program modes (and iterator)
88 #--------------------------------------------------------------------------#
92 my @choices = ( $self->section_choices, $self->action_choices );
93 $self->_iterate_commits(
95 my ($log, $i, $count) = @_;
96 say "\n### Commit @{[$i+1]} of $count ###";
98 $self->show_header($log);
99 $self->show_body($log, 1);
100 $self->show_files($log);
102 return $self->dispatch( $self->prompt( @choices ), $log);
110 my @choices = ( $self->review_choices, $self->action_choices );
111 $self->_iterate_commits(
113 my ($log, $i, $count) = @_;
114 say "\n### Commit @{[$i+1]} of $count ###";
116 $self->show_header($log);
117 $self->show_notes($log, 1);
119 return $self->dispatch( $self->prompt( @choices ), $log);
128 $self->_iterate_commits(
131 my $section = $self->note_section($log) or return;
132 push @{ $sections{$section} }, $self->note_delta($log);
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};
143 say join ( "\n", @{ $sections{$s} }, "" );
150 $self->_iterate_commits(
153 $self->show_header($log);
163 my $status = $self->opt('status')
164 or die "The 'status' option must be supplied for update mode\n";
166 $self->_iterate_commits(
169 my $note = $log->notes;
170 $note =~ s{^(perldelta.*\[)\w+(\].*)}{$1$status$2}ms;
171 $self->add_note( $log->id, $note );
178 sub _iterate_commits {
179 my ($self, $fcn) = @_;
180 my $type = $self->opt('type');
181 say STDERR "Scanning for $type commits since " . $self->last_tag . "...";
182 my $list = [ $self->find_commits($type) ];
184 while ( my ($i,$log) = each @$list ) {
185 redo unless $fcn->($log, $i, $count);
190 #--------------------------------------------------------------------------#
192 #--------------------------------------------------------------------------#
195 my ($self, $id, $note) = @_;
196 my @lines = split "\n", _strip_comments($note);
197 pop @lines while @lines && $lines[-1] =~ m{^\s*$};
198 my $tempfh = File::Temp->new;
200 $tempfh->printflush( join( "\n", @lines), "\n" );
201 $self->git->notes('edit', '-F', "$tempfh", $id);
204 $tempfh->printflush( "\n" );
205 # git notes won't take an empty file as input
206 system("git notes edit -F $tempfh $id");
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);
221 my ($self, $text, $args) = @_;
223 my $tempfh = File::Temp->new;
224 $tempfh->printflush( $text );
225 if ( my @editor = split /\s+/, ($ENV{VISUAL} || $ENV{EDITOR}) ) {
226 push @editor, "-f" if $editor[0] =~ /^gvim/;
227 system(@editor, "$tempfh");
230 warn("No VISUAL or EDITOR defined");
232 return do { local (@ARGV,$/) = "$tempfh"; <> };
236 my ($self, $type) = @_;
238 my @commits = $self->git->log($self->last_tag . "..HEAD");
239 $_ = Git::Wrapper::XLog->from_log($_, $self->git) for @commits;
241 if ( $type eq 'new' ) {
242 @list = grep { ! $_->notes } @commits;
245 @list = grep { $self->note_status( $_ ) eq $type } @commits;
251 my ($self, $log) = @_;
252 my @diff = $self->git->show({ stat => 1, p => 1 }, $log->id);
253 return join("\n", @diff);
257 my ($self, $log) = @_;
258 my @delta = split "\n", ($log->notes || '');
259 return '' unless @delta;
261 return join( "\n", @delta, "" );
265 my ($self, $log) = @_;
266 my $note = $log->notes or return '';
267 my ($section) = $note =~ m{^perldelta:\s*([^\[]*)\s+}ms;
268 return $section || '';
272 my ($self, $log) = @_;
273 my $note = $log->notes or return '';
274 my ($status) = $note =~ m{^perldelta:\s*[^\[]*\[(\w+)\]}ms;
275 return $status || '';
279 my ($self, $log, $text) = @_;
280 my $diff = _prepend_comment( $self->get_diff($log) );
282 # Edit commit note below. Do not change the first line. Comments are stripped
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};
298 $valid .= lc $button;
299 $keymap{lc $button} = $c;
301 my $keypress = $self->prompt_key( $self->wrap_list(@menu), $valid );
302 return $keymap{lc $keypress};
306 my ($self, $prompt, $valid_keys) = @_;
311 $key = lc ReadKey(0);
313 if ( $key !~ qr/\A[$valid_keys]\z/i ) {
322 my ($self, $log, $lf) = @_;
323 return unless my $body = $log->body;
324 say $lf ? "\n$body" : $body;
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;
334 say join("\n", map { " * $_" } sort map { /.*\s+(\S+)/; $1 } @files);
339 my ($self, $log) = @_;
340 my $header = $log->short_id;
341 $header .= " " . $log->subject if length $log->subject;
342 $header .= sprintf(' (%s)', $log->author) if $log->author;
343 say colored( $header, "yellow");
348 my ($self, $log, $lf) = @_;
349 return unless my $notes = $log->notes;
350 say $lf ? "\n$notes" : $notes;
355 my ($self, @list) = @_;
356 my $line = shift @list;
358 for my $item ( @list ) {
359 if ( length( $line . $item ) > 70 ) {
361 $line = $item ne $list[-1] ? $item : "or $item";
364 $line .= $item ne $list[-1] ? ", $item" : " or $item";
367 return join("\n", @wrap, $line);
371 my ($self, $msg) = @_;
372 my $key = $self->prompt_key($msg . " (y/n?)", 'yn');
376 #--------------------------------------------------------------------------#
378 #--------------------------------------------------------------------------#
381 my ($self, $choice, $log) = @_;
382 my $note = "perldelta: Unknown [blocking]\n";
383 $self->add_note( $log->id, $note );
388 my ($self, $choice, $log) = @_;
390 say $self->get_diff($log);
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
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 );
413 my ($self, $choice, $log) = @_;
414 my $old_note = $log->notes;
415 my $new_note = $self->edit_text( $self->note_template( $log, $old_note) );
416 $self->add_note( $log->id, $new_note );
421 my ($self, $choice, $log) = @_;
422 my $section = _strip_parens($choice->{name});
423 my $subject = $log->subject;
424 my $body = $log->body;
426 my $template = $self->note_template( $log,
427 "perldelta: $section [pending]\n\n=head2 $subject\n\n$body\n"
430 my $note = $self->edit_text( $template );
431 if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
432 $self->add_note( $log->id, $note );
439 my ($self, $choice, $log) = @_;
440 my $section = _strip_parens($choice->{name});
441 my $subject = $log->subject;
442 my $body = $log->body;
444 my $template = $self->note_template( $log,
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"
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 );
457 my ($self, $choice, $log) = @_;
458 my $section = _strip_parens($choice->{name});
459 my $subject = $log->subject;
460 my $body = $log->body;
462 my $template = $self->note_template( $log,
463 "perldelta: $section [pending]\n\n=item *\n\n$subject\n\n$body\n"
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 );
475 my ($self, $choice, $log) = @_;
476 my $note = "perldelta: None [ignored]\n";
477 $self->add_note( $log->id, $note );
482 my ($self, $choice, $log) = @_;
483 my $section = _strip_parens($choice->{name});
484 my $subject = $log->subject;
485 my $body = $log->body;
487 my $template = $self->note_template( $log,
488 "perldelta: $section [pending]\n\n=item PLATFORM-NAME\n\n$subject\n\n$body\n"
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 );
499 sub do_quit { exit 0 }
501 sub do_repeat { return 0 }
503 sub do_skip { return 1 }
506 my ($self, $choice, $log) = @_;
507 my $section = _strip_parens($choice->{name});
508 my $subject = $log->subject;
509 my $body = $log->body;
511 my $template = $self->note_template( $log, << "HERE" );
512 perldelta: $section [pending]
519 my $note = $self->edit_text( $template );
520 if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
521 $self->add_note( $log->id, $note );
528 my ($self, $choice, $log) = @_;
529 my @choices = ( $choice->{subsection}, $self->submenu_choices );
530 say "For " . _strip_parens($choice->{name}) . ":";
531 return $self->dispatch( $self->prompt( @choices ), $log);
534 #--------------------------------------------------------------------------#
536 #--------------------------------------------------------------------------#
540 state $action_choices = [
541 { name => 'E(x)amine', handler => 'examine' },
542 { name => '(+)Cherrymaint', handler => 'cherry' },
543 { name => '(?)NeedHelp', handler => 'blocking' },
544 { name => 'S(k)ip', handler => 'skip' },
545 { name => '(Q)uit', handler => 'quit' },
547 return $action_choices;
550 sub submenu_choices {
552 state $submenu_choices = [
553 { name => '(B)ack', handler => 'repeat' },
555 return $submenu_choices;
561 state $action_choices = [
562 { name => '(E)dit', handler => 'edit' },
563 { name => '(I)gnore', handler => 'none' },
564 { name => '(D)one', handler => 'done' },
566 return $action_choices;
569 sub section_choices {
570 my ($self, $key) = @_;
571 state $section_choices = [
572 # Headline stuff that should go first
574 name => 'Core (E)nhancements',
578 name => 'Securit(y)',
582 name => '(I)ncompatible Changes',
586 name => 'Dep(r)ecations',
590 name => '(P)erformance Enhancements',
594 # Details on things installed with Perl (for Perl developers)
596 name => '(M)odules and Pragmata',
597 handler => 'subsection',
600 name => '(N)ew Modules and Pragmata',
604 name => '(U)pdated Modules and Pragmata',
608 name => '(R)emoved Modules and Pragmata',
614 name => '(D)ocumentation',
615 handler => 'subsection',
618 name => '(N)ew Documentation',
619 handler => 'linked_item',
622 name => '(C)hanges to Existing Documentation',
623 handler => 'linked_item',
628 name => 'Dia(g)nostics',
629 handler => 'subsection',
632 name => '(N)ew Diagnostics',
636 name => '(C)hanges to Existing Diagnostics',
642 name => '(U)tilities',
643 handler => 'linked_item',
646 # Details on building/testing Perl (for porters and packagers)
648 name => '(C)onfiguration and Compilation',
652 name => '(T)esting', # new tests or significant notes about it
656 name => 'Pl(a)tform Support',
657 handler => 'subsection',
660 name => '(N)ew Platforms',
661 handler => 'platform',
664 name => '(D)iscontinued Platforms',
665 handler => 'platform',
668 name => '(P)latform-Specific Notes',
669 handler => 'platform',
674 # Details on perl internals (for porters and XS developers)
676 name => 'Inter(n)al Changes',
680 # Bugs fixed and related stuff
682 name => 'Selected Bug (F)ixes',
686 name => 'Known Prob(l)ems',
690 # dummy options for special handling
693 handler => 'special',
700 return $section_choices;
707 for my $c ( @{ $self->section_choices } ) {
708 if ( $c->{subsection} ) {
709 push @order, map { $_->{name} } @{$c->{subsection}};
712 push @order, $c->{name};
719 #--------------------------------------------------------------------------#
721 #--------------------------------------------------------------------------#
723 sub get_pager { $ENV{'PAGER'} || `which less` || `which more` }
725 sub in_pager { shift->original_stdout ? 1 : 0 }
730 if (!$self->in_pager) {
731 local $ENV{'LESS'} ||= '-FXe';
733 $ENV{'MORE'} ||= '-FXe' unless $^O =~ /^MSWin/;
735 my $pager = $self->get_pager;
736 return unless $pager;
737 open (my $cmd, "|-", $pager) || return;
739 $self->original_stdout(*STDOUT);
741 # $pager will be closed once we restore STDOUT to $original_stdout
748 return unless ($self->in_pager);
749 *STDOUT = $self->original_stdout;
752 $self->original_stdout(undef);
755 #--------------------------------------------------------------------------#
757 #--------------------------------------------------------------------------#
765 sub _prepend_comment {
767 return join ("\n", map { s/^/# /g; $_ } split "\n", $text);
770 sub _strip_comments {
772 return join ("\n", grep { ! /^#/ } split "\n", $text);
775 #--------------------------------------------------------------------------#
776 # Extend Git::Wrapper::Log
777 #--------------------------------------------------------------------------#
779 package Git::Wrapper::XLog;
780 BEGIN { our @ISA = qw/Git::Wrapper::Log/; }
782 sub subject { shift->attr->{subject} }
783 sub body { shift->attr->{body} }
784 sub short_id { shift->attr->{short_id} }
785 sub author { shift->attr->{author} }
788 my ($class, $log, $git) = @_;
790 my $msg = $log->message;
791 my ($subject, $body) = $msg =~ m{^([^\n]+)\n*(.*)}ms;
794 $body =~ s/[\r\n]*\z//ms;
796 my ($short) = $git->rev_parse({short => 1}, $log->id);
798 $log->attr->{subject} = $subject;
799 $log->attr->{body} = $body;
800 $log->attr->{short_id} = $short;
801 return bless $log, $class;
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);
816 git-deltatool - Annotate commits for perldelta
820 # annotate commits back to last 'git describe' tag
826 $ git-deltatool --mode review
828 # review commits needing help
830 $ git-deltatool --mode review --type blocking
832 # summarize commits needing help
834 $ git-deltatool --mode summary --type blocking
836 # assemble annotations by section to STDOUT
838 $ git-deltatool --mode render
840 # Get a list of commits needing further review, e.g. for peer review
842 $ git-deltatool --mode summary --type blocking
844 # mark 'pending' annotations as 'done' (i.e. added to perldelta)
846 $ git-deltatool --mode update --type pending --status done
852 =item B<--mode>|B<-m> MODE
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
856 modes are 'review', 'render', 'summary' and 'update'.
858 =item B<--type>|B<-t> TYPE
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
862 'review', 'summary' and 'render' modes is 'pending'. The options must be set
863 explicitly for 'update' mode.
865 The type 'blocking' is reserved for commits needing further review.
867 =item B<--status>|B<-s> STATUS
869 For 'update' mode only, sets a new status. While there is no restriction,
870 it should be one of 'new', 'pending', 'blocking', 'ignored' or 'done'.
872 =item B<--since> REVISION
874 Defines the boundary for searching git commits. Defaults to the last
875 major tag (as would be given by 'git describe').
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.
892 David Golden <dagolden@cpan.org>
894 =head1 COPYRIGHT AND LICENSE
896 This software is copyright (c) 2010 by David Golden.
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.