This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Extract from buildtoc the code that processes pod.lst, MANIFEST and perl.pod
[perl5.git] / Porting / pod_lib.pl
1 #!/usr/bin/perl -w
2
3 use strict;
4
5 # make it clearer when we haven't run to completion, as we can be quite
6 # noisy when things are working ok
7
8 sub my_die {
9     print STDERR "$0: ", @_;
10     print STDERR "\n" unless $_[-1] =~ /\n\z/;
11     print STDERR "ABORTED\n";
12     exit 255;
13 }
14
15 sub open_or_die {
16     my $filename = shift;
17     open my $fh, '<', $filename or my_die "Can't open $filename: $!";
18     return $fh;
19 }
20
21 sub get_pod_metadata {
22     my %BuildFiles;
23
24     foreach my $path (@_) {
25         $path =~ m!([^/]+)$!;
26         ++$BuildFiles{$1};
27     }
28
29     my %state =
30         (
31          # Don't copy these top level READMEs
32          ignore =>
33          {
34           micro => 1,
35           # vms => 1,
36          },
37      );
38
39     my $source = 'perldelta.pod';
40     my $filename = "pod/$source";
41     my $fh = open_or_die($filename);
42     my $contents = do {local $/; <$fh>};
43     my @want =
44         $contents =~ /perldelta - what is new for perl v5\.(\d+)\.(\d+)\n/;
45     die "Can't extract version from $filename" unless @want;
46     $state{delta_target} = "perl5$want[0]$want[1]delta.pod";
47
48     # This way round so that keys can act as a MANIFEST skip list
49     # Targets will always be in the pod directory. Currently we can only cope
50     # with sources being in the same directory.
51     $state{copies}{$state{delta_target}} = $source;
52
53
54     # process pod.lst
55     my %Readmepods;
56     my $master = open_or_die('pod.lst');
57
58     foreach (<$master>) {
59         next if /^\#/;
60
61         # At least one upper case letter somewhere in the first group
62         if (/^(\S+)\s(.*)/ && $1 =~ tr/h//) {
63             # it's a heading
64             my $flags = $1;
65             $flags =~ tr/h//d;
66             my %flags = (header => 1);
67             $flags{toc_omit} = 1 if $flags =~ tr/o//d;
68             $flags{aux} = 1 if $flags =~ tr/a//d;
69             my_die "Unknown flag found in heading line: $_" if length $flags;
70
71             push @{$state{master}}, [\%flags, $2];
72         } elsif (/^(\S*)\s+(\S+)\s+(.*)/) {
73             # it's a section
74             my ($flags, $podname, $desc) = ($1, $2, $3);
75             my $filename = "${podname}.pod";
76             $filename = "pod/${filename}" if $filename !~ m{/};
77
78             my %flags = (indent => 0);
79             $flags{indent} = $1 if $flags =~ s/(\d+)//;
80             $flags{toc_omit} = 1 if $flags =~ tr/o//d;
81             $flags{aux} = 1 if $flags =~ tr/a//d;
82             $flags{perlpod_omit} = "$podname.pod" eq $state{delta_target};
83
84             $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
85
86             if ($flags =~ tr/r//d) {
87                 my $readme = $podname;
88                 $readme =~ s/^perl//;
89                 $Readmepods{$podname} = $state{readmes}{$readme} = $desc;
90                 $flags{readme} = 1;
91             } elsif ($flags{aux}) {
92                 $state{aux}{$podname} = $desc;
93             } else {
94                 $state{pods}{$podname} = $desc;
95             }
96             my_die "Unknown flag found in section line: $_" if length $flags;
97             my $shortname = $podname =~ s{.*/}{}r;
98             push @{$state{master}},
99                 [\%flags, $podname, $filename, $desc, $shortname];
100         } elsif (/^$/) {
101             push @{$state{master}}, undef;
102         } else {
103             my_die "Malformed line: $_" if $1 =~ tr/A-Z//;
104         }
105     }
106     close $master or my_die "close pod.lst: $!";
107
108     # Sanity cross check
109
110     my (%disk_pods, @disk_pods);
111     my (@manipods, %manipods);
112     my (@manireadmes, %manireadmes);
113     my (@perlpods, %perlpods);
114     my (@cpanpods, %cpanpods, %cpanpods_short);
115     my (%our_pods);
116
117     # These are stub files for deleted documents. We don't want them to show up
118     # in perl.pod, they just exist so that if someone types "perldoc perltoot"
119     # they get some sort of pointer to the new docs.
120     my %ignoredpods
121         = map { ( "$_.pod" => 1 ) } qw( perlboot perlbot perltooc perltoot );
122
123     # Convert these to a list of filenames.
124     foreach (keys %{$state{pods}}, keys %Readmepods) {
125         $our_pods{"$_.pod"}++;
126     }
127
128     opendir my $dh, 'pod';
129     while (defined ($_ = readdir $dh)) {
130         next unless /\.pod\z/;
131         push @disk_pods, $_;
132         ++$disk_pods{$_};
133     }
134
135     # Things we copy from won't be in perl.pod
136     # Things we copy to won't be in MANIFEST
137
138     my $mani = open_or_die('MANIFEST');
139     while (<$mani>) {
140         chomp;
141         s/\s+.*$//;
142         if (m!^pod/([^.]+\.pod)!i) {
143             push @manipods, $1;
144         } elsif (m!^README\.(\S+)!i) {
145             next if $state{ignore}{$1};
146             push @manireadmes, "perl$1.pod";
147         } elsif (exists $our_pods{$_}) {
148             push @cpanpods, $_;
149             $disk_pods{$_}++
150                 if -e $_;
151         }
152     }
153     close $mani or my_die "close MANIFEST: $!\n";
154
155     @manipods{@manipods} = @manipods;
156     @manireadmes{@manireadmes} = @manireadmes;
157     @cpanpods{@cpanpods} = map { s/.*\///r } @cpanpods;
158     %cpanpods_short = reverse %cpanpods;
159
160     my $perlpod = open_or_die('pod/perl.pod');
161     while (<$perlpod>) {
162         if (/^For ease of access, /../^\(If you're intending /) {
163             if (/^\s+(perl\S*)\s+\w/) {
164                 push @perlpods, "$1.pod";
165             }
166         }
167     }
168     close $perlpod or my_die "close perlpod: $!\n";
169     my_die "could not find the pod listing of perl.pod\n"
170         unless @perlpods;
171     @perlpods{@perlpods} = @perlpods;
172
173     my @inconsistent;
174     foreach my $i (sort keys %disk_pods) {
175         push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
176             unless $our_pods{$i};
177         push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
178             if !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
179                 && !$state{generated}{$i} && !$cpanpods{$i};
180         push @inconsistent, "$0: $i exists but is unknown by perl.pod\n"
181             if !$perlpods{$i} && !exists $state{copies}{$i} && !$cpanpods{$i} && !$ignoredpods{$i};
182     }
183     foreach my $i (sort keys %our_pods) {
184         push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
185             unless $disk_pods{$i} or $BuildFiles{$i};
186     }
187     foreach my $i (sort keys %manipods) {
188         push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
189             unless $disk_pods{$i};
190         push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
191             if $state{generated}{$i};
192     }
193     foreach my $i (sort keys %perlpods) {
194         push @inconsistent, "$0: $i is known by perl.pod but does not exist\n"
195             unless $disk_pods{$i} or $BuildFiles{$i} or $cpanpods_short{$i};
196     }
197     $state{inconsistent} = \@inconsistent;
198     return \%state;
199 }
200
201 1;
202
203 # Local variables:
204 # cperl-indent-level: 4
205 # indent-tabs-mode: nil
206 # End:
207 #
208 # ex: set ts=8 sts=4 sw=4 et: