Commit | Line | Data |
---|---|---|
d7816c47 NC |
1 | #!/usr/bin/perl -w |
2 | ||
3 | use strict; | |
449e2f79 | 4 | use Digest::MD5 'md5'; |
9bbb230a | 5 | use 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 | ||
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 | ||
bcfe7366 NC |
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 | ||
9bbb230a NC |
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 { | |
65e5b016 NC |
50 | if (m!/t\z!) { |
51 | ++$File::Find::prune; | |
52 | return; | |
53 | } | |
54 | ||
9bbb230a NC |
55 | # $_ is $File::Find::name when using no_chdir |
56 | return unless m!\.p(?:m|od)\z! && -f $_; | |
9bbb230a NC |
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 | } | |
9887f448 NC |
75 | |
76 | my %state = ( | |
77 | # Don't copy these top level READMEs | |
78 | ignore => { | |
79 | micro => 1, | |
80 | # vms => 1, | |
81 | }, | |
82 | ); | |
83 | ||
4027e27b NC |
84 | { |
85 | my (%Lengths, %MD5s); | |
86 | ||
87 | sub is_duplicate_pod { | |
88 | my $file = shift; | |
75d90f49 | 89 | local $_; |
4027e27b NC |
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}}) { | |
2ce3647c | 95 | next unless $_->[2]{dual}; |
4027e27b NC |
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. | |
2ce3647c NC |
99 | ++$Lengths{-s $_->[1]}; |
100 | ++$MD5s{md5(slurp_or_die($_->[1]))}; | |
4027e27b NC |
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 | } | |
449e2f79 NC |
109 | } |
110 | ||
9887f448 | 111 | sub __prime_state { |
d7816c47 NC |
112 | my $source = 'perldelta.pod'; |
113 | my $filename = "pod/$source"; | |
64587559 | 114 | my $contents = slurp_or_die($filename); |
d7816c47 | 115 | my @want = |
bcfe7366 | 116 | $contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\n/; |
d7816c47 | 117 | die "Can't extract version from $filename" unless @want; |
0aef0fe5 NC |
118 | my $delta_leaf = join '', 'perl', @want, 'delta'; |
119 | $state{delta_target} = "$delta_leaf.pod"; | |
bcfe7366 | 120 | $state{delta_version} = \@want; |
d7816c47 NC |
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 | ||
0aef0fe5 NC |
127 | # The default flags if none explicitly set for the current file. |
128 | my $current_flags = ''; | |
129 | my (%flag_set, @paths); | |
d7816c47 | 130 | |
0aef0fe5 NC |
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 | |
4e604983 | 155 | $state{aux} = [sort @args]; |
0aef0fe5 NC |
156 | } else { |
157 | my_die("Unknown buildtoc command '$command'"); | |
158 | } | |
159 | } | |
d7816c47 NC |
160 | |
161 | foreach (<$master>) { | |
0aef0fe5 NC |
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; | |
d7816c47 | 190 | $flags{toc_omit} = 1 if $flags =~ tr/o//d; |
dc437300 | 191 | $flags{dual} = $podname ne $leafname; |
d7816c47 NC |
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//; | |
64587559 | 198 | $state{readmes}{$readme} = $desc; |
d7816c47 | 199 | $flags{readme} = 1; |
d7816c47 NC |
200 | } else { |
201 | $state{pods}{$podname} = $desc; | |
202 | } | |
203 | my_die "Unknown flag found in section line: $_" if length $flags; | |
449e2f79 | 204 | |
d7816c47 | 205 | push @{$state{master}}, |
2ce3647c | 206 | [$leafname, $filename, \%flags]; |
0aef0fe5 NC |
207 | |
208 | if ($podname eq 'perldelta') { | |
209 | local $" = '.'; | |
0aef0fe5 | 210 | push @{$state{master}}, |
2ce3647c | 211 | [$delta_leaf, "pod/$state{delta_target}"]; |
dc437300 | 212 | $state{pods}{$delta_leaf} = "Perl changes in version @want"; |
0aef0fe5 NC |
213 | } |
214 | ||
d7816c47 | 215 | } else { |
0aef0fe5 | 216 | my_die("Malformed line: $_"); |
d7816c47 NC |
217 | } |
218 | } | |
0aef0fe5 | 219 | close $master or my_die("close pod/perl.pod: $!"); |
e1aae8e4 NC |
220 | # This has to be special-cased somewhere. Turns out this is cleanest: |
221 | push @{$state{master}}, ['a2p', 'x2p/a2p.pod', {toc_omit => 1}]; | |
0aef0fe5 NC |
222 | |
223 | my_die("perl.pod sets flags for unknown pods: " | |
224 | . join ' ', sort keys %flag_set) | |
225 | if keys %flag_set; | |
9887f448 NC |
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; | |
75d90f49 | 233 | local $_; |
d7816c47 | 234 | |
9887f448 | 235 | __prime_state() unless $state{master}; |
d4c6b7ae NC |
236 | return \%state unless $callback; |
237 | ||
9887f448 NC |
238 | my %BuildFiles; |
239 | ||
240 | foreach my $path (@_) { | |
241 | $path =~ m!([^/]+)$!; | |
242 | ++$BuildFiles{$1}; | |
243 | } | |
244 | ||
d7816c47 NC |
245 | # Sanity cross check |
246 | ||
0aef0fe5 | 247 | my (%disk_pods, %manipods, %manireadmes); |
852355fc | 248 | my (%cpanpods, %cpanpods_leaf); |
d7816c47 NC |
249 | my (%our_pods); |
250 | ||
6ca94f41 RGS |
251 | # There are files that we don't want to list in perl.pod. |
252 | # Maybe the various stub manpages should be listed there. | |
253 | my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( ); | |
d7816c47 NC |
254 | |
255 | # Convert these to a list of filenames. | |
64587559 NC |
256 | ++$our_pods{"$_.pod"} foreach keys %{$state{pods}}; |
257 | foreach (@{$state{master}}) { | |
2ce3647c NC |
258 | ++$our_pods{"$_->[0].pod"} |
259 | if $_->[2]{readme}; | |
d7816c47 NC |
260 | } |
261 | ||
262 | opendir my $dh, 'pod'; | |
263 | while (defined ($_ = readdir $dh)) { | |
264 | next unless /\.pod\z/; | |
d7816c47 NC |
265 | ++$disk_pods{$_}; |
266 | } | |
267 | ||
268 | # Things we copy from won't be in perl.pod | |
269 | # Things we copy to won't be in MANIFEST | |
270 | ||
271 | my $mani = open_or_die('MANIFEST'); | |
272 | while (<$mani>) { | |
273 | chomp; | |
274 | s/\s+.*$//; | |
275 | if (m!^pod/([^.]+\.pod)!i) { | |
6fdb59a5 | 276 | ++$manipods{$1}; |
d7816c47 NC |
277 | } elsif (m!^README\.(\S+)!i) { |
278 | next if $state{ignore}{$1}; | |
6fdb59a5 | 279 | ++$manireadmes{"perl$1.pod"}; |
d7816c47 | 280 | } elsif (exists $our_pods{$_}) { |
852355fc NC |
281 | ++$cpanpods{$_}; |
282 | m!([^/]+)$!; | |
283 | ++$cpanpods_leaf{$1}; | |
d7816c47 NC |
284 | $disk_pods{$_}++ |
285 | if -e $_; | |
286 | } | |
287 | } | |
288 | close $mani or my_die "close MANIFEST: $!\n"; | |
289 | ||
c26a697b NC |
290 | # Are we running before known generated files have been generated? |
291 | # (eg in a clean checkout) | |
292 | my %not_yet_there; | |
293 | if ($permit_missing_generated) { | |
294 | # If so, don't complain if these files aren't yet in place | |
295 | %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}}) | |
296 | } | |
297 | ||
d7816c47 NC |
298 | my @inconsistent; |
299 | foreach my $i (sort keys %disk_pods) { | |
300 | push @inconsistent, "$0: $i exists but is unknown by buildtoc\n" | |
6ca94f41 | 301 | unless $our_pods{$i} || $ignoredpods{$i}; |
d7816c47 | 302 | push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n" |
9e241592 NC |
303 | if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST |
304 | && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i} | |
305 | && !$state{generated}{$i} && !$cpanpods{$i}; | |
d7816c47 NC |
306 | } |
307 | foreach my $i (sort keys %our_pods) { | |
308 | push @inconsistent, "$0: $i is known by buildtoc but does not exist\n" | |
c26a697b | 309 | unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i}; |
d7816c47 | 310 | } |
9e241592 NC |
311 | unless ($BuildFiles{'MANIFEST'}) { |
312 | # Again, ignore these if we're about to rebuild MANIFEST | |
313 | foreach my $i (sort keys %manipods) { | |
314 | push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n" | |
315 | unless $disk_pods{$i}; | |
316 | push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n" | |
317 | if $state{generated}{$i}; | |
318 | } | |
d7816c47 | 319 | } |
d4c6b7ae | 320 | &$callback(@inconsistent); |
d7816c47 NC |
321 | return \%state; |
322 | } | |
323 | ||
324 | 1; | |
325 | ||
326 | # Local variables: | |
327 | # cperl-indent-level: 4 | |
328 | # indent-tabs-mode: nil | |
329 | # End: | |
330 | # | |
331 | # ex: set ts=8 sts=4 sw=4 et: |