Set default static inline for Netware/config.wc.
[perl.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::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 => '%' ) }
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 = shift;
96       say "";
97       say "-" x 75;
98       $self->show_header($log);
99       $self->show_body($log, 1);
100       say "-" x 75;
101       return $self->dispatch( $self->prompt( @choices ), $log);
102     }
103   );
104   return;
105 }
106
107 sub review {
108   my ($self) = @_;
109   my @choices = ( $self->review_choices, $self->action_choices );
110   $self->_iterate_commits(
111     sub {
112       my $log = shift;
113       say "";
114       say "-" x 75;
115       $self->show_header($log);
116       $self->show_notes($log, 1);
117       say "-" x 75;
118       return $self->dispatch( $self->prompt( @choices ), $log);
119     }
120   );
121   return;
122 }
123
124 sub render {
125   my ($self) = @_;
126   my %sections;
127   $self->_iterate_commits(
128     sub {
129       my $log = shift;
130       my $section = $self->note_section($log) or return;
131       push @{ $sections{$section} }, $self->note_delta($log);
132       return 1;
133     }
134   );
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};
140     say "-"x75;
141     say uc($s) . "\n";
142     say join ( "\n", @{ $sections{$s} }, "" );
143   }
144   return;
145 }
146
147 sub summary {
148   my ($self) = @_;
149   $self->_iterate_commits(
150     sub {
151       my $log = shift;
152       $self->show_header($log);
153       return 1;
154     }
155   );
156   return;
157 }
158
159 sub update {
160   my ($self) = @_;
161
162   my $status = $self->opt('status')
163     or die "The 'status' option must be supplied for update mode\n";
164
165   $self->_iterate_commits(
166     sub {
167       my $log = shift;
168       my $note = $log->notes;
169       $note =~ s{^(perldelta.*\[)\w+(\].*)}{$1$status$2}ms;
170       $self->add_note( $log->id, $note );
171       return 1;
172     }
173   );
174   return;
175 }
176
177 sub _iterate_commits {
178   my ($self, $fcn) = @_;
179   my $type = $self->opt('type');
180   say "Scanning for $type commits since " . $self->last_tag . "...";
181   for my $log ( $self->find_commits($type) ) {
182     redo unless $fcn->($log);
183   }
184   return 1;
185 }
186
187 #--------------------------------------------------------------------------#
188 # methods
189 #--------------------------------------------------------------------------#
190
191 sub add_note {
192   my ($self, $id, $note) = @_;
193   my @lines = split "\n", _strip_comments($note);
194   pop @lines while @lines && $lines[-1] =~ m{^\s*$};
195   my $tempfh = File::Temp->new;
196   if (@lines) {
197     $tempfh->printflush( join( "\n", @lines), "\n" );
198     $self->git->notes('edit', '-F', "$tempfh", $id);
199   }
200   else {
201     $tempfh->printflush( "\n" );
202     # git notes won't take an empty file as input
203     system("git notes edit -F $tempfh $id");
204   }
205
206   return;
207 }
208
209 sub dispatch {
210   my ($self, $choice, $log) = @_;
211   return unless $choice;
212   my $method = "do_$choice->{handler}";
213   return 1 unless $self->can($method); # missing methods "succeed"
214   return $self->$method($choice, $log);
215 }
216
217 sub edit_text {
218   my ($self, $text, $args) = @_;
219   $args //= {};
220   my $tempfh = File::Temp->new;
221   $tempfh->printflush( $text );
222   if ( my (@editor) = $ENV{VISUAL} || $ENV{EDITOR} ) {
223     push @editor, "-f" if $editor[0] =~ /^gvim/;
224     system(@editor, "$tempfh");
225   }
226   else {
227     warn("No VISUAL or EDITOR defined");
228   }
229   $tempfh->seek(0,0);
230   return do { local $/; <$tempfh> };
231 }
232
233 sub find_commits {
234   my ($self, $type) = @_;
235   $type //= 'new';
236   my @commits = $self->git->log($self->last_tag . "..HEAD");
237   $_ = Git::Wrapper::XLog->from_log($_) for @commits;
238   my @list;
239   if ( $type eq 'new' ) {
240     @list = grep { ! $_->notes } @commits;
241   }
242   else {
243     @list = grep { $self->note_status( $_ ) eq $type } @commits;
244   }
245   return @list;
246 }
247
248 sub get_diff {
249   my ($self, $log) = @_;
250   my @diff = $self->git->show({ stat => 1, p => 1 }, $log->id);
251   return join("\n", @diff);
252 }
253
254 sub note_delta {
255   my ($self, $log) = @_;
256   my @delta = split "\n", ($log->notes || '');
257   return '' unless @delta;
258   splice @delta, 0, 2;
259   return join( "\n", @delta, "" );
260 }
261
262 sub note_section {
263   my ($self, $log) = @_;
264   my $note = $log->notes or return '';
265   my ($section) = $note =~ m{^perldelta:\s*([^\[]*)\s+}ms;
266   return $section || '';
267 }
268
269 sub note_status {
270   my ($self, $log) = @_;
271   my $note = $log->notes or return '';
272   my ($status) = $note =~ m{^perldelta:\s*[^\[]*\[(\w+)\]}ms;
273   return $status || '';
274 }
275
276 sub note_template {
277   my ($self, $log, $text) = @_;
278   my $diff = _prepend_comment( $self->get_diff($log) );
279   return << "HERE";
280 # Edit commit note below. Do not change the first line. Comments are stripped
281 $text
282
283 $diff
284 HERE
285 }
286
287 sub prompt {
288   my ($self, @choices) = @_;
289   my ($valid, @menu, %keymap) = '';
290   for my $c ( map { @$_ } @choices ) {
291     my ($item) = grep { /\(/ } split q{ }, $c->{name};
292     my ($button) = $item =~ m{\((.)\)};
293     die "No key shortcut found for '$item'" unless $button;
294     die "Duplicate key shortcut found for '$item'" if $keymap{lc $button};
295     push @menu, $item;
296     $valid .= lc $button;
297     $keymap{lc $button} = $c;
298   }
299   my $keypress = $self->prompt_key( $self->wrap_list(@menu), $valid );
300   return $keymap{lc $keypress};
301 }
302
303 sub prompt_key {
304   my ($self, $prompt, $valid_keys) = @_;
305   my $key;
306   KEY: {
307     say $prompt;
308     ReadMode 3;
309     $key = lc ReadKey(0);
310     ReadMode 0;
311     if ( $key !~ qr/\A[$valid_keys]\z/i ) {
312       say "";
313       redo KEY;
314     }
315   }
316   return $key;
317 }
318
319 sub show_body {
320   my ($self, $log, $lf) = @_;
321   return unless my $body = $log->body;
322   say $lf ? "\n$body" : $body;
323   return;
324 }
325
326 sub show_header {
327   my ($self, $log) = @_;
328   my $header = $log->short_id;
329   $header .= " " . $log->subject if length $log->subject;
330   say colored( $header, "yellow");
331   return;
332 }
333
334 sub show_notes {
335   my ($self, $log, $lf) = @_;
336   return unless my $notes = $log->notes;
337   say $lf ? "\n$notes" : $notes;
338   return;
339 }
340
341 sub wrap_list {
342   my ($self, @list) = @_;
343   my $line = shift @list;
344   my @wrap;
345   for my $item ( @list ) {
346     if ( length( $line . $item ) > 70 ) {
347       push @wrap, $line;
348       $line = $item ne $list[-1] ? $item : "or $item";
349     }
350     else {
351       $line .= $item ne $list[-1] ? ", $item" : " or $item";
352     }
353   }
354   return join("\n", @wrap, $line);
355 }
356
357 sub y_n {
358   my ($self, $msg) = @_;
359   my $key = $self->prompt_key($msg . " (y/n?)", 'yn');
360   return $key eq 'y';
361 }
362
363 #--------------------------------------------------------------------------#
364 # handlers
365 #--------------------------------------------------------------------------#
366
367 sub do_blocking {
368   my ($self, $choice, $log) = @_;
369   my $note = "perldelta: Unknown [blocking]\n";
370   $self->add_note( $log->id, $note );
371   return 1;
372 }
373
374 sub do_cherry {
375   my ($self, $choice, $log) = @_;
376   my $id = $log->short_id;
377   $self->y_n("Recommend a cherry pick of '$id' to maint?") or return;
378   my $cherrymaint = dirname($0) . "/cherrymaint";
379   system("$^X $cherrymaint --vote $id");
380   return; # false will re-prompt the same commit
381 }
382
383 sub do_done {
384   my ($self, $choice, $log) = @_;
385   my $note = $log->notes;
386   $note =~ s{^(perldelta.*\[)\w+(\].*)}{$1done$2}ms;
387   $self->add_note( $log->id, $note );
388   return 1;
389 }
390
391 sub do_edit {
392   my ($self, $choice, $log) = @_;
393   my $old_note = $log->notes;
394   my $new_note = $self->edit_text( $self->note_template( $log, $old_note) );
395   $self->add_note( $log->id, $new_note );
396   return 1;
397 }
398
399 sub do_head2 {
400   my ($self, $choice, $log) = @_;
401   my $section = _strip_parens($choice->{name});
402   my $subject = $log->subject;
403   my $body = $log->body;
404   my $id = $log->short_id;
405
406   my $template = $self->note_template( $log,
407     "perldelta: $section [pending]\n\n=head2 $subject\n\n$body ($id)\n"
408   );
409
410   my $note = $self->edit_text( $template );
411   if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
412     $self->add_note( $log->id, $note );
413     return 1;
414   }
415   return;
416 }
417
418 sub do_linked_item {
419   my ($self, $choice, $log) = @_;
420   my $section = _strip_parens($choice->{name});
421   my $subject = $log->subject;
422   my $body = $log->body;
423   my $id = $log->short_id;
424
425   my $template = $self->note_template( $log,
426     "perldelta: $section [pending]\n\n=head3 L<LINK>\n\n=over\n\n=item *\n\n$subject ($id)\n\n$body\n\n=back\n"
427   );
428
429   my $note = $self->edit_text($template);
430   if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
431     $self->add_note( $log->id, $note );
432     return 1;
433   }
434   return;
435 }
436
437 sub do_item {
438   my ($self, $choice, $log) = @_;
439   my $section = _strip_parens($choice->{name});
440   my $subject = $log->subject;
441   my $body = $log->body;
442   my $id = $log->short_id;
443
444   my $template = $self->note_template( $log,
445     "perldelta: $section [pending]\n\n=item *\n\n$subject ($id)\n\n$body\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_none {
457   my ($self, $choice, $log) = @_;
458   my $note = "perldelta: None [ignored]\n";
459   $self->add_note( $log->id, $note );
460   return 1;
461 }
462
463 sub do_platform {
464   my ($self, $choice, $log) = @_;
465   my $section = _strip_parens($choice->{name});
466   my $subject = $log->subject;
467   my $body = $log->body;
468   my $id = $log->short_id;
469
470   my $template = $self->note_template( $log,
471     "perldelta: $section [pending]\n\n=item PLATFORM-NAME\n\n$subject ($id)\n\n$body\n"
472   );
473
474   my $note = $self->edit_text($template);
475   if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
476     $self->add_note( $log->id, $note );
477     return 1;
478   }
479   return;
480 }
481
482 sub do_quit { exit 0 }
483
484 sub do_repeat { return 0 }
485
486 sub do_skip { return 1 }
487
488 sub do_special {
489   my ($self, $choice, $log) = @_;
490   my $section = _strip_parens($choice->{name});
491   my $subject = $log->subject;
492   my $body = $log->body;
493   my $id = $log->short_id;
494
495   my $template = $self->note_template( $log, << "HERE" );
496 perldelta: $section [pending]
497
498 $subject
499
500 $body ($id)
501 HERE
502
503   my $note = $self->edit_text( $template );
504   if ( ($note ne $template) or $self->y_n("Note unchanged. Commit it?") ) {
505     $self->add_note( $log->id, $note );
506     return 1;
507   }
508   return;
509 }
510
511 sub do_subsection {
512   my ($self, $choice, $log) = @_;
513   my @choices = ( $choice->{subsection}, $self->submenu_choices );
514   say "For " . _strip_parens($choice->{name}) . ":";
515   return $self->dispatch( $self->prompt( @choices ), $log);
516 }
517
518 #--------------------------------------------------------------------------#
519 # define prompts
520 #--------------------------------------------------------------------------#
521
522 sub action_choices {
523   my ($self) = @_;
524   state $action_choices = [
525       { name => '(+)Cherrymaint', handler => 'cherry' },
526       { name => '(?)NeedHelp', handler => 'blocking' },
527       { name => 'S(k)ip', handler => 'skip' },
528       { name => '(Q)uit', handler => 'quit' },
529   ];
530   return $action_choices;
531 }
532
533 sub submenu_choices {
534   my ($self) = @_;
535   state $submenu_choices = [
536       { name => '(B)ack', handler => 'repeat' },
537   ];
538   return $submenu_choices;
539 }
540
541
542 sub review_choices {
543   my ($self) = @_;
544   state $action_choices = [
545       { name => '(E)dit', handler => 'edit' },
546       { name => '(I)gnore', handler => 'none' },
547       { name => '(D)one', handler => 'done' },
548   ];
549   return $action_choices;
550 }
551
552 sub section_choices {
553   my ($self, $key) = @_;
554   state $section_choices = [
555     # Headline stuff that should go first
556     {
557       name => 'Core (E)nhancements',
558       handler => 'head2',
559     },
560     {
561       name => 'Securit(y)',
562       handler => 'head2',
563     },
564     {
565       name => '(I)ncompatible Changes',
566       handler => 'head2',
567     },
568     {
569       name => 'Dep(r)ecations',
570       handler => 'head2',
571     },
572     {
573       name => '(P)erformance Enhancements',
574       handler => 'item',
575     },
576
577     # Details on things installed with Perl (for Perl developers)
578     {
579       name => '(M)odules and Pragmata',
580       handler => 'subsection',
581       subsection => [
582         {
583           name => '(N)ew Modules and Pragmata',
584           handler => 'item',
585         },
586         {
587           name => '(U)pdated Modules and Pragmata',
588           handler => 'item',
589         },
590         {
591           name => '(R)emoved Modules and Pragmata',
592           handler => 'item',
593         },
594       ],
595     },
596     {
597       name => '(D)ocumentation',
598       handler => 'subsection',
599       subsection => [
600         {
601           name => '(N)ew Documentation',
602           handler => 'linked_item',
603         },
604         {
605           name => '(C)hanges to Existing Documentation',
606           handler => 'linked_item',
607         },
608       ],
609     },
610     {
611       name => 'Dia(g)nostics',
612       handler => 'subsection',
613       subsection => [
614         {
615           name => '(N)ew Diagnostics',
616           handler => 'item',
617         },
618         {
619           name => '(C)hanges to Existing Diagnostics',
620           handler => 'item',
621         },
622       ],
623     },
624     {
625       name => '(U)tilities',
626       handler => 'linked_item',
627     },
628
629     # Details on building/testing Perl (for porters and packagers)
630     {
631       name => '(C)onfiguration and Compilation',
632       handler => 'item',
633     },
634     {
635       name => '(T)esting', # new tests or significant notes about it
636       handler => 'item',
637     },
638     {
639       name => 'Pl(a)tform Support',
640       handler => 'subsection',
641       subsection => [
642         {
643           name => '(N)ew Platforms',
644           handler => 'platform',
645         },
646         {
647           name => '(D)iscontinued Platforms',
648           handler => 'platform',
649         },
650         {
651           name => '(P)latform-Specific Notes',
652           handler => 'platform',
653         },
654       ],
655     },
656
657     # Details on perl internals (for porters and XS developers)
658     {
659       name => 'Inter(n)al Changes',
660       handler => 'item',
661     },
662
663     # Bugs fixed and related stuff
664     {
665       name => 'Selected Bug (F)ixes',
666       handler => 'item',
667     },
668     {
669       name => 'Known Prob(l)ems',
670       handler => 'item',
671     },
672
673     # dummy options for special handling
674     {
675       name => '(S)pecial',
676       handler => 'special',
677     },
678     {
679       name => '(*)None',
680       handler => 'none',
681     },
682   ];
683   return $section_choices;
684 }
685
686 sub section_order {
687   my ($self) = @_;
688   state @order;
689   if ( ! @order ) {
690     for my $c ( @{ $self->section_choices } ) {
691       if ( $c->{subsection} ) {
692         push @order, map { $_->{name} } @{$c->{subsection}};
693       }
694       else {
695         push @order, $c->{name};
696       }
697     }
698   }
699   return @order;
700 }
701
702 #--------------------------------------------------------------------------#
703 # Utility functions
704 #--------------------------------------------------------------------------#
705
706 sub _strip_parens {
707   my ($name) = @_;
708   $name =~ s/[()]//g;
709   return $name;
710 }
711
712 sub _prepend_comment {
713   my ($text) = @_;
714   return join ("\n", map { s/^/# /g; $_ } split "\n", $text);
715 }
716
717 sub _strip_comments {
718   my ($text) = @_;
719   return join ("\n", grep { ! /^#/ } split "\n", $text);
720 }
721
722 #--------------------------------------------------------------------------#
723 # Extend Git::Wrapper::Log
724 #--------------------------------------------------------------------------#
725
726 package Git::Wrapper::XLog;
727 BEGIN { our @ISA = qw/Git::Wrapper::Log/; }
728
729 sub subject { shift->attr->{subject} }
730 sub body { shift->attr->{body} }
731 sub short_id { shift->attr->{short_id} }
732
733 sub from_log {
734   my ($class, $log) = @_;
735
736   my $msg = $log->message;
737   my ($subject, $body) = $msg =~ m{^([^\n]+)\n*(.*)}ms;
738   $subject //= '';
739   $body //= '';
740   $body =~ s/[\r\n]*\z//ms;
741
742   my ($short) = Git::Wrapper->new(".")->rev_parse({short => 1}, $log->id);
743
744   $log->attr->{subject} = $subject;
745   $log->attr->{body} = $body;
746   $log->attr->{short_id} = $short;
747   return bless $log, $class;
748 }
749
750 sub notes {
751   my ($self) = @_;
752   my @notes = eval { Git::Wrapper->new(".")->notes('show', $self->id) };
753   pop @notes while @notes && $notes[-1] =~ m{^\s*$};
754   return unless @notes;
755   return join ("\n", @notes);
756 }
757
758 __END__
759
760 =head1 NAME
761
762 git-deltatool - Annotate commits for perldelta
763
764 =head1 SYNOPSIS
765
766  # annotate commits back to last 'git describe' tag
767
768  $ git-deltatool
769
770  # review annotations
771
772  $ git-deltatool --mode review
773
774  # review commits needing help
775
776  $ git-deltatool --mode review --type blocking
777
778  # summarize commits needing help
779
780  $ git-deltatool --mode summary --type blocking
781
782  # assemble annotations by section to STDOUT
783
784  $ git-deltatool --mode render
785
786  # mark 'pending' annotations as 'done' (i.e. added to perldelta)
787
788  $ git-deltatool --mode update --type pending --status done
789
790 =head1 OPTIONS
791
792 =over
793
794 =item B<--mode>|B<-m> MODE
795
796 Indicates the run mode for the program.  The default is 'assign' which
797 assigns categories and marks the notes as 'pending' (or 'ignored').  Other
798 modes are 'review', 'render', 'summarize' and 'update'.
799
800 =item B<--type>|B<-t> TYPE
801
802 Indicates what types of commits to process.  The default for 'assign' mode is
803 'new', which processes commits without any perldelta notes.  The default for
804 'review', 'summarize' and 'render' modes is 'pending'.  The options must be set
805 explicitly for 'update' mode.
806
807 The type 'blocking' is reserved for commits needing further review.
808
809 =item B<--status>|B<-s> STATUS
810
811 For 'update' mode only, sets a new status.  While there is no restriction,
812 it should be one of 'new', 'pending', 'blocking', 'ignored' or 'done'.
813
814 =item B<--since> REVISION
815
816 Defines the boundary for searching git commits.  Defaults to the last
817 major tag (as would be given by 'git describe').
818
819 =item B<--help>
820
821 Shows the manual.
822
823 =back
824
825 =head1 TODO
826
827 It would be nice to make some of the structured sections smarter -- e.g.
828 look at changed files in pod/* for Documentation section entries.  Likewise
829 it would be nice to collate them during the render phase -- e.g. cluster
830 all platform-specific things properly.
831
832 =head1 AUTHOR
833
834 David Golden <dagolden@cpan.org>
835
836 =head1 COPYRIGHT AND LICENSE
837
838 This software is copyright (c) 2010 by David Golden.
839
840 This is free software; you can redistribute it and/or modify it under the same
841 terms as the Perl 5 programming language system itself.
842
843 =cut
844