Add a tool for writing a perldelta using git notes

I've written this tool to help me annotate commits for perldelta.
It scans back through commits, prompting for a perldelta section
for each commit (or to ignore the commit).  It then opens up an
editor to write a perldelta snippet into a git note on the commit.

It also supports some very primative workflow, including reviewing
existing annotations and "rendering" annotations properly grouped
by section to cut/paste into perldelta.

It does have some non-core dependencies including Git::Wrapper and
Term::ReadKey, so is intended to be run using an installed perl with
these module from CPAN, not the freshly built one.

Documentation is sparse.

N.B. Git notes are *local* -- they are kept in a detached branch and
will not be pushed upstream.  This makes them well-suited for a
release manager to keep working notes (as for perldelta) that will
become irrelevant over time.  It's not clear whether they have broader
utility.

1 files changed, 732 insertions, 0 deletions

diff --git a/Porting/git-deltatool b/Porting/git-deltatool
new file mode 100755
index 0000000000..db4696ad0c
--- /dev/null
+++ b/Porting/git-deltatool
@@ -0,0 +1,732 @@
+#!/usr/bin/perl
+#
+# This is a rough draft of a tool to aid in generating a perldelta file
+# from a series of git commits.
+
+use 5.010;
+use strict;
+use warnings;
+package Git::DeltaTool;
+
+use Class::Struct;
+use File::Temp;
+use Getopt::Long;
+use Git::Wrapper;
+use Term::ReadKey;
+use Term::ANSIColor;
+
+BEGIN { struct( git => '$', last_tag => '$', opt => '%' ) }
+
+__PACKAGE__->run;
+
+#--------------------------------------------------------------------------#
+# main program
+#--------------------------------------------------------------------------#
+
+sub run {
+  my $class = shift;
+
+  my %opt = (
+    mode => 'assign',
+  );
+
+  GetOptions( \%opt,
+    # inputs
+    'mode|m:s', # 'assign', 'review', 'render', 'update'
+    'type|t:s', # select by status
+    'status|s:s', # status to set for 'update'
+    'since:s', # origin commit
+  );
+
+  my $git = Git::Wrapper->new(".");
+  my $git_id = $opt{since};
+  if ( defined $git_id ) {
+    die "Invalid git identifier '$git_id'\n"
+      unless eval { $git->show($git_id); 1 };
+  } else {
+    ($git_id) = $git->describe;
+    $git_id =~ s/-.*$//;
+  }
+  my $gdt = $class->new( git => $git, last_tag => $git_id, opt => \%opt );
+
+  if ( $opt{mode} eq 'assign' ) {
+    $opt{type} //= 'new';
+    $gdt->assign;
+  }
+  elsif ( $opt{mode} eq 'review' ) {
+    $opt{type} //= 'pending';
+    $gdt->review;
+  }
+  elsif ( $opt{mode} eq 'render' ) {
+    $opt{type} //= 'pending';
+    $gdt->render;
+  }
+  elsif ( $opt{mode} eq 'update' ) {
+    die "Explicit --type argument required for update mode\n"
+      unless defined $opt{type};
+    die "Explicit --status argument requrid for update mode\n"
+      unless defined $opt{status};
+    $gdt->update;
+  }
+  else {
+    die "Unrecognized mode '$opt{mode}'\n";
+  }
+  exit 0;
+}
+
+#--------------------------------------------------------------------------#
+# program modes (and iterator)
+#--------------------------------------------------------------------------#
+
+sub assign {
+  my ($self) = @_;
+  my @choices = ( $self->section_choices, $self->action_choices );
+  $self->_iterate_commits(
+    sub {
+      my $log = shift;
+      say "-" x 75;
+      $self->show_header($log);
+      $self->show_body($log, 1);
+      say "-" x 75;
+      return $self->dispatch( $self->prompt( @choices ), $log);
+    }
+  );
+  return;
+}
+
+sub review {
+  my ($self) = @_;
+  my @choices = ( $self->review_choices, $self->action_choices );
+  $self->_iterate_commits(
+    sub {
+      my $log = shift;
+      say "-" x 75;
+      $self->show_header($log);
+      $self->show_body($log, 1);
+      $self->show_notes($log, 1);
+      say "-" x 75;
+      return $self->dispatch( $self->prompt( @choices ), $log);
+    }
+  );
+  return;
+}
+
+sub render {
+  my ($self) = @_;
+  my %sections;
+  $self->_iterate_commits(
+    sub {
+      my $log = shift;
+      my $section = $self->note_section($log) or return;
+      push @{ $sections{$section} }, $self->note_delta($log);
+      return 1;
+    }
+  );
+  my @order = $self->section_order;
+  my %known = map { $_ => 1 } @order;
+  my @rest = grep { ! $known{$_} } keys %sections;
+  for my $s ( @order, @rest ) {
+    next unless ref $sections{$s};
+    say "-"x75;
+    say uc($s) . "\n";
+    say join ( "\n", @{ $sections{$s} }, "" );
+  }
+  return;
+}
+
+sub update {
+  my ($self) = @_;
+
+  my $status = $self->opt('status')
+    or die "The 'status' option must be supplied for update mode\n";
+
+  $self->_iterate_commits(
+    sub {
+      my $log = shift;
+      my $note = $log->notes;
+      $note =~ s{^(perldelta.*\[)\w+(\].*)}{$1$status$2}ms;
+      $self->add_note( $log->id, $note );
+      return 1;
+    }
+  );
+  return;
+}
+
+sub _iterate_commits {
+  my ($self, $fcn) = @_;
+  my $type = $self->opt('type');
+  say "Scanning for $type commits since " . $self->last_tag . "...";
+  for my $log ( $self->find_commits($type) ) {
+    redo unless $fcn->($log);
+  }
+  return 1;
+}
+
+#--------------------------------------------------------------------------#
+# methods
+#--------------------------------------------------------------------------#
+
+sub add_note {
+  my ($self, $id, $note) = @_;
+  my @lines = split "\n", $note;
+  pop @lines while @lines && $lines[-1] =~ m{^\s*$};
+  my $tempfh = File::Temp->new;
+  if (@lines) {
+    $tempfh->printflush( join( "\n", @lines), "\n" );
+    $self->git->notes('edit', '-F', "$tempfh", $id);
+  }
+  else {
+    $tempfh->printflush( "\n" );
+    # git notes won't take an empty file as input
+    system("git notes edit -F $tempfh $id");
+  }
+
+  return;
+}
+
+sub dispatch {
+  my ($self, $choice, $log) = @_;
+  return unless $choice;
+  my $method = "do_$choice->{handler}";
+  return 1 unless $self->can($method); # missing methods "succeed"
+  return $self->$method($choice, $log);
+}
+
+sub edit_text {
+  my ($self, $text, $args) = @_;
+  $args //= {};
+  my $tempfh = File::Temp->new;
+  $tempfh->printflush( $text );
+  if ( my (@editor) = $ENV{VISUAL} || $ENV{EDITOR} ) {
+    push @editor, "-f" if $editor[0] =~ /^gvim/;
+    system(@editor, "$tempfh");
+  }
+  else {
+    warn("No VISUAL or EDITOR defined");
+  }
+  $tempfh->seek(0,0);
+  return do { local $/; <$tempfh> };
+}
+
+sub find_commits {
+  my ($self, $type) = @_;
+  $type //= 'new';
+  my @commits = $self->git->log($self->last_tag . "..HEAD");
+  $_ = Git::Wrapper::XLog->from_log($_) for @commits;
+  my @list;
+  if ( $type eq 'new' ) {
+    @list = grep { ! $_->notes } @commits;
+  }
+  else {
+    @list = grep { $self->note_status( $_ ) eq $type } @commits;
+  }
+  return @list;
+}
+
+sub get_diff {
+  my ($self, $log) = @_;
+  my @diff = $self->git->show({ stat => 1, p => 1 }, $log->id);
+  return join("\n", @diff);
+}
+
+sub note_delta {
+  my ($self, $log) = @_;
+  my @delta = split "\n", ($log->notes || '');
+  return '' unless @delta;
+  splice @delta, 0, 2;
+  return join( "\n", @delta, "" );
+}
+
+sub note_section {
+  my ($self, $log) = @_;
+  my $note = $log->notes or return '';
+  my ($section) = $note =~ m{^perldelta:\s*([^\[]*)\s+}ms;
+  return $section || '';
+}
+
+sub note_status {
+  my ($self, $log) = @_;
+  my $note = $log->notes or return '';
+  my ($status) = $note =~ m{^perldelta:\s*[^\[]*\[(\w+)\]}ms;
+  return $status || '';
+}
+
+sub note_template {
+  my ($self, $log, $text) = @_;
+  my $diff = _prepend_comment( $self->get_diff($log) );
+  return << "HERE";
+# Edit commit note below. Do not change the first line. Comments are stripped
+$text
+
+$diff
+HERE
+}
+
+sub prompt {
+  my ($self, @choices) = @_;
+  my ($valid, @menu, %keymap) = '';
+  for my $c ( map { @$_ } @choices ) {
+    my ($item) = grep { /\(/ } split q{ }, $c->{name};
+    my ($button) = $item =~ m{\((.)\)};
+    die "No key shortcut found for '$item'" unless $button;
+    die "Duplicate key shortcut found for '$item'" if $keymap{lc $button};
+    push @menu, $item;
+    $valid .= lc $button;
+    $keymap{lc $button} = $c;
+  }
+  my $keypress = $self->prompt_key( $self->wrap_list(@menu), $valid );
+  return $keymap{lc $keypress};
+}
+
+sub prompt_key {
+  my ($self, $prompt, $valid_keys) = @_;
+  my $key;
+  KEY: {
+    say $prompt;
+    ReadMode 3;
+    $key = lc ReadKey(0);
+    ReadMode 0;
+    if ( $key !~ qr/\A[$valid_keys]\z/i ) {
+      say "";
+      redo KEY;
+    }
+  }
+  return $key;
+}
+
+sub show_body {
+  my ($self, $log, $lf) = @_;
+  return unless my $body = $log->body;
+  say $lf ? "\n$body" : $body;
+  return;
+}
+
+sub show_header {
+  my ($self, $log) = @_;
+  my $header = $log->short_id;
+  $header .= " " . $log->subject if length $log->subject;
+  say colored( $header, "yellow");
+  return;
+}
+
+sub show_notes {
+  my ($self, $log, $lf) = @_;
+  return unless my $notes = $log->notes;
+  say $lf ? "\n$notes" : $notes;
+  return;
+}
+
+sub wrap_list {
+  my ($self, @list) = @_;
+  my $line = shift @list;
+  my @wrap;
+  for my $item ( @list ) {
+    if ( length( $line . $item ) > 70 ) {
+      push @wrap, $line;
+      $line = $item ne $list[-1] ? $item : "or $item";
+    }
+    else {
+      $line .= $item ne $list[-1] ? ", $item" : " or $item";
+    }
+  }
+  return join("\n", @wrap, $line);
+}
+
+sub y_n {
+  my ($self, $msg) = @_;
+  my $key = $self->prompt_key($msg . " (y/n?)", 'yn');
+  return $key eq 'y';
+}
+
+#--------------------------------------------------------------------------#
+# handlers
+#--------------------------------------------------------------------------#
+
+sub do_done {
+  my ($self, $choice, $log) = @_;
+  my $note = $log->notes;
+  $note =~ s{^(perldelta.*\[)\w+(\].*)}{$1done$2}ms;
+  $self->add_note( $log->id, $note );
+  return 1;
+}
+
+sub do_edit {
+  my ($self, $choice, $log) = @_;
+  my $old_note = $log->notes;
+  my $new_note = $self->edit_text( $self->note_template( $log, $old_note) );
+  $self->add_note( $log->id, _strip_comments($new_note) );
+  return 1;
+}
+
+sub do_head2 {
+  my ($self, $choice, $log) = @_;
+  my $section = _strip_parens($choice->{name});
+  my $subject = $log->subject;
+  my $body = $log->body;
+  my $id = $log->short_id;
+
+  my $template = $self->note_template( $log,
+    "perldelta: $section [pending]\n\n=head2 $subject\n\n$body ($id)\n"
+  );
+
+  my $note = $self->edit_text( $template );
+  if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
+    $self->add_note( $log->id, _strip_comments($note) );
+    return 1;
+  }
+  return;
+}
+
+sub do_item {
+  my ($self, $choice, $log) = @_;
+  my $section = _strip_parens($choice->{name});
+  my $subject = $log->subject;
+  my $body = $log->body;
+  my $id = $log->short_id;
+
+  my $template =
+    "perldelta: $section [pending]\n\n=item *\n\n $subject ($id)\n\n$body\n";
+
+  my $note = $self->edit_text($template);
+  if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
+    $self->add_note( $log->id, $note );
+    return 1;
+  }
+  return;
+}
+
+sub do_none {
+  my ($self, $choice, $log) = @_;
+  my $note = "perldelta: None [ignored]\n";
+  $self->add_note( $log->id, $note );
+  return 1;
+}
+
+sub do_quit { exit 0 }
+
+sub do_skip { return 1 }
+
+sub do_special {
+  my ($self, $choice, $log) = @_;
+  my $section = _strip_parens($choice->{name});
+  my $subject = $log->subject;
+  my $body = $log->body;
+  my $id = $log->short_id;
+
+  my $template = $self->note_template( $log, << "HERE" );
+perldelta: $section [pending]
+
+$subject
+
+$body ($id)
+HERE
+
+  my $note = $self->edit_text( $template );
+  if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
+    $self->add_note( $log->id, _strip_comments($note) );
+    return 1;
+  }
+  return;
+}
+
+sub do_subsection {
+  my ($self, $choice, $log) = @_;
+  say "For " . _strip_parens($choice->{name}) . ":";
+  return $self->dispatch( $self->prompt( $choice->{subsection} ), $log);
+}
+
+#--------------------------------------------------------------------------#
+# define prompts
+#--------------------------------------------------------------------------#
+
+sub action_choices {
+  my ($self) = @_;
+  state $action_choices = [
+      { name => 'S(k)ip', handler => 'skip' },
+      { name => '(Q)uit', handler => 'quit' },
+  ];
+  return $action_choices;
+}
+
+sub review_choices {
+  my ($self) = @_;
+  state $action_choices = [
+      { name => '(E)dit', handler => 'edit' },
+      { name => '(I)gnore', handler => 'none' },
+      { name => '(D)one', handler => 'done' },
+  ];
+  return $action_choices;
+}
+
+sub section_choices {
+  my ($self, $key) = @_;
+  state $section_choices = [
+    # Headline stuff that should go first
+    {
+      name => 'Core (E)nhancements',
+      handler => 'head2',
+    },
+    {
+      name => 'Securit(y)',
+      handler => 'head2',
+    },
+    {
+      name => '(I)ncompatible Changes',
+      handler => 'head2',
+    },
+    {
+      name => 'Dep(r)ecations',
+      handler => 'head2',
+    },
+    {
+      name => '(P)erformance Enhancements',
+      handler => 'item',
+    },
+
+    # Details on things installed with Perl (for Perl developers)
+    {
+      name => '(M)odules and Pragmata',
+      handler => 'subsection',
+      subsection => [
+        {
+          name => '(N)ew Modules and Pragmata',
+          handler => 'item',
+        },
+        {
+          name => '(U)pdated Modules and Pragmata',
+          handler => 'item',
+        },
+        {
+          name => '(R)emoved Modules and Pragmata',
+          handler => 'item',
+        },
+      ],
+    },
+    {
+      name => '(D)ocumentation',
+      handler => 'subsection',
+      subsection => [
+        {
+          name => '(N)ew Documentation',
+          handler => 'item',
+        },
+        {
+          name => '(C)hanges to Existing Documentation',
+          handler => 'item',
+        },
+      ],
+    },
+    {
+      name => 'Dia(g)nostics',
+      handler => 'subsection',
+      subsection => [
+        {
+          name => '(N)ew Diagnostics',
+          handler => 'item',
+        },
+        {
+          name => '(C)hanges to Existing Diagnostics',
+          handler => 'item',
+        },
+      ],
+    },
+    {
+      name => '(U)tilities',
+      handler => 'item',
+    },
+
+    # Details on building/testing Perl (for porters and packagers)
+    {
+      name => '(C)onfiguration and Compilation',
+      handler => 'item',
+    },
+    {
+      name => '(T)esting', # new tests or significant notes about it
+      handler => 'item',
+    },
+    {
+      name => 'Pl(a)tform Support',
+      handler => 'subsection',
+      subsection => [
+        {
+          name => '(N)ew Platforms',
+          handler => 'item',
+        },
+        {
+          name => '(D)iscontinued Platforms',
+          handler => 'item',
+        },
+        {
+          name => '(P)latform-Specific Notes',
+          handler => 'item',
+        },
+      ],
+    },
+
+    # Details on perl internals (for porters and XS developers)
+    {
+      name => 'Inter(n)al Changes',
+      handler => 'item',
+    },
+
+    # Bugs fixed and related stuff
+    {
+      name => 'Selected Bug (F)ixes',
+      handler => 'item',
+    },
+    {
+      name => 'Known Prob(l)ems',
+      handler => 'item',
+    },
+
+    # dummy options for special handling
+    {
+      name => '(S)pecial',
+      handler => 'special',
+    },
+    {
+      name => '(*)None',
+      handler => 'none',
+    },
+  ];
+  return $section_choices;
+}
+
+sub section_order {
+  my ($self) = @_;
+  state @order;
+  if ( ! @order ) {
+    for my $c ( @{ $self->section_choices } ) {
+      if ( $c->{subsection} ) {
+        push @order, map { $_->{name} } @{$c->{subsection}};
+      }
+      else {
+        push @order, $c->{name};
+      }
+    }
+  }
+  return @order;
+}
+
+#--------------------------------------------------------------------------#
+# Utility functions
+#--------------------------------------------------------------------------#
+
+sub _strip_parens {
+  my ($name) = @_;
+  $name =~ s/[()]//g;
+  return $name;
+}
+
+sub _prepend_comment {
+  my ($text) = @_;
+  return join ("\n", map { s/^/# /g; $_ } split "\n", $text);
+}
+
+sub _strip_comments {
+  my ($text) = @_;
+  return join ("\n", grep { ! /^#/ } split "\n", $text);
+}
+
+#--------------------------------------------------------------------------#
+# Extend Git::Wrapper::Log
+#--------------------------------------------------------------------------#
+
+package Git::Wrapper::XLog;
+BEGIN { our @ISA = qw/Git::Wrapper::Log/; }
+
+sub subject { shift->attr->{subject} }
+sub body { shift->attr->{body} }
+sub short_id { shift->attr->{short_id} }
+
+sub from_log {
+  my ($class, $log) = @_;
+
+  my $msg = $log->message;
+  my ($subject, $body) = $msg =~ m{^([^\n]+)\n*(.*)}ms;
+  $subject //= '';
+  $body //= '';
+  $body =~ s/[\r\n]*\z//ms;
+
+  my ($short) = Git::Wrapper->new(".")->rev_parse({short => 1}, $log->id);
+
+  $log->attr->{subject} = $subject;
+  $log->attr->{body} = $body;
+  $log->attr->{short_id} = $short;
+  return bless $log, $class;
+}
+
+sub notes {
+  my ($self) = @_;
+  my @notes = eval { Git::Wrapper->new(".")->notes('show', $self->id) };
+  pop @notes while @notes && $notes[-1] =~ m{^\s*$};
+  return unless @notes;
+  return join ("\n", @notes);
+}
+
+__END__
+
+=head1 NAME
+
+git-deltatool.pl - Annotate commits for perldelta
+
+=head1 SYNOPSIS
+
+ # annotate commits back to last 'git describe' tag
+
+ $ git-deltatool.pl
+
+ # review annotations
+
+ $ git-deltatool.pl --mode review
+
+ # summarize annotations by section to STDOUT
+
+ $ git-deltatool.pl --mode render
+
+ # mark 'pending' annotations as 'done' (i.e. added to perldelta)
+
+ $ git-deltatool.pl --mode update --type pending --status done
+
+=head1 OPTIONS
+
+=over
+
+=item B<--mode>|B<-m> MODE
+
+Indicates the run mode for the program.  The default is 'assign' which
+assigns categories and marks the notes as 'pending' (or 'ignored').  Other
+modes are 'review', 'render' and 'update'.
+
+=item B<--type>|B<-t> TYPE
+
+Indicates what types of commits to process.  The default for 'assign' mode
+is 'new', which processes commits without any perldelta notes.  The
+default for 'review' and 'render' modes is 'pending'.  The options
+must be set explicitly for 'update' mode.
+
+=item B<--status>|B<-s> STATUS
+
+For 'update' mode only, sets a new status.  While there is no restriction,
+it should be one of 'new', 'pending', 'ignored' or 'done'.
+
+=item B<--since> REVISION
+
+Defines the boundary for searching git commits.  Defaults to the last
+major tag (as would be given by 'git describe').
+
+=back
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden.
+
+This is free software; you can redistribute it and/or modify it under the same
+terms as the Perl 5 programming language system itself.
+
+=cut
+