This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move the common Pod scanning code from installman and buildtoc to pod_lib.pl
[perl5.git] / Porting / pod_lib.pl
CommitLineData
d7816c47
NC
1#!/usr/bin/perl -w
2
3use strict;
449e2f79 4use Digest::MD5 'md5';
9bbb230a 5use File::Find;
d7816c47
NC
6
7# make it clearer when we haven't run to completion, as we can be quite
8# noisy when things are working ok
9
10sub my_die {
11 print STDERR "$0: ", @_;
12 print STDERR "\n" unless $_[-1] =~ /\n\z/;
13 print STDERR "ABORTED\n";
14 exit 255;
15}
16
17sub open_or_die {
18 my $filename = shift;
19 open my $fh, '<', $filename or my_die "Can't open $filename: $!";
20 return $fh;
21}
22
bcfe7366
NC
23sub slurp_or_die {
24 my $filename = shift;
25 my $fh = open_or_die($filename);
26 binmode $fh;
27 local $/;
28 my $contents = <$fh>;
29 die "Can't read $filename: $!" unless defined $contents and close $fh;
30 return $contents;
31}
32
33sub write_or_die {
34 my ($filename, $contents) = @_;
35 open my $fh, '>', $filename or die "Can't open $filename for writing: $!";
36 binmode $fh;
37 print $fh $contents or die "Can't write to $filename: $!";
38 close $fh or die "Can't close $filename: $!";
39}
40
9bbb230a
NC
41sub pods_to_install {
42 # manpages not to be installed
43 my %do_not_install = map { ($_ => 1) }
44 qw(Pod::Functions XS::APItest XS::Typemap);
45
46 my (%done, %found);
47
48 File::Find::find({no_chdir=>1,
49 wanted => sub {
50 # $_ is $File::Find::name when using no_chdir
51 return unless m!\.p(?:m|od)\z! && -f $_;
52 return if m!(?:^|/)t/!;
53 return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-)
54 # Skip .pm files that have corresponding .pod files
55 return if s!\.pm\z!.pod! && -e $_;
56 s!\.pod\z!!;
57 s!\Alib/!!;
58 s!/!::!g;
59
60 my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
61 if exists $done{$_};
62 $done{$_} = $File::Find::name;
63
64 return if $do_not_install{$_};
65 return if is_duplicate_pod($File::Find::name);
66 $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
67 = $File::Find::name;
68 }}, 'lib');
69 return \%found;
70}
9887f448
NC
71
72my %state = (
73 # Don't copy these top level READMEs
74 ignore => {
75 micro => 1,
76 # vms => 1,
77 },
78 );
79
4027e27b
NC
80{
81 my (%Lengths, %MD5s);
82
83 sub is_duplicate_pod {
84 my $file = shift;
85
86 # Initialise the list of possible source files on the first call.
87 unless (%Lengths) {
88 __prime_state() unless $state{master};
89 foreach (@{$state{master}}) {
2ce3647c 90 next unless $_->[2]{dual};
4027e27b
NC
91 # This is a dual-life perl*.pod file, which will have be copied
92 # to lib/ by the build process, and hence also found there.
93 # These are the only pod files that might become duplicated.
2ce3647c
NC
94 ++$Lengths{-s $_->[1]};
95 ++$MD5s{md5(slurp_or_die($_->[1]))};
4027e27b
NC
96 }
97 }
98
99 # We are a file in lib. Are we a duplicate?
100 # Don't bother calculating the MD5 if there's no interesting file of
101 # this length.
102 return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
103 }
449e2f79
NC
104}
105
9887f448 106sub __prime_state {
d7816c47
NC
107 my $source = 'perldelta.pod';
108 my $filename = "pod/$source";
64587559 109 my $contents = slurp_or_die($filename);
d7816c47 110 my @want =
bcfe7366 111 $contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\n/;
d7816c47 112 die "Can't extract version from $filename" unless @want;
0aef0fe5
NC
113 my $delta_leaf = join '', 'perl', @want, 'delta';
114 $state{delta_target} = "$delta_leaf.pod";
bcfe7366 115 $state{delta_version} = \@want;
d7816c47
NC
116
117 # This way round so that keys can act as a MANIFEST skip list
118 # Targets will always be in the pod directory. Currently we can only cope
119 # with sources being in the same directory.
120 $state{copies}{$state{delta_target}} = $source;
121
0aef0fe5
NC
122 # The default flags if none explicitly set for the current file.
123 my $current_flags = '';
124 my (%flag_set, @paths);
d7816c47 125
0aef0fe5
NC
126 my $master = open_or_die('pod/perl.pod');
127
128 while (<$master>) {
129 last if /^=begin buildtoc$/;
130 }
131 die "Can't find '=begin buildtoc':" if eof $master;
132
133 while (<$master>) {
134 next if /^$/ or /^#/;
135 last if /^=end buildtoc/;
136 my ($command, @args) = split ' ';
137 if ($command eq 'flag') {
138 # For the named pods, use these flags, instead of $current_flags
139 my $flags = shift @args;
140 my_die("Malformed flag $flags")
141 unless $flags =~ /\A=([a-z]*)\z/;
142 $flag_set{$_} = $1 foreach @args;
143 } elsif ($command eq 'path') {
144 # If the pod's name matches the regex, prepend the given path.
145 my_die("Malformed path for /$args[0]/")
146 unless @args == 2;
147 push @paths, [qr/\A$args[0]\z/, $args[1]];
148 } elsif ($command eq 'aux') {
149 # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
4e604983 150 $state{aux} = [sort @args];
0aef0fe5
NC
151 } else {
152 my_die("Unknown buildtoc command '$command'");
153 }
154 }
d7816c47
NC
155
156 foreach (<$master>) {
0aef0fe5
NC
157 next if /^$/ or /^#/;
158 next if /^=head2/;
159 last if /^=for buildtoc __END__$/;
160
161 if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
162 if ($action eq '+') {
163 $current_flags .= $flags;
164 } else {
165 my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
166 unless $current_flags =~ s/[\Q$flags\E]//g;
167 }
168 } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
169 my $podname = $leafname;
170 my $filename = "pod/$podname.pod";
171 foreach (@paths) {
172 my ($re, $path) = @$_;
173 if ($leafname =~ $re) {
174 $podname = $path . $leafname;
175 $filename = "$podname.pod";
176 last;
177 }
178 }
179
180 # Keep this compatible with pre-5.10
181 my $flags = delete $flag_set{$leafname};
182 $flags = $current_flags unless defined $flags;
183
184 my %flags;
d7816c47 185 $flags{toc_omit} = 1 if $flags =~ tr/o//d;
dc437300 186 $flags{dual} = $podname ne $leafname;
d7816c47
NC
187
188 $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
189
190 if ($flags =~ tr/r//d) {
191 my $readme = $podname;
192 $readme =~ s/^perl//;
64587559 193 $state{readmes}{$readme} = $desc;
d7816c47 194 $flags{readme} = 1;
d7816c47
NC
195 } else {
196 $state{pods}{$podname} = $desc;
197 }
198 my_die "Unknown flag found in section line: $_" if length $flags;
449e2f79 199
d7816c47 200 push @{$state{master}},
2ce3647c 201 [$leafname, $filename, \%flags];
0aef0fe5
NC
202
203 if ($podname eq 'perldelta') {
204 local $" = '.';
0aef0fe5 205 push @{$state{master}},
2ce3647c 206 [$delta_leaf, "pod/$state{delta_target}"];
dc437300 207 $state{pods}{$delta_leaf} = "Perl changes in version @want";
0aef0fe5
NC
208 }
209
d7816c47 210 } else {
0aef0fe5 211 my_die("Malformed line: $_");
d7816c47
NC
212 }
213 }
0aef0fe5
NC
214 close $master or my_die("close pod/perl.pod: $!");
215
216 my_die("perl.pod sets flags for unknown pods: "
217 . join ' ', sort keys %flag_set)
218 if keys %flag_set;
9887f448
NC
219}
220
221sub get_pod_metadata {
222 # Do we expect to find generated pods on disk?
223 my $permit_missing_generated = shift;
224 # Do they want a consistency report?
225 my $callback = shift;
d7816c47 226
9887f448 227 __prime_state() unless $state{master};
d4c6b7ae
NC
228 return \%state unless $callback;
229
9887f448
NC
230 my %BuildFiles;
231
232 foreach my $path (@_) {
233 $path =~ m!([^/]+)$!;
234 ++$BuildFiles{$1};
235 }
236
d7816c47
NC
237 # Sanity cross check
238
0aef0fe5 239 my (%disk_pods, %manipods, %manireadmes);
852355fc 240 my (%cpanpods, %cpanpods_leaf);
d7816c47
NC
241 my (%our_pods);
242
243 # These are stub files for deleted documents. We don't want them to show up
244 # in perl.pod, they just exist so that if someone types "perldoc perltoot"
245 # they get some sort of pointer to the new docs.
246 my %ignoredpods
247 = map { ( "$_.pod" => 1 ) } qw( perlboot perlbot perltooc perltoot );
248
249 # Convert these to a list of filenames.
64587559
NC
250 ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
251 foreach (@{$state{master}}) {
2ce3647c
NC
252 ++$our_pods{"$_->[0].pod"}
253 if $_->[2]{readme};
d7816c47
NC
254 }
255
256 opendir my $dh, 'pod';
257 while (defined ($_ = readdir $dh)) {
258 next unless /\.pod\z/;
d7816c47
NC
259 ++$disk_pods{$_};
260 }
261
262 # Things we copy from won't be in perl.pod
263 # Things we copy to won't be in MANIFEST
264
265 my $mani = open_or_die('MANIFEST');
266 while (<$mani>) {
267 chomp;
268 s/\s+.*$//;
269 if (m!^pod/([^.]+\.pod)!i) {
6fdb59a5 270 ++$manipods{$1};
d7816c47
NC
271 } elsif (m!^README\.(\S+)!i) {
272 next if $state{ignore}{$1};
6fdb59a5 273 ++$manireadmes{"perl$1.pod"};
d7816c47 274 } elsif (exists $our_pods{$_}) {
852355fc
NC
275 ++$cpanpods{$_};
276 m!([^/]+)$!;
277 ++$cpanpods_leaf{$1};
d7816c47
NC
278 $disk_pods{$_}++
279 if -e $_;
280 }
281 }
282 close $mani or my_die "close MANIFEST: $!\n";
283
c26a697b
NC
284 # Are we running before known generated files have been generated?
285 # (eg in a clean checkout)
286 my %not_yet_there;
287 if ($permit_missing_generated) {
288 # If so, don't complain if these files aren't yet in place
289 %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
290 }
291
d7816c47
NC
292 my @inconsistent;
293 foreach my $i (sort keys %disk_pods) {
294 push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
295 unless $our_pods{$i};
296 push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
9e241592
NC
297 if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
298 && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
299 && !$state{generated}{$i} && !$cpanpods{$i};
d7816c47
NC
300 }
301 foreach my $i (sort keys %our_pods) {
302 push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
c26a697b 303 unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
d7816c47 304 }
9e241592
NC
305 unless ($BuildFiles{'MANIFEST'}) {
306 # Again, ignore these if we're about to rebuild MANIFEST
307 foreach my $i (sort keys %manipods) {
308 push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
309 unless $disk_pods{$i};
310 push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
311 if $state{generated}{$i};
312 }
d7816c47 313 }
d4c6b7ae 314 &$callback(@inconsistent);
d7816c47
NC
315 return \%state;
316}
317
3181;
319
320# Local variables:
321# cperl-indent-level: 4
322# indent-tabs-mode: nil
323# End:
324#
325# ex: set ts=8 sts=4 sw=4 et: