This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
db4696ad0c95a8313d427fc6c33a11daea4d9cdc
[perl5.git] / 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::Temp;
13 use Getopt::Long;
14 use Git::Wrapper;
15 use Term::ReadKey;
16 use Term::ANSIColor;
17
18 BEGIN { struct( git => '$', last_tag => '$', opt => '%' ) }
19
20 __PACKAGE__->run;
21
22 #--------------------------------------------------------------------------#
23 # main program
24 #--------------------------------------------------------------------------#
25
26 sub run {
27   my $class = shift;
28
29   my %opt = (
30     mode => 'assign',
31   );
32
33   GetOptions( \%opt,
34     # inputs
35     'mode|m:s', # 'assign', 'review', 'render', 'update'
36     'type|t:s', # select by status
37     'status|s:s', # status to set for 'update'
38     'since:s', # origin commit
39   );
40
41   my $git = Git::Wrapper->new(".");
42   my $git_id = $opt{since};
43   if ( defined $git_id ) {
44     die "Invalid git identifier '$git_id'\n"
45       unless eval { $git->show($git_id); 1 };
46   } else {
47     ($git_id) = $git->describe;
48     $git_id =~ s/-.*$//;
49   }
50   my $gdt = $class->new( git => $git, last_tag => $git_id, opt => \%opt );
51
52   if ( $opt{mode} eq 'assign' ) {
53     $opt{type} //= 'new';
54     $gdt->assign;
55   }
56   elsif ( $opt{mode} eq 'review' ) {
57     $opt{type} //= 'pending';
58     $gdt->review;
59   }
60   elsif ( $opt{mode} eq 'render' ) {
61     $opt{type} //= 'pending';
62     $gdt->render;
63   }
64   elsif ( $opt{mode} eq 'update' ) {
65     die "Explicit --type argument required for update mode\n"
66       unless defined $opt{type};
67     die "Explicit --status argument requrid for update mode\n"
68       unless defined $opt{status};
69     $gdt->update;
70   }
71   else {
72     die "Unrecognized mode '$opt{mode}'\n";
73   }
74   exit 0;
75 }
76
77 #--------------------------------------------------------------------------#
78 # program modes (and iterator)
79 #--------------------------------------------------------------------------#
80
81 sub assign {
82   my ($self) = @_;
83   my @choices = ( $self->section_choices, $self->action_choices );
84   $self->_iterate_commits(
85     sub {
86       my $log = shift;
87       say "-" x 75;
88       $self->show_header($log);
89       $self->show_body($log, 1);
90       say "-" x 75;
91       return $self->dispatch( $self->prompt( @choices ), $log);
92     }
93   );
94   return;
95 }
96
97 sub review {
98   my ($self) = @_;
99   my @choices = ( $self->review_choices, $self->action_choices );
100   $self->_iterate_commits(
101     sub {
102       my $log = shift;
103       say "-" x 75;
104       $self->show_header($log);
105       $self->show_body($log, 1);
106       $self->show_notes($log, 1);
107       say "-" x 75;
108       return $self->dispatch( $self->prompt( @choices ), $log);
109     }
110   );
111   return;
112 }
113
114 sub render {
115   my ($self) = @_;
116   my %sections;
117   $self->_iterate_commits(
118     sub {
119       my $log = shift;
120       my $section = $self->note_section($log) or return;
121       push @{ $sections{$section} }, $self->note_delta($log);
122       return 1;
123     }
124   );
125   my @order = $self->section_order;
126   my %known = map { $_ => 1 } @order;
127   my @rest = grep { ! $known{$_} } keys %sections;
128   for my $s ( @order, @rest ) {
129     next unless ref $sections{$s};
130     say "-"x75;
131     say uc($s) . "\n";
132     say join ( "\n", @{ $sections{$s} }, "" );
133   }
134   return;
135 }
136
137 sub update {
138   my ($self) = @_;
139
140   my $status = $self->opt('status')
141     or die "The 'status' option must be supplied for update mode\n";
142
143   $self->_iterate_commits(
144     sub {
145       my $log = shift;
146       my $note = $log->notes;
147       $note =~ s{^(perldelta.*\[)\w+(\].*)}{$1$status$2}ms;
148       $self->add_note( $log->id, $note );
149       return 1;
150     }
151   );
152   return;
153 }
154
155 sub _iterate_commits {
156   my ($self, $fcn) = @_;
157   my $type = $self->opt('type');
158   say "Scanning for $type commits since " . $self->last_tag . "...";
159   for my $log ( $self->find_commits($type) ) {
160     redo unless $fcn->($log);
161   }
162   return 1;
163 }
164
165 #--------------------------------------------------------------------------#
166 # methods
167 #--------------------------------------------------------------------------#
168
169 sub add_note {
170   my ($self, $id, $note) = @_;
171   my @lines = split "\n", $note;
172   pop @lines while @lines && $lines[-1] =~ m{^\s*$};
173   my $tempfh = File::Temp->new;
174   if (@lines) {
175     $tempfh->printflush( join( "\n", @lines), "\n" );
176     $self->git->notes('edit', '-F', "$tempfh", $id);
177   }
178   else {
179     $tempfh->printflush( "\n" );
180     # git notes won't take an empty file as input
181     system("git notes edit -F $tempfh $id");
182   }
183
184   return;
185 }
186
187 sub dispatch {
188   my ($self, $choice, $log) = @_;
189   return unless $choice;
190   my $method = "do_$choice->{handler}";
191   return 1 unless $self->can($method); # missing methods "succeed"
192   return $self->$method($choice, $log);
193 }
194
195 sub edit_text {
196   my ($self, $text, $args) = @_;
197   $args //= {};
198   my $tempfh = File::Temp->new;
199   $tempfh->printflush( $text );
200   if ( my (@editor) = $ENV{VISUAL} || $ENV{EDITOR} ) {
201     push @editor, "-f" if $editor[0] =~ /^gvim/;
202     system(@editor, "$tempfh");
203   }
204   else {
205     warn("No VISUAL or EDITOR defined");
206   }
207   $tempfh->seek(0,0);
208   return do { local $/; <$tempfh> };
209 }
210
211 sub find_commits {
212   my ($self, $type) = @_;
213   $type //= 'new';
214   my @commits = $self->git->log($self->last_tag . "..HEAD");
215   $_ = Git::Wrapper::XLog->from_log($_) for @commits;
216   my @list;
217   if ( $type eq 'new' ) {
218     @list = grep { ! $_->notes } @commits;
219   }
220   else {
221     @list = grep { $self->note_status( $_ ) eq $type } @commits;
222   }
223   return @list;
224 }
225
226 sub get_diff {
227   my ($self, $log) = @_;
228   my @diff = $self->git->show({ stat => 1, p => 1 }, $log->id);
229   return join("\n", @diff);
230 }
231
232 sub note_delta {
233   my ($self, $log) = @_;
234   my @delta = split "\n", ($log->notes || '');
235   return '' unless @delta;
236   splice @delta, 0, 2;
237   return join( "\n", @delta, "" );
238 }
239
240 sub note_section {
241   my ($self, $log) = @_;
242   my $note = $log->notes or return '';
243   my ($section) = $note =~ m{^perldelta:\s*([^\[]*)\s+}ms;
244   return $section || '';
245 }
246
247 sub note_status {
248   my ($self, $log) = @_;
249   my $note = $log->notes or return '';
250   my ($status) = $note =~ m{^perldelta:\s*[^\[]*\[(\w+)\]}ms;
251   return $status || '';
252 }
253
254 sub note_template {
255   my ($self, $log, $text) = @_;
256   my $diff = _prepend_comment( $self->get_diff($log) );
257   return << "HERE";
258 # Edit commit note below. Do not change the first line. Comments are stripped
259 $text
260
261 $diff
262 HERE
263 }
264
265 sub prompt {
266   my ($self, @choices) = @_;
267   my ($valid, @menu, %keymap) = '';
268   for my $c ( map { @$_ } @choices ) {
269     my ($item) = grep { /\(/ } split q{ }, $c->{name};
270     my ($button) = $item =~ m{\((.)\)};
271     die "No key shortcut found for '$item'" unless $button;
272     die "Duplicate key shortcut found for '$item'" if $keymap{lc $button};
273     push @menu, $item;
274     $valid .= lc $button;
275     $keymap{lc $button} = $c;
276   }
277   my $keypress = $self->prompt_key( $self->wrap_list(@menu), $valid );
278   return $keymap{lc $keypress};
279 }
280
281 sub prompt_key {
282   my ($self, $prompt, $valid_keys) = @_;
283   my $key;
284   KEY: {
285     say $prompt;
286     ReadMode 3;
287     $key = lc ReadKey(0);
288     ReadMode 0;
289     if ( $key !~ qr/\A[$valid_keys]\z/i ) {
290       say "";
291       redo KEY;
292     }
293   }
294   return $key;
295 }
296
297 sub show_body {
298   my ($self, $log, $lf) = @_;
299   return unless my $body = $log->body;
300   say $lf ? "\n$body" : $body;
301   return;
302 }
303
304 sub show_header {
305   my ($self, $log) = @_;
306   my $header = $log->short_id;
307   $header .= " " . $log->subject if length $log->subject;
308   say colored( $header, "yellow");
309   return;
310 }
311
312 sub show_notes {
313   my ($self, $log, $lf) = @_;
314   return unless my $notes = $log->notes;
315   say $lf ? "\n$notes" : $notes;
316   return;
317 }
318
319 sub wrap_list {
320   my ($self, @list) = @_;
321   my $line = shift @list;
322   my @wrap;
323   for my $item ( @list ) {
324     if ( length( $line . $item ) > 70 ) {
325       push @wrap, $line;
326       $line = $item ne $list[-1] ? $item : "or $item";
327     }
328     else {
329       $line .= $item ne $list[-1] ? ", $item" : " or $item";
330     }
331   }
332   return join("\n", @wrap, $line);
333 }
334
335 sub y_n {
336   my ($self, $msg) = @_;
337   my $key = $self->prompt_key($msg . " (y/n?)", 'yn');
338   return $key eq 'y';
339 }
340
341 #--------------------------------------------------------------------------#
342 # handlers
343 #--------------------------------------------------------------------------#
344
345 sub do_done {
346   my ($self, $choice, $log) = @_;
347   my $note = $log->notes;
348   $note =~ s{^(perldelta.*\[)\w+(\].*)}{$1done$2}ms;
349   $self->add_note( $log->id, $note );
350   return 1;
351 }
352
353 sub do_edit {
354   my ($self, $choice, $log) = @_;
355   my $old_note = $log->notes;
356   my $new_note = $self->edit_text( $self->note_template( $log, $old_note) );
357   $self->add_note( $log->id, _strip_comments($new_note) );
358   return 1;
359 }
360
361 sub do_head2 {
362   my ($self, $choice, $log) = @_;
363   my $section = _strip_parens($choice->{name});
364   my $subject = $log->subject;
365   my $body = $log->body;
366   my $id = $log->short_id;
367
368   my $template = $self->note_template( $log,
369     "perldelta: $section [pending]\n\n=head2 $subject\n\n$body ($id)\n"
370   );
371
372   my $note = $self->edit_text( $template );
373   if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
374     $self->add_note( $log->id, _strip_comments($note) );
375     return 1;
376   }
377   return;
378 }
379
380 sub do_item {
381   my ($self, $choice, $log) = @_;
382   my $section = _strip_parens($choice->{name});
383   my $subject = $log->subject;
384   my $body = $log->body;
385   my $id = $log->short_id;
386
387   my $template =
388     "perldelta: $section [pending]\n\n=item *\n\n $subject ($id)\n\n$body\n";
389
390   my $note = $self->edit_text($template);
391   if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
392     $self->add_note( $log->id, $note );
393     return 1;
394   }
395   return;
396 }
397
398 sub do_none {
399   my ($self, $choice, $log) = @_;
400   my $note = "perldelta: None [ignored]\n";
401   $self->add_note( $log->id, $note );
402   return 1;
403 }
404
405 sub do_quit { exit 0 }
406
407 sub do_skip { return 1 }
408
409 sub do_special {
410   my ($self, $choice, $log) = @_;
411   my $section = _strip_parens($choice->{name});
412   my $subject = $log->subject;
413   my $body = $log->body;
414   my $id = $log->short_id;
415
416   my $template = $self->note_template( $log, << "HERE" );
417 perldelta: $section [pending]
418
419 $subject
420
421 $body ($id)
422 HERE
423
424   my $note = $self->edit_text( $template );
425   if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
426     $self->add_note( $log->id, _strip_comments($note) );
427     return 1;
428   }
429   return;
430 }
431
432 sub do_subsection {
433   my ($self, $choice, $log) = @_;
434   say "For " . _strip_parens($choice->{name}) . ":";
435   return $self->dispatch( $self->prompt( $choice->{subsection} ), $log);
436 }
437
438 #--------------------------------------------------------------------------#
439 # define prompts
440 #--------------------------------------------------------------------------#
441
442 sub action_choices {
443   my ($self) = @_;
444   state $action_choices = [
445       { name => 'S(k)ip', handler => 'skip' },
446       { name => '(Q)uit', handler => 'quit' },
447   ];
448   return $action_choices;
449 }
450
451 sub review_choices {
452   my ($self) = @_;
453   state $action_choices = [
454       { name => '(E)dit', handler => 'edit' },
455       { name => '(I)gnore', handler => 'none' },
456       { name => '(D)one', handler => 'done' },
457   ];
458   return $action_choices;
459 }
460
461 sub section_choices {
462   my ($self, $key) = @_;
463   state $section_choices = [
464     # Headline stuff that should go first
465     {
466       name => 'Core (E)nhancements',
467       handler => 'head2',
468     },
469     {
470       name => 'Securit(y)',
471       handler => 'head2',
472     },
473     {
474       name => '(I)ncompatible Changes',
475       handler => 'head2',
476     },
477     {
478       name => 'Dep(r)ecations',
479       handler => 'head2',
480     },
481     {
482       name => '(P)erformance Enhancements',
483       handler => 'item',
484     },
485
486     # Details on things installed with Perl (for Perl developers)
487     {
488       name => '(M)odules and Pragmata',
489       handler => 'subsection',
490       subsection => [
491         {
492           name => '(N)ew Modules and Pragmata',
493           handler => 'item',
494         },
495         {
496           name => '(U)pdated Modules and Pragmata',
497           handler => 'item',
498         },
499         {
500           name => '(R)emoved Modules and Pragmata',
501           handler => 'item',
502         },
503       ],
504     },
505     {
506       name => '(D)ocumentation',
507       handler => 'subsection',
508       subsection => [
509         {
510           name => '(N)ew Documentation',
511           handler => 'item',
512         },
513         {
514           name => '(C)hanges to Existing Documentation',
515           handler => 'item',
516         },
517       ],
518     },
519     {
520       name => 'Dia(g)nostics',
521       handler => 'subsection',
522       subsection => [
523         {
524           name => '(N)ew Diagnostics',
525           handler => 'item',
526         },
527         {
528           name => '(C)hanges to Existing Diagnostics',
529           handler => 'item',
530         },
531       ],
532     },
533     {
534       name => '(U)tilities',
535       handler => 'item',
536     },
537
538     # Details on building/testing Perl (for porters and packagers)
539     {
540       name => '(C)onfiguration and Compilation',
541       handler => 'item',
542     },
543     {
544       name => '(T)esting', # new tests or significant notes about it
545       handler => 'item',
546     },
547     {
548       name => 'Pl(a)tform Support',
549       handler => 'subsection',
550       subsection => [
551         {
552           name => '(N)ew Platforms',
553           handler => 'item',
554         },
555         {
556           name => '(D)iscontinued Platforms',
557           handler => 'item',
558         },
559         {
560           name => '(P)latform-Specific Notes',
561           handler => 'item',
562         },
563       ],
564     },
565
566     # Details on perl internals (for porters and XS developers)
567     {
568       name => 'Inter(n)al Changes',
569       handler => 'item',
570     },
571
572     # Bugs fixed and related stuff
573     {
574       name => 'Selected Bug (F)ixes',
575       handler => 'item',
576     },
577     {
578       name => 'Known Prob(l)ems',
579       handler => 'item',
580     },
581
582     # dummy options for special handling
583     {
584       name => '(S)pecial',
585       handler => 'special',
586     },
587     {
588       name => '(*)None',
589       handler => 'none',
590     },
591   ];
592   return $section_choices;
593 }
594
595 sub section_order {
596   my ($self) = @_;
597   state @order;
598   if ( ! @order ) {
599     for my $c ( @{ $self->section_choices } ) {
600       if ( $c->{subsection} ) {
601         push @order, map { $_->{name} } @{$c->{subsection}};
602       }
603       else {
604         push @order, $c->{name};
605       }
606     }
607   }
608   return @order;
609 }
610
611 #--------------------------------------------------------------------------#
612 # Utility functions
613 #--------------------------------------------------------------------------#
614
615 sub _strip_parens {
616   my ($name) = @_;
617   $name =~ s/[()]//g;
618   return $name;
619 }
620
621 sub _prepend_comment {
622   my ($text) = @_;
623   return join ("\n", map { s/^/# /g; $_ } split "\n", $text);
624 }
625
626 sub _strip_comments {
627   my ($text) = @_;
628   return join ("\n", grep { ! /^#/ } split "\n", $text);
629 }
630
631 #--------------------------------------------------------------------------#
632 # Extend Git::Wrapper::Log
633 #--------------------------------------------------------------------------#
634
635 package Git::Wrapper::XLog;
636 BEGIN { our @ISA = qw/Git::Wrapper::Log/; }
637
638 sub subject { shift->attr->{subject} }
639 sub body { shift->attr->{body} }
640 sub short_id { shift->attr->{short_id} }
641
642 sub from_log {
643   my ($class, $log) = @_;
644
645   my $msg = $log->message;
646   my ($subject, $body) = $msg =~ m{^([^\n]+)\n*(.*)}ms;
647   $subject //= '';
648   $body //= '';
649   $body =~ s/[\r\n]*\z//ms;
650
651   my ($short) = Git::Wrapper->new(".")->rev_parse({short => 1}, $log->id);
652
653   $log->attr->{subject} = $subject;
654   $log->attr->{body} = $body;
655   $log->attr->{short_id} = $short;
656   return bless $log, $class;
657 }
658
659 sub notes {
660   my ($self) = @_;
661   my @notes = eval { Git::Wrapper->new(".")->notes('show', $self->id) };
662   pop @notes while @notes && $notes[-1] =~ m{^\s*$};
663   return unless @notes;
664   return join ("\n", @notes);
665 }
666
667 __END__
668
669 =head1 NAME
670
671 git-deltatool.pl - Annotate commits for perldelta
672
673 =head1 SYNOPSIS
674
675  # annotate commits back to last 'git describe' tag
676
677  $ git-deltatool.pl
678
679  # review annotations
680
681  $ git-deltatool.pl --mode review
682
683  # summarize annotations by section to STDOUT
684
685  $ git-deltatool.pl --mode render
686
687  # mark 'pending' annotations as 'done' (i.e. added to perldelta)
688
689  $ git-deltatool.pl --mode update --type pending --status done
690
691 =head1 OPTIONS
692
693 =over
694
695 =item B<--mode>|B<-m> MODE
696
697 Indicates the run mode for the program.  The default is 'assign' which
698 assigns categories and marks the notes as 'pending' (or 'ignored').  Other
699 modes are 'review', 'render' and 'update'.
700
701 =item B<--type>|B<-t> TYPE
702
703 Indicates what types of commits to process.  The default for 'assign' mode
704 is 'new', which processes commits without any perldelta notes.  The
705 default for 'review' and 'render' modes is 'pending'.  The options
706 must be set explicitly for 'update' mode.
707
708 =item B<--status>|B<-s> STATUS
709
710 For 'update' mode only, sets a new status.  While there is no restriction,
711 it should be one of 'new', 'pending', 'ignored' or 'done'.
712
713 =item B<--since> REVISION
714
715 Defines the boundary for searching git commits.  Defaults to the last
716 major tag (as would be given by 'git describe').
717
718 =back
719
720 =head1 AUTHOR
721
722 David Golden <dagolden@cpan.org>
723
724 =head1 COPYRIGHT AND LICENSE
725
726 This software is copyright (c) 2010 by David Golden.
727
728 This is free software; you can redistribute it and/or modify it under the same
729 terms as the Perl 5 programming language system itself.
730
731 =cut
732