Commit | Line | Data |
---|---|---|
d7816c47 NC |
1 | #!/usr/bin/perl -w |
2 | ||
3 | use strict; | |
9bbb230a | 4 | use File::Find; |
d7816c47 | 5 | |
1e62a62d JK |
6 | =head1 NAME |
7 | ||
8 | Porting/pod_lib.pl - functions for building and installing POD | |
9 | ||
10 | =head1 SYNOPSIS | |
11 | ||
12 | require './Porting/pod_lib.pl'; | |
13 | ||
14 | =cut | |
15 | ||
16 | =head1 DESCRIPTION | |
17 | ||
18 | This program, when C<require>d into other programs in the Perl 5 core | |
19 | distribution, provides functions useful during building and, secondarily, | |
20 | testing. | |
21 | ||
22 | As of this writing, the functions in this program are used in these other | |
23 | programs: | |
24 | ||
25 | installman | |
26 | installperl | |
27 | pod/buildtoc | |
28 | pod/perl.pod | |
29 | Porting/new-perldelta.pl | |
30 | Porting/pod_rules.pl | |
31 | ||
32 | Note: Since these functions are used during the Perl build process, they must | |
33 | work with F<miniperl>. That necessarily implies that these functions must not | |
34 | rely on XS modules, either directly or indirectly (e.g., C<autodie>). | |
35 | ||
36 | =head1 SUBROUTINES | |
37 | ||
38 | =head2 C<my_die()> | |
39 | ||
40 | =over 4 | |
41 | ||
42 | =item * Purpose | |
43 | ||
44 | Exit from a process with an error code and a message. | |
45 | ||
46 | =item * Arguments | |
47 | ||
48 | List of arguments to be passed with the error message. Example: | |
49 | ||
50 | close $fh or my_die("close 'utils.lst': $!"); | |
51 | ||
52 | =item * Return Value | |
53 | ||
54 | Exit code C<255>. | |
55 | ||
56 | =item * Comment | |
57 | ||
58 | Prints C<ABORTED> to STDERR. | |
59 | ||
60 | =back | |
61 | ||
62 | =cut | |
d7816c47 | 63 | |
252696ec JR |
64 | # In some situations, eg cross-compiling, we get run with miniperl, so we can't use Digest::MD5 |
65 | my $has_md5; | |
66 | BEGIN { | |
67 | use Carp; | |
68 | $has_md5 = eval { require Digest::MD5; Digest::MD5->import('md5'); 1; }; | |
69 | } | |
70 | ||
71 | ||
72 | # make it clearer when we haven't run to completion, as we can be quite | |
73 | # noisy when things are working ok | |
74 | ||
d7816c47 NC |
75 | sub my_die { |
76 | print STDERR "$0: ", @_; | |
77 | print STDERR "\n" unless $_[-1] =~ /\n\z/; | |
78 | print STDERR "ABORTED\n"; | |
79 | exit 255; | |
80 | } | |
81 | ||
1e62a62d JK |
82 | =head2 C<open_or_die()> |
83 | ||
84 | =over 4 | |
85 | ||
86 | =item * Purpose | |
87 | ||
88 | Opens a file or fails if it cannot. | |
89 | ||
90 | =item * Arguments | |
91 | ||
92 | String holding filename to be opened. Example: | |
93 | ||
94 | $fh = open_or_die('utils.lst'); | |
95 | ||
96 | =item * Return Value | |
97 | ||
98 | Handle to opened file. | |
99 | ||
100 | =back | |
101 | ||
102 | =cut | |
103 | ||
d7816c47 NC |
104 | sub open_or_die { |
105 | my $filename = shift; | |
106 | open my $fh, '<', $filename or my_die "Can't open $filename: $!"; | |
107 | return $fh; | |
108 | } | |
109 | ||
1e62a62d JK |
110 | =head2 C<slurp_or_die()> |
111 | ||
112 | =over 4 | |
113 | ||
114 | =item * Purpose | |
115 | ||
116 | Read the contents of a file into memory as a single string. | |
117 | ||
118 | =item * Arguments | |
119 | ||
120 | String holding name of file to be read into memory. | |
121 | ||
122 | $olddelta = slurp_or_die('pod/perldelta.pod'); | |
123 | ||
124 | =item * Return Value | |
125 | ||
126 | String holding contents of file. | |
127 | ||
128 | =back | |
129 | ||
130 | =cut | |
131 | ||
bcfe7366 NC |
132 | sub slurp_or_die { |
133 | my $filename = shift; | |
134 | my $fh = open_or_die($filename); | |
135 | binmode $fh; | |
136 | local $/; | |
137 | my $contents = <$fh>; | |
138 | die "Can't read $filename: $!" unless defined $contents and close $fh; | |
139 | return $contents; | |
140 | } | |
141 | ||
1e62a62d JK |
142 | =head2 C<write_or_die()> |
143 | ||
144 | =over 4 | |
145 | ||
146 | =item * Purpose | |
147 | ||
148 | Write out a string to a file. | |
149 | ||
150 | =item * Arguments | |
151 | ||
152 | List of two arguments: (i) String holding name of file to be written to; (ii) | |
153 | String holding contents to be written. | |
154 | ||
155 | write_or_die($olddeltaname, $olddelta); | |
156 | ||
157 | =item * Return Value | |
158 | ||
159 | Implicitly returns true value upon success. | |
160 | ||
161 | =back | |
162 | ||
163 | =cut | |
164 | ||
bcfe7366 NC |
165 | sub write_or_die { |
166 | my ($filename, $contents) = @_; | |
167 | open my $fh, '>', $filename or die "Can't open $filename for writing: $!"; | |
168 | binmode $fh; | |
169 | print $fh $contents or die "Can't write to $filename: $!"; | |
170 | close $fh or die "Can't close $filename: $!"; | |
171 | } | |
172 | ||
93b1bf68 NC |
173 | =head2 C<verify_contiguous()> |
174 | ||
175 | =over 4 | |
176 | ||
177 | =item * Purpose | |
178 | ||
76f5a288 JK |
179 | Verify that a makefile or makefile constructor contains exactly one contiguous |
180 | run of lines which matches a given pattern. C<croak()>s if the pattern is not | |
181 | found, or found in more than one place. | |
182 | ||
183 | By "makefile or makefile constructor" we mean a file which is one of the | |
184 | right-hand values in this list of key-value pairs: | |
185 | ||
186 | manifest => 'MANIFEST', | |
187 | vms => 'vms/descrip_mms.template', | |
188 | nmake => 'win32/Makefile', | |
76f5a288 JK |
189 | gmake => 'win32/GNUmakefile', |
190 | podmak => 'win32/pod.mak', | |
191 | unix => 'Makefile.SH', | |
192 | ||
193 | (Currently found in C<%Targets> in F<Porting/pod_rules.pl>.) | |
93b1bf68 NC |
194 | |
195 | =item * Arguments | |
196 | ||
197 | =over 4 | |
198 | ||
76f5a288 JK |
199 | =item * Name of target |
200 | ||
201 | String holding the key of one element in C<%Targets> in F<Porting/pod_rules.pl>. | |
93b1bf68 NC |
202 | |
203 | =item * Contents of file | |
204 | ||
76f5a288 JK |
205 | String holding slurped contents of the file named in the value of the element |
206 | in C<%Targets> in F<Porting/pod_rules.pl> named in the first argument. | |
207 | ||
93b1bf68 NC |
208 | =item * Pattern of interest |
209 | ||
76f5a288 JK |
210 | Compiled regular expression pertinent to a particular makefile constructor. |
211 | ||
93b1bf68 NC |
212 | =item * Name to report on error |
213 | ||
76f5a288 JK |
214 | String holding description. |
215 | ||
93b1bf68 NC |
216 | =back |
217 | ||
218 | =item * Return Value | |
219 | ||
220 | The contents of the file, with C<qr/\0+/> substituted for the pattern. | |
221 | ||
76f5a288 JK |
222 | =item * Example (drawn from F<Porting/pod_rules.pl> C<do_unix()>): |
223 | ||
224 | my $makefile_SH = slurp_or_die('./Makefile.SH'); | |
225 | my $re = qr/some\s+pattern/; | |
226 | my $makefile_SH_out = | |
227 | verify_contiguous('unix', $makefile_SH, $re, 'copy rules'); | |
228 | ||
93b1bf68 NC |
229 | =back |
230 | ||
231 | =cut | |
232 | ||
233 | sub verify_contiguous { | |
234 | my ($name, $content, $re, $what) = @_; | |
235 | require Carp; | |
236 | $content =~ s/$re/\0/g; | |
237 | my $sections = () = $content =~ m/\0+/g; | |
238 | Carp::croak("$0: $name contains no $what") if $sections < 1; | |
239 | Carp::croak("$0: $name contains discontiguous $what") if $sections > 1; | |
240 | return $content; | |
241 | } | |
242 | ||
244a7751 NC |
243 | =head2 C<process()> |
244 | ||
245 | =over 4 | |
246 | ||
247 | =item * Purpose | |
248 | ||
249 | Read a file from disk, pass the contents to the callback, and either update | |
250 | the file on disk (if changed) or generate TAP output to confirm that the | |
251 | version on disk is up to date. C<die>s if the file contains any C<NUL> bytes. | |
252 | This permits the callback routine to use C<NUL> bytes as placeholders while | |
253 | manipulating the file's contents. | |
254 | ||
255 | =item * Arguments | |
256 | ||
257 | =over 4 | |
258 | ||
259 | =item * Description for use in error messages | |
260 | ||
261 | =item * Name of file | |
262 | ||
263 | =item * Callback | |
264 | ||
265 | Passed description and file contents, should return updated file contents. | |
266 | ||
267 | =item * Test number | |
268 | ||
269 | If defined, generate TAP output to C<STDOUT>. If defined and false, generate | |
270 | an unnumbered test. Otherwise this is the test number in the I<ok> line. | |
271 | ||
272 | =item * Verbose flag | |
273 | ||
274 | If true, generate verbose output. | |
275 | ||
276 | =back | |
277 | ||
278 | =item * Return Value | |
279 | ||
280 | Does not return anything. | |
281 | ||
282 | =back | |
283 | ||
284 | =cut | |
285 | ||
286 | sub process { | |
287 | my ($desc, $filename, $callback, $test, $verbose) = @_; | |
288 | ||
289 | print "Now processing $filename\n" if $verbose; | |
290 | my $orig = slurp_or_die($filename); | |
291 | my_die "$filename contains NUL bytes" if $orig =~ /\0/; | |
292 | ||
293 | my $new = $callback->($desc, $orig); | |
294 | ||
295 | if (defined $test) { | |
296 | printf "%s%s # $filename is up to date\n", | |
297 | ($new eq $orig ? 'ok' : 'not ok'), ($test ? " $test" : ''); | |
298 | return; | |
299 | } elsif ($new eq $orig) { | |
300 | print "Was not modified\n" | |
301 | if $verbose; | |
302 | return; | |
303 | } | |
304 | ||
305 | my $mode = (stat $filename)[2]; | |
306 | my_die "Can't stat $filename: $!" | |
307 | unless defined $mode; | |
308 | rename $filename, "$filename.old" | |
309 | or my_die "Can't rename $filename to $filename.old: $!"; | |
310 | ||
311 | write_or_die($filename, $new); | |
312 | chmod $mode & 0777, $filename or my_die "can't chmod $mode $filename: $!"; | |
313 | } | |
314 | ||
1e62a62d JK |
315 | =head2 C<pods_to_install()> |
316 | ||
317 | =over 4 | |
318 | ||
319 | =item * Purpose | |
320 | ||
321 | Create a lookup table holding information about PODs to be installed. | |
322 | ||
323 | =item * Arguments | |
324 | ||
325 | None. | |
326 | ||
327 | =item * Return Value | |
328 | ||
329 | Reference to a hash with a structure like this: | |
330 | ||
331 | $found = { | |
332 | 'MODULE' => { | |
333 | 'CPAN::Bundle' => 'lib/CPAN/Bundle.pm', | |
334 | 'Locale::Codes::Script_Retired' => | |
335 | 'lib/Locale/Codes/Script_Retired.pm', | |
336 | 'Pod::Simple::DumpAsText' => | |
337 | 'lib/Pod/Simple/DumpAsText.pm', | |
338 | # ... | |
339 | 'Locale::Codes::LangVar' => | |
340 | 'lib/Locale/Codes/LangVar.pod' | |
341 | }, | |
342 | 'PRAGMA' => { | |
343 | 'fields' => 'lib/fields.pm', | |
344 | 'subs' => 'lib/subs.pm', | |
345 | # ... | |
346 | }, | |
347 | ||
348 | =item * Comment | |
349 | ||
350 | Broadly speaking, the function assembles a list of all F<.pm> and F<.pod> | |
351 | files in the distribution and then excludes certain files from installation. | |
352 | ||
353 | =back | |
354 | ||
355 | =cut | |
356 | ||
9bbb230a NC |
357 | sub pods_to_install { |
358 | # manpages not to be installed | |
359 | my %do_not_install = map { ($_ => 1) } | |
360 | qw(Pod::Functions XS::APItest XS::Typemap); | |
a04fd069 TC |
361 | $do_not_install{"ExtUtils::XSSymSet"} = 1 |
362 | unless $^O eq "VMS"; | |
9bbb230a NC |
363 | |
364 | my (%done, %found); | |
365 | ||
366 | File::Find::find({no_chdir=>1, | |
367 | wanted => sub { | |
65e5b016 NC |
368 | if (m!/t\z!) { |
369 | ++$File::Find::prune; | |
370 | return; | |
371 | } | |
372 | ||
9bbb230a NC |
373 | # $_ is $File::Find::name when using no_chdir |
374 | return unless m!\.p(?:m|od)\z! && -f $_; | |
9bbb230a NC |
375 | return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-) |
376 | # Skip .pm files that have corresponding .pod files | |
377 | return if s!\.pm\z!.pod! && -e $_; | |
378 | s!\.pod\z!!; | |
379 | s!\Alib/!!; | |
380 | s!/!::!g; | |
381 | ||
382 | my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'") | |
383 | if exists $done{$_}; | |
384 | $done{$_} = $File::Find::name; | |
385 | ||
386 | return if $do_not_install{$_}; | |
387 | return if is_duplicate_pod($File::Find::name); | |
388 | $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_} | |
389 | = $File::Find::name; | |
390 | }}, 'lib'); | |
391 | return \%found; | |
392 | } | |
9887f448 NC |
393 | |
394 | my %state = ( | |
395 | # Don't copy these top level READMEs | |
396 | ignore => { | |
397 | micro => 1, | |
398 | # vms => 1, | |
399 | }, | |
400 | ); | |
401 | ||
4027e27b NC |
402 | { |
403 | my (%Lengths, %MD5s); | |
404 | ||
405 | sub is_duplicate_pod { | |
406 | my $file = shift; | |
75d90f49 | 407 | local $_; |
4027e27b | 408 | |
252696ec JR |
409 | return if !$has_md5; |
410 | ||
4027e27b NC |
411 | # Initialise the list of possible source files on the first call. |
412 | unless (%Lengths) { | |
413 | __prime_state() unless $state{master}; | |
414 | foreach (@{$state{master}}) { | |
2ce3647c | 415 | next unless $_->[2]{dual}; |
4027e27b NC |
416 | # This is a dual-life perl*.pod file, which will have be copied |
417 | # to lib/ by the build process, and hence also found there. | |
418 | # These are the only pod files that might become duplicated. | |
2ce3647c NC |
419 | ++$Lengths{-s $_->[1]}; |
420 | ++$MD5s{md5(slurp_or_die($_->[1]))}; | |
4027e27b NC |
421 | } |
422 | } | |
423 | ||
424 | # We are a file in lib. Are we a duplicate? | |
425 | # Don't bother calculating the MD5 if there's no interesting file of | |
426 | # this length. | |
427 | return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))}; | |
428 | } | |
449e2f79 NC |
429 | } |
430 | ||
9887f448 | 431 | sub __prime_state { |
d7816c47 NC |
432 | my $source = 'perldelta.pod'; |
433 | my $filename = "pod/$source"; | |
64587559 | 434 | my $contents = slurp_or_die($filename); |
d7816c47 | 435 | my @want = |
cbc2e172 | 436 | $contents =~ /perldelta - what is new for perl v(\d+)\.(\d+)\.(\d+)\r?\n/; |
d7816c47 | 437 | die "Can't extract version from $filename" unless @want; |
0aef0fe5 NC |
438 | my $delta_leaf = join '', 'perl', @want, 'delta'; |
439 | $state{delta_target} = "$delta_leaf.pod"; | |
bcfe7366 | 440 | $state{delta_version} = \@want; |
d7816c47 NC |
441 | |
442 | # This way round so that keys can act as a MANIFEST skip list | |
443 | # Targets will always be in the pod directory. Currently we can only cope | |
444 | # with sources being in the same directory. | |
445 | $state{copies}{$state{delta_target}} = $source; | |
446 | ||
0aef0fe5 NC |
447 | # The default flags if none explicitly set for the current file. |
448 | my $current_flags = ''; | |
449 | my (%flag_set, @paths); | |
d7816c47 | 450 | |
0aef0fe5 NC |
451 | my $master = open_or_die('pod/perl.pod'); |
452 | ||
453 | while (<$master>) { | |
454 | last if /^=begin buildtoc$/; | |
455 | } | |
456 | die "Can't find '=begin buildtoc':" if eof $master; | |
457 | ||
458 | while (<$master>) { | |
459 | next if /^$/ or /^#/; | |
460 | last if /^=end buildtoc/; | |
461 | my ($command, @args) = split ' '; | |
462 | if ($command eq 'flag') { | |
463 | # For the named pods, use these flags, instead of $current_flags | |
464 | my $flags = shift @args; | |
465 | my_die("Malformed flag $flags") | |
466 | unless $flags =~ /\A=([a-z]*)\z/; | |
467 | $flag_set{$_} = $1 foreach @args; | |
468 | } elsif ($command eq 'path') { | |
469 | # If the pod's name matches the regex, prepend the given path. | |
470 | my_die("Malformed path for /$args[0]/") | |
471 | unless @args == 2; | |
472 | push @paths, [qr/\A$args[0]\z/, $args[1]]; | |
473 | } elsif ($command eq 'aux') { | |
474 | # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section | |
4e604983 | 475 | $state{aux} = [sort @args]; |
0aef0fe5 NC |
476 | } else { |
477 | my_die("Unknown buildtoc command '$command'"); | |
478 | } | |
479 | } | |
d7816c47 NC |
480 | |
481 | foreach (<$master>) { | |
0aef0fe5 NC |
482 | next if /^$/ or /^#/; |
483 | next if /^=head2/; | |
484 | last if /^=for buildtoc __END__$/; | |
485 | ||
486 | if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) { | |
487 | if ($action eq '+') { | |
488 | $current_flags .= $flags; | |
489 | } else { | |
490 | my_die("Attempt to unset [$flags] failed - flags are '$current_flags") | |
491 | unless $current_flags =~ s/[\Q$flags\E]//g; | |
492 | } | |
493 | } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) { | |
494 | my $podname = $leafname; | |
495 | my $filename = "pod/$podname.pod"; | |
496 | foreach (@paths) { | |
497 | my ($re, $path) = @$_; | |
498 | if ($leafname =~ $re) { | |
499 | $podname = $path . $leafname; | |
500 | $filename = "$podname.pod"; | |
501 | last; | |
502 | } | |
503 | } | |
504 | ||
505 | # Keep this compatible with pre-5.10 | |
506 | my $flags = delete $flag_set{$leafname}; | |
507 | $flags = $current_flags unless defined $flags; | |
508 | ||
509 | my %flags; | |
d7816c47 | 510 | $flags{toc_omit} = 1 if $flags =~ tr/o//d; |
dc437300 | 511 | $flags{dual} = $podname ne $leafname; |
d7816c47 NC |
512 | |
513 | $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d; | |
514 | ||
515 | if ($flags =~ tr/r//d) { | |
516 | my $readme = $podname; | |
517 | $readme =~ s/^perl//; | |
64587559 | 518 | $state{readmes}{$readme} = $desc; |
d7816c47 | 519 | $flags{readme} = 1; |
d7816c47 NC |
520 | } else { |
521 | $state{pods}{$podname} = $desc; | |
522 | } | |
523 | my_die "Unknown flag found in section line: $_" if length $flags; | |
449e2f79 | 524 | |
d7816c47 | 525 | push @{$state{master}}, |
2ce3647c | 526 | [$leafname, $filename, \%flags]; |
0aef0fe5 NC |
527 | |
528 | if ($podname eq 'perldelta') { | |
529 | local $" = '.'; | |
0aef0fe5 | 530 | push @{$state{master}}, |
2ce3647c | 531 | [$delta_leaf, "pod/$state{delta_target}"]; |
dc437300 | 532 | $state{pods}{$delta_leaf} = "Perl changes in version @want"; |
0aef0fe5 NC |
533 | } |
534 | ||
d7816c47 | 535 | } else { |
0aef0fe5 | 536 | my_die("Malformed line: $_"); |
d7816c47 NC |
537 | } |
538 | } | |
0aef0fe5 NC |
539 | close $master or my_die("close pod/perl.pod: $!"); |
540 | ||
541 | my_die("perl.pod sets flags for unknown pods: " | |
542 | . join ' ', sort keys %flag_set) | |
543 | if keys %flag_set; | |
9887f448 NC |
544 | } |
545 | ||
1e62a62d JK |
546 | =head2 C<get_pod_metadata()> |
547 | ||
548 | =over 4 | |
549 | ||
550 | =item * Purpose | |
551 | ||
76f5a288 JK |
552 | Create a data structure holding information about files containing text in POD format. |
553 | ||
1e62a62d JK |
554 | =item * Arguments |
555 | ||
556 | List of one or more arguments. | |
557 | ||
558 | =over 4 | |
559 | ||
560 | =item * Boolean true or false | |
561 | ||
730ad6b9 | 562 | =item * Reference to a subroutine. |
1e62a62d JK |
563 | |
564 | =item * Various other arguments. | |
565 | ||
566 | =back | |
567 | ||
568 | Example: | |
569 | ||
570 | $state = get_pod_metadata( | |
571 | 0, sub { warn @_ if @_ }, 'pod/perltoc.pod'); | |
572 | ||
573 | get_pod_metadata( | |
574 | 1, sub { warn @_ if @_ }, values %Build); | |
575 | ||
576 | =item * Return Value | |
577 | ||
578 | Hash reference; each element provides either a list or a lookup table for | |
579 | information about various types of POD files. | |
580 | ||
581 | 'aux' => [ # utility programs like | |
8166b4e0 | 582 | 'h2xs' and 'perldoc' ] |
1e62a62d JK |
583 | 'generated' => { # lookup table for generated POD files |
584 | like 'perlapi.pod' } | |
585 | 'ignore' => { # lookup table for files to be ignored } | |
586 | 'pods' => { # lookup table in "name" => | |
587 | "short description" format } | |
588 | 'readmes' => { # lookup table for OS-specific | |
589 | and other READMEs } | |
590 | 'delta_version' => [ # major version number, minor no., | |
591 | patch no. ] | |
592 | 'delta_target' => 'perl<Mmmpp>delta.pod', | |
593 | 'master' => [ # list holding entries for files callable | |
594 | by 'perldoc' ] | |
595 | 'copies' => { # patch version perldelta => | |
596 | minor version perldelta } | |
597 | ||
76f5a288 JK |
598 | =item * Comment |
599 | ||
600 | Instances where this subroutine is used may be found in these files: | |
601 | ||
602 | pod/buildtoc | |
603 | Porting/new-perldelta.pl | |
604 | Porting/pod_rules.pl | |
605 | ||
1e62a62d JK |
606 | =back |
607 | ||
608 | =cut | |
609 | ||
9887f448 NC |
610 | sub get_pod_metadata { |
611 | # Do we expect to find generated pods on disk? | |
612 | my $permit_missing_generated = shift; | |
613 | # Do they want a consistency report? | |
614 | my $callback = shift; | |
75d90f49 | 615 | local $_; |
d7816c47 | 616 | |
9887f448 | 617 | __prime_state() unless $state{master}; |
d4c6b7ae NC |
618 | return \%state unless $callback; |
619 | ||
9887f448 NC |
620 | my %BuildFiles; |
621 | ||
622 | foreach my $path (@_) { | |
623 | $path =~ m!([^/]+)$!; | |
624 | ++$BuildFiles{$1}; | |
625 | } | |
626 | ||
d7816c47 NC |
627 | # Sanity cross check |
628 | ||
0aef0fe5 | 629 | my (%disk_pods, %manipods, %manireadmes); |
852355fc | 630 | my (%cpanpods, %cpanpods_leaf); |
d7816c47 NC |
631 | my (%our_pods); |
632 | ||
6ca94f41 RGS |
633 | # There are files that we don't want to list in perl.pod. |
634 | # Maybe the various stub manpages should be listed there. | |
635 | my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( ); | |
d7816c47 NC |
636 | |
637 | # Convert these to a list of filenames. | |
64587559 NC |
638 | ++$our_pods{"$_.pod"} foreach keys %{$state{pods}}; |
639 | foreach (@{$state{master}}) { | |
2ce3647c NC |
640 | ++$our_pods{"$_->[0].pod"} |
641 | if $_->[2]{readme}; | |
d7816c47 NC |
642 | } |
643 | ||
644 | opendir my $dh, 'pod'; | |
645 | while (defined ($_ = readdir $dh)) { | |
646 | next unless /\.pod\z/; | |
d7816c47 NC |
647 | ++$disk_pods{$_}; |
648 | } | |
649 | ||
650 | # Things we copy from won't be in perl.pod | |
651 | # Things we copy to won't be in MANIFEST | |
652 | ||
653 | my $mani = open_or_die('MANIFEST'); | |
654 | while (<$mani>) { | |
655 | chomp; | |
656 | s/\s+.*$//; | |
657 | if (m!^pod/([^.]+\.pod)!i) { | |
6fdb59a5 | 658 | ++$manipods{$1}; |
d7816c47 NC |
659 | } elsif (m!^README\.(\S+)!i) { |
660 | next if $state{ignore}{$1}; | |
6fdb59a5 | 661 | ++$manireadmes{"perl$1.pod"}; |
d7816c47 | 662 | } elsif (exists $our_pods{$_}) { |
852355fc NC |
663 | ++$cpanpods{$_}; |
664 | m!([^/]+)$!; | |
665 | ++$cpanpods_leaf{$1}; | |
d7816c47 NC |
666 | $disk_pods{$_}++ |
667 | if -e $_; | |
668 | } | |
669 | } | |
670 | close $mani or my_die "close MANIFEST: $!\n"; | |
671 | ||
c26a697b NC |
672 | # Are we running before known generated files have been generated? |
673 | # (eg in a clean checkout) | |
674 | my %not_yet_there; | |
675 | if ($permit_missing_generated) { | |
676 | # If so, don't complain if these files aren't yet in place | |
677 | %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}}) | |
678 | } | |
679 | ||
d7816c47 NC |
680 | my @inconsistent; |
681 | foreach my $i (sort keys %disk_pods) { | |
682 | push @inconsistent, "$0: $i exists but is unknown by buildtoc\n" | |
6ca94f41 | 683 | unless $our_pods{$i} || $ignoredpods{$i}; |
d7816c47 | 684 | push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n" |
9e241592 NC |
685 | if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST |
686 | && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i} | |
687 | && !$state{generated}{$i} && !$cpanpods{$i}; | |
d7816c47 NC |
688 | } |
689 | foreach my $i (sort keys %our_pods) { | |
690 | push @inconsistent, "$0: $i is known by buildtoc but does not exist\n" | |
c26a697b | 691 | unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i}; |
d7816c47 | 692 | } |
9e241592 NC |
693 | unless ($BuildFiles{'MANIFEST'}) { |
694 | # Again, ignore these if we're about to rebuild MANIFEST | |
695 | foreach my $i (sort keys %manipods) { | |
696 | push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n" | |
697 | unless $disk_pods{$i}; | |
698 | push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n" | |
699 | if $state{generated}{$i}; | |
700 | } | |
d7816c47 | 701 | } |
d4c6b7ae | 702 | &$callback(@inconsistent); |
d7816c47 NC |
703 | return \%state; |
704 | } | |
705 | ||
706 | 1; | |
707 | ||
d7816c47 | 708 | # ex: set ts=8 sts=4 sw=4 et: |