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