Porting/git-deltatool

   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;
  12 use File::Basename;
  13 use File::Temp;
  14 use Getopt::Long;
  15 use Git::Wrapper;
  16 use Term::ReadKey;
  17 use Term::ANSIColor;
  18 use Pod::Usage;
  19
  20 BEGIN { struct( git => '$', last_tag => '$', opt => '%', original_stdout => '$' ) }
  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
  41     'help|h',  # help
  42   );
  43
  44   pod2usage() if $opt{help};
  45
  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   }
  69   elsif ( $opt{mode} eq 'summary' ) {
  70     $opt{type} //= 'pending';
  71     $gdt->summary;
  72   }
  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};
  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, $i, $count) = @_;
  96       say "\n### Commit @{[$i+1]} of $count ###";
  97       say "-" x 75;
  98       $self->show_header($log);
  99       $self->show_body($log, 1);
 100       $self->show_files($log);
 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 {
 113       my ($log, $i, $count) = @_;
 114       say "\n### Commit @{[$i+1]} of $count ###";
 115       say "-" x 75;
 116       $self->show_header($log);
 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
 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
 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');
 181   say STDERR "Scanning for $type commits since " . $self->last_tag . "...";
 182   my $list = [ $self->find_commits($type) ];
 183   my $count = @$list;
 184   while ( my ($i,$log) = each @$list ) {
 185     redo unless $fcn->($log, $i, $count);
 186   }
 187   return 1;
 188 }
 189
 190 #--------------------------------------------------------------------------#
 191 # methods
 192 #--------------------------------------------------------------------------#
 193
 194 sub add_note {
 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;
 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 );
 225   if ( my @editor = split /\s+/, ($ENV{VISUAL} || $ENV{EDITOR}) ) {
 226     push @editor, "-f" if $editor[0] =~ /^gvim/;
 227     system(@editor, "$tempfh");
 228   }
 229   else {
 230     warn("No VISUAL or EDITOR defined");
 231   }
 232   return do { local (@ARGV,$/) = "$tempfh"; <> };
 233 }
 234
 235 sub find_commits {
 236   my ($self, $type) = @_;
 237   $type //= 'new';
 238   my @commits = $self->git->log($self->last_tag . "..HEAD");
 239   $_ = Git::Wrapper::XLog->from_log($_, $self->git) for @commits;
 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
 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
 338 sub show_header {
 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");
 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
 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
 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
 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
 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) );
 416   $self->add_note( $log->id, $new_note );
 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;
 425
 426   my $template = $self->note_template( $log,
 427     "perldelta: $section [pending]\n\n=head2 $subject\n\n$body\n"
 428   );
 429
 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 );
 433     return 1;
 434   }
 435   return;
 436 }
 437
 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;
 443
 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"
 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
 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;
 461
 462   my $template = $self->note_template( $log,
 463     "perldelta: $section [pending]\n\n=item *\n\n$subject\n\n$body\n"
 464   );
 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
 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;
 486
 487   my $template = $self->note_template( $log,
 488     "perldelta: $section [pending]\n\n=item PLATFORM-NAME\n\n$subject\n\n$body\n"
 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
 499 sub do_quit { exit 0 }
 500
 501 sub do_repeat { return 0 }
 502
 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;
 510
 511   my $template = $self->note_template( $log, << "HERE" );
 512 perldelta: $section [pending]
 513
 514 $subject
 515
 516 $body
 517 HERE
 518
 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 );
 522     return 1;
 523   }
 524   return;
 525 }
 526
 527 sub do_subsection {
 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);
 532 }
 533
 534 #--------------------------------------------------------------------------#
 535 # define prompts
 536 #--------------------------------------------------------------------------#
 537
 538 sub action_choices {
 539   my ($self) = @_;
 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' },
 546   ];
 547   return $action_choices;
 548 }
 549
 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
 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',
 619           handler => 'linked_item',
 620         },
 621         {
 622           name => '(C)hanges to Existing Documentation',
 623           handler => 'linked_item',
 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',
 643       handler => 'linked_item',
 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',
 661           handler => 'platform',
 662         },
 663         {
 664           name => '(D)iscontinued Platforms',
 665           handler => 'platform',
 666         },
 667         {
 668           name => '(P)latform-Specific Notes',
 669           handler => 'platform',
 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 #--------------------------------------------------------------------------#
 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 #--------------------------------------------------------------------------#
 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} }
 785 sub author { shift->attr->{author} }
 786
 787 sub from_log {
 788   my ($class, $log, $git) = @_;
 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
 796   my ($short) = $git->rev_parse({short => 1}, $log->id);
 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
 816 git-deltatool - Annotate commits for perldelta
 817
 818 =head1 SYNOPSIS
 819
 820  # annotate commits back to last 'git describe' tag
 821
 822  $ git-deltatool
 823
 824  # review annotations
 825
 826  $ git-deltatool --mode review
 827
 828  # review commits needing help
 829
 830  $ git-deltatool --mode review --type blocking
 831
 832  # summarize commits needing help
 833
 834  $ git-deltatool --mode summary --type blocking
 835
 836  # assemble annotations by section to STDOUT
 837
 838  $ git-deltatool --mode render
 839
 840  # Get a list of commits needing further review, e.g. for peer review
 841
 842  $ git-deltatool --mode summary --type blocking
 843
 844  # mark 'pending' annotations as 'done' (i.e. added to perldelta)
 845
 846  $ git-deltatool --mode update --type pending --status done
 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
 856 modes are 'review', 'render', 'summary' and 'update'.
 857
 858 =item B<--type>|B<-t> TYPE
 859
 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.
 864
 865 The type 'blocking' is reserved for commits needing further review.
 866
 867 =item B<--status>|B<-s> STATUS
 868
 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'.
 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
 877 =item B<--help>
 878
 879 Shows the manual.
 880
 881 =back
 882
 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
 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