1#!perl
2use strict;
3use warnings;
4use autodie;
5
6use Getopt::Long;
7use Pod::Simple::HTML;
8
9sub 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';
19make-rmg-checklist [--type TYPE]
20
21This script creates a release checklist as a simple HTML document. It accepts
22the 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
29EOF
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
53sub _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
71sub _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
106sub _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
115Release Manager's Guide with Checklist
116
117=head2 Checklist
118
119EOF
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
145main();
146