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);
101 return $self->dispatch( $self->prompt( @choices ), $log);
109 my @choices = ( $self->review_choices, $self->action_choices );
110 $self->_iterate_commits(
112 my ($log, $i, $count) = @_;
113 say "\n### Commit @{[$i+1]} of $count ###";
115 $self->show_header($log);
116 $self->show_notes($log, 1);
118 return $self->dispatch( $self->prompt( @choices ), $log);
127 $self->_iterate_commits(
130 my $section = $self->note_section($log) or return;
131 push @{ $sections{$section} }, $self->note_delta($log);
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};
142 say join ( "\n", @{ $sections{$s} }, "" );
149 $self->_iterate_commits(
152 $self->show_header($log);
162 my $status = $self->opt('status')
163 or die "The 'status' option must be supplied for update mode\n";
165 $self->_iterate_commits(
168 my $note = $log->notes;
169 $note =~ s{^(perldelta.*\[)\w+(\].*)}{$1$status$2}ms;
170 $self->add_note( $log->id, $note );
177 sub _iterate_commits {
178 my ($self, $fcn) = @_;
179 my $type = $self->opt('type');
180 say STDERR "Scanning for $type commits since " . $self->last_tag . "...";
181 my $list = [ $self->find_commits($type) ];
183 while ( my ($i,$log) = each @$list ) {
184 redo unless $fcn->($log, $i, $count);
189 #--------------------------------------------------------------------------#
191 #--------------------------------------------------------------------------#
194 my ($self, $id, $note) = @_;
195 my @lines = split "\n", _strip_comments($note);
196 pop @lines while @lines && $lines[-1] =~ m{^\s*$};
197 my $tempfh = File::Temp->new;
199 $tempfh->printflush( join( "\n", @lines), "\n" );
200 $self->git->notes('edit', '-F', "$tempfh", $id);
203 $tempfh->printflush( "\n" );
204 # git notes won't take an empty file as input
205 system("git notes edit -F $tempfh $id");
212 my ($self, $choice, $log) = @_;
213 return unless $choice;
214 my $method = "do_$choice->{handler}";
215 return 1 unless $self->can($method); # missing methods "succeed"
216 return $self->$method($choice, $log);
220 my ($self, $text, $args) = @_;
222 my $tempfh = File::Temp->new;
223 $tempfh->printflush( $text );
224 if ( my @editor = split /\s+/, ($ENV{VISUAL} || $ENV{EDITOR}) ) {
225 push @editor, "-f" if $editor[0] =~ /^gvim/;
226 system(@editor, "$tempfh");
229 warn("No VISUAL or EDITOR defined");
232 return do { local $/; <$tempfh> };
236 my ($self, $type) = @_;
238 my @commits = $self->git->log($self->last_tag . "..HEAD");
239 $_ = Git::Wrapper::XLog->from_log($_) 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 $header = $log->short_id;
331 $header .= " " . $log->subject if length $log->subject;
332 $header .= sprintf(' (%s)', $log->author) if $log->author;
333 say colored( $header, "yellow");
338 my ($self, $log, $lf) = @_;
339 return unless my $notes = $log->notes;
340 say $lf ? "\n$notes" : $notes;
345 my ($self, @list) = @_;
346 my $line = shift @list;
348 for my $item ( @list ) {
349 if ( length( $line . $item ) > 70 ) {
351 $line = $item ne $list[-1] ? $item : "or $item";
354 $line .= $item ne $list[-1] ? ", $item" : " or $item";
357 return join("\n", @wrap, $line);
361 my ($self, $msg) = @_;
362 my $key = $self->prompt_key($msg . " (y/n?)", 'yn');
366 #--------------------------------------------------------------------------#
368 #--------------------------------------------------------------------------#
371 my ($self, $choice, $log) = @_;
372 my $note = "perldelta: Unknown [blocking]\n";
373 $self->add_note( $log->id, $note );
378 my ($self, $choice, $log) = @_;
380 say $self->get_diff($log);
386 my ($self, $choice, $log) = @_;
387 my $id = $log->short_id;
388 $self->y_n("Recommend a cherry pick of '$id' to maint?") or return;
389 my $cherrymaint = dirname($0) . "/cherrymaint";
390 system("$^X $cherrymaint --vote $id");
391 return; # false will re-prompt the same commit
395 my ($self, $choice, $log) = @_;
396 my $note = $log->notes;
397 $note =~ s{^(perldelta.*\[)\w+(\].*)}{$1done$2}ms;
398 $self->add_note( $log->id, $note );
403 my ($self, $choice, $log) = @_;
404 my $old_note = $log->notes;
405 my $new_note = $self->edit_text( $self->note_template( $log, $old_note) );
406 $self->add_note( $log->id, $new_note );
411 my ($self, $choice, $log) = @_;
412 my $section = _strip_parens($choice->{name});
413 my $subject = $log->subject;
414 my $body = $log->body;
416 my $template = $self->note_template( $log,
417 "perldelta: $section [pending]\n\n=head2 $subject\n\n$body\n"
420 my $note = $self->edit_text( $template );
421 if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
422 $self->add_note( $log->id, $note );
429 my ($self, $choice, $log) = @_;
430 my $section = _strip_parens($choice->{name});
431 my $subject = $log->subject;
432 my $body = $log->body;
434 my $template = $self->note_template( $log,
435 "perldelta: $section [pending]\n\n=head3 L<LINK>\n\n=over\n\n=item *\n\n$subject\n\n$body\n\n=back\n"
438 my $note = $self->edit_text($template);
439 if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
440 $self->add_note( $log->id, $note );
447 my ($self, $choice, $log) = @_;
448 my $section = _strip_parens($choice->{name});
449 my $subject = $log->subject;
450 my $body = $log->body;
452 my $template = $self->note_template( $log,
453 "perldelta: $section [pending]\n\n=item *\n\n$subject\n\n$body\n"
456 my $note = $self->edit_text($template);
457 if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
458 $self->add_note( $log->id, $note );
465 my ($self, $choice, $log) = @_;
466 my $note = "perldelta: None [ignored]\n";
467 $self->add_note( $log->id, $note );
472 my ($self, $choice, $log) = @_;
473 my $section = _strip_parens($choice->{name});
474 my $subject = $log->subject;
475 my $body = $log->body;
477 my $template = $self->note_template( $log,
478 "perldelta: $section [pending]\n\n=item PLATFORM-NAME\n\n$subject\n\n$body\n"
481 my $note = $self->edit_text($template);
482 if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
483 $self->add_note( $log->id, $note );
489 sub do_quit { exit 0 }
491 sub do_repeat { return 0 }
493 sub do_skip { return 1 }
496 my ($self, $choice, $log) = @_;
497 my $section = _strip_parens($choice->{name});
498 my $subject = $log->subject;
499 my $body = $log->body;
501 my $template = $self->note_template( $log, << "HERE" );
502 perldelta: $section [pending]
509 my $note = $self->edit_text( $template );
510 if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
511 $self->add_note( $log->id, $note );
518 my ($self, $choice, $log) = @_;
519 my @choices = ( $choice->{subsection}, $self->submenu_choices );
520 say "For " . _strip_parens($choice->{name}) . ":";
521 return $self->dispatch( $self->prompt( @choices ), $log);
524 #--------------------------------------------------------------------------#
526 #--------------------------------------------------------------------------#
530 state $action_choices = [
531 { name => 'E(x)amine', handler => 'examine' },
532 { name => '(+)Cherrymaint', handler => 'cherry' },
533 { name => '(?)NeedHelp', handler => 'blocking' },
534 { name => 'S(k)ip', handler => 'skip' },
535 { name => '(Q)uit', handler => 'quit' },
537 return $action_choices;
540 sub submenu_choices {
542 state $submenu_choices = [
543 { name => '(B)ack', handler => 'repeat' },
545 return $submenu_choices;
551 state $action_choices = [
552 { name => '(E)dit', handler => 'edit' },
553 { name => '(I)gnore', handler => 'none' },
554 { name => '(D)one', handler => 'done' },
556 return $action_choices;
559 sub section_choices {
560 my ($self, $key) = @_;
561 state $section_choices = [
562 # Headline stuff that should go first
564 name => 'Core (E)nhancements',
568 name => 'Securit(y)',
572 name => '(I)ncompatible Changes',
576 name => 'Dep(r)ecations',
580 name => '(P)erformance Enhancements',
584 # Details on things installed with Perl (for Perl developers)
586 name => '(M)odules and Pragmata',
587 handler => 'subsection',
590 name => '(N)ew Modules and Pragmata',
594 name => '(U)pdated Modules and Pragmata',
598 name => '(R)emoved Modules and Pragmata',
604 name => '(D)ocumentation',
605 handler => 'subsection',
608 name => '(N)ew Documentation',
609 handler => 'linked_item',
612 name => '(C)hanges to Existing Documentation',
613 handler => 'linked_item',
618 name => 'Dia(g)nostics',
619 handler => 'subsection',
622 name => '(N)ew Diagnostics',
626 name => '(C)hanges to Existing Diagnostics',
632 name => '(U)tilities',
633 handler => 'linked_item',
636 # Details on building/testing Perl (for porters and packagers)
638 name => '(C)onfiguration and Compilation',
642 name => '(T)esting', # new tests or significant notes about it
646 name => 'Pl(a)tform Support',
647 handler => 'subsection',
650 name => '(N)ew Platforms',
651 handler => 'platform',
654 name => '(D)iscontinued Platforms',
655 handler => 'platform',
658 name => '(P)latform-Specific Notes',
659 handler => 'platform',
664 # Details on perl internals (for porters and XS developers)
666 name => 'Inter(n)al Changes',
670 # Bugs fixed and related stuff
672 name => 'Selected Bug (F)ixes',
676 name => 'Known Prob(l)ems',
680 # dummy options for special handling
683 handler => 'special',
690 return $section_choices;
697 for my $c ( @{ $self->section_choices } ) {
698 if ( $c->{subsection} ) {
699 push @order, map { $_->{name} } @{$c->{subsection}};
702 push @order, $c->{name};
709 #--------------------------------------------------------------------------#
711 #--------------------------------------------------------------------------#
713 sub get_pager { $ENV{'PAGER'} || `which less` || `which more` }
715 sub in_pager { shift->original_stdout ? 1 : 0 }
720 if (!$self->in_pager) {
721 local $ENV{'LESS'} ||= '-FXe';
723 $ENV{'MORE'} ||= '-FXe' unless $^O =~ /^MSWin/;
725 my $pager = $self->get_pager;
726 return unless $pager;
727 open (my $cmd, "|-", $pager) || return;
729 $self->original_stdout(*STDOUT);
731 # $pager will be closed once we restore STDOUT to $original_stdout
738 return unless ($self->in_pager);
739 *STDOUT = $self->original_stdout;
742 $self->original_stdout(undef);
745 #--------------------------------------------------------------------------#
747 #--------------------------------------------------------------------------#
755 sub _prepend_comment {
757 return join ("\n", map { s/^/# /g; $_ } split "\n", $text);
760 sub _strip_comments {
762 return join ("\n", grep { ! /^#/ } split "\n", $text);
765 #--------------------------------------------------------------------------#
766 # Extend Git::Wrapper::Log
767 #--------------------------------------------------------------------------#
769 package Git::Wrapper::XLog;
770 BEGIN { our @ISA = qw/Git::Wrapper::Log/; }
772 sub subject { shift->attr->{subject} }
773 sub body { shift->attr->{body} }
774 sub short_id { shift->attr->{short_id} }
775 sub author { shift->attr->{author} }
778 my ($class, $log) = @_;
780 my $msg = $log->message;
781 my ($subject, $body) = $msg =~ m{^([^\n]+)\n*(.*)}ms;
784 $body =~ s/[\r\n]*\z//ms;
786 my ($short) = Git::Wrapper->new(".")->rev_parse({short => 1}, $log->id);
788 $log->attr->{subject} = $subject;
789 $log->attr->{body} = $body;
790 $log->attr->{short_id} = $short;
791 return bless $log, $class;
796 my @notes = eval { Git::Wrapper->new(".")->notes('show', $self->id) };
797 pop @notes while @notes && $notes[-1] =~ m{^\s*$};
798 return unless @notes;
799 return join ("\n", @notes);
806 git-deltatool - Annotate commits for perldelta
810 # annotate commits back to last 'git describe' tag
816 $ git-deltatool --mode review
818 # review commits needing help
820 $ git-deltatool --mode review --type blocking
822 # summarize commits needing help
824 $ git-deltatool --mode summary --type blocking
826 # assemble annotations by section to STDOUT
828 $ git-deltatool --mode render
830 # Get a list of commits needing further review, e.g. for peer review
832 $ git-deltatool --mode summary --type blocking
834 # mark 'pending' annotations as 'done' (i.e. added to perldelta)
836 $ git-deltatool --mode update --type pending --status done
842 =item B<--mode>|B<-m> MODE
844 Indicates the run mode for the program. The default is 'assign' which
845 assigns categories and marks the notes as 'pending' (or 'ignored'). Other
846 modes are 'review', 'render', 'summary' and 'update'.
848 =item B<--type>|B<-t> TYPE
850 Indicates what types of commits to process. The default for 'assign' mode is
851 'new', which processes commits without any perldelta notes. The default for
852 'review', 'summary' and 'render' modes is 'pending'. The options must be set
853 explicitly for 'update' mode.
855 The type 'blocking' is reserved for commits needing further review.
857 =item B<--status>|B<-s> STATUS
859 For 'update' mode only, sets a new status. While there is no restriction,
860 it should be one of 'new', 'pending', 'blocking', 'ignored' or 'done'.
862 =item B<--since> REVISION
864 Defines the boundary for searching git commits. Defaults to the last
865 major tag (as would be given by 'git describe').
875 It would be nice to make some of the structured sections smarter -- e.g.
876 look at changed files in pod/* for Documentation section entries. Likewise
877 it would be nice to collate them during the render phase -- e.g. cluster
878 all platform-specific things properly.
882 David Golden <dagolden@cpan.org>
884 =head1 COPYRIGHT AND LICENSE
886 This software is copyright (c) 2010 by David Golden.
888 This is free software; you can redistribute it and/or modify it under the same
889 terms as the Perl 5 programming language system itself.