| 1 | #!perl |
| 2 | use strict; |
| 3 | use warnings; |
| 4 | use autodie; |
| 5 | |
| 6 | use Getopt::Long; |
| 7 | use Pod::Simple::HTML; |
| 8 | |
| 9 | sub main { |
| 10 | my ( $help, $type, $html ); |
| 11 | GetOptions( |
| 12 | 'type:s' => \$type, |
| 13 | 'html' => \$html, |
| 14 | 'help' => \$help, |
| 15 | ); |
| 16 | |
| 17 | if ($help) { |
| 18 | print <<'EOF'; |
| 19 | make-rmg-checklist [--type TYPE] |
| 20 | |
| 21 | This script creates a release checklist as a simple HTML document. It accepts |
| 22 | the following arguments: |
| 23 | |
| 24 | --type The release type for the checklist. This can be BLEAD-FINAL, |
| 25 | BLEAD-POINT, MAINT, or RC. This defaults to BLEAD-POINT. |
| 26 | |
| 27 | --html Output HTML instead of POD |
| 28 | |
| 29 | EOF |
| 30 | |
| 31 | exit; |
| 32 | } |
| 33 | |
| 34 | $type = _validate_type($type); |
| 35 | |
| 36 | open my $fh, '<', 'Porting/release_managers_guide.pod'; |
| 37 | my $pod = do { local $/; <$fh> }; |
| 38 | close $fh; |
| 39 | |
| 40 | my $heads = _parse_rmg( $pod, $type ); |
| 41 | my $new_pod = _munge_pod( $pod, $heads ); |
| 42 | |
| 43 | if ($html) { |
| 44 | my $simple = Pod::Simple::HTML->new(); |
| 45 | $simple->output_fh(*STDOUT); |
| 46 | $simple->parse_string_document($new_pod); |
| 47 | } |
| 48 | else { |
| 49 | print $new_pod; |
| 50 | } |
| 51 | } |
| 52 | |
| 53 | sub _validate_type { |
| 54 | my $type = shift || 'BLEAD-POINT'; |
| 55 | |
| 56 | my @valid = qw( BLEAD-FINAL BLEAD-POINT MAINT RC ); |
| 57 | my %valid = map { $_ => 1 } @valid; |
| 58 | |
| 59 | unless ( $valid{ uc $type } ) { |
| 60 | my $err |
| 61 | = "The type you provided ($type) is not a valid release type. It must be one of "; |
| 62 | $err .= join ', ', @valid; |
| 63 | $err .= "\n"; |
| 64 | |
| 65 | die $err; |
| 66 | } |
| 67 | |
| 68 | return $type; |
| 69 | } |
| 70 | |
| 71 | sub _parse_rmg { |
| 72 | my $pod = shift; |
| 73 | my $type = shift; |
| 74 | |
| 75 | my @heads; |
| 76 | my $include = 0; |
| 77 | my %skip; |
| 78 | |
| 79 | for ( split /\n/, $pod ) { |
| 80 | if (/^=for checklist begin/) { |
| 81 | $include = 1; |
| 82 | next; |
| 83 | } |
| 84 | |
| 85 | next unless $include; |
| 86 | |
| 87 | last if /^=for checklist end/; |
| 88 | |
| 89 | if (/^=for checklist skip (.+)/) { |
| 90 | %skip = map { $_ => 1 } split / /, $1; |
| 91 | next; |
| 92 | } |
| 93 | |
| 94 | if (/^=head(\d) (.+)/) { |
| 95 | unless ( keys %skip && $skip{$type} ) { |
| 96 | push @heads, [ $1, $2 ]; |
| 97 | } |
| 98 | |
| 99 | %skip = (); |
| 100 | } |
| 101 | } |
| 102 | |
| 103 | return \@heads; |
| 104 | } |
| 105 | |
| 106 | sub _munge_pod { |
| 107 | my $pod = shift; |
| 108 | my $heads = shift; |
| 109 | |
| 110 | $pod =~ s/=head1 NAME.+?(=head1 SYNOPSIS)/$1/s; |
| 111 | |
| 112 | my $new_pod = <<'EOF'; |
| 113 | =head1 NAME |
| 114 | |
| 115 | Release Manager's Guide with Checklist |
| 116 | |
| 117 | =head2 Checklist |
| 118 | |
| 119 | EOF |
| 120 | |
| 121 | my $last_level = 0; |
| 122 | for my $head ( @{$heads} ) { |
| 123 | my $level = $head->[0] - 1; |
| 124 | |
| 125 | if ( $level > $last_level ) { |
| 126 | $new_pod .= '=over ' . $level * 4; |
| 127 | $new_pod .= "\n\n"; |
| 128 | } |
| 129 | elsif ( $level < $last_level ) { |
| 130 | $new_pod .= "=back\n\n" for 1 .. ( $last_level - $level ); |
| 131 | } |
| 132 | |
| 133 | $new_pod .= '=item * ' . 'L<< /' . $head->[1] . " >>\n\n"; |
| 134 | |
| 135 | $last_level = $level; |
| 136 | } |
| 137 | |
| 138 | $new_pod .= "=back\n\n" while $last_level--; |
| 139 | |
| 140 | $new_pod .= $pod; |
| 141 | |
| 142 | return $new_pod; |
| 143 | } |
| 144 | |
| 145 | main(); |