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 | 6 | |
1e62a62d JK |
7 | =head1 NAME |
8 | ||
9 | Porting/pod_lib.pl - functions for building and installing POD | |
10 | ||
11 | =head1 SYNOPSIS | |
12 | ||
13 | require './Porting/pod_lib.pl'; | |
14 | ||
15 | =cut | |
16 | ||
17 | =head1 DESCRIPTION | |
18 | ||
19 | This program, when C<require>d into other programs in the Perl 5 core | |
20 | distribution, provides functions useful during building and, secondarily, | |
21 | testing. | |
22 | ||
23 | As of this writing, the functions in this program are used in these other | |
24 | programs: | |
25 | ||
26 | installman | |
27 | installperl | |
28 | pod/buildtoc | |
29 | pod/perl.pod | |
30 | Porting/new-perldelta.pl | |
31 | Porting/pod_rules.pl | |
32 | ||
33 | Note: Since these functions are used during the Perl build process, they must | |
34 | work with F<miniperl>. That necessarily implies that these functions must not | |
35 | rely on XS modules, either directly or indirectly (e.g., C<autodie>). | |
36 | ||
37 | =head1 SUBROUTINES | |
38 | ||
39 | =head2 C<my_die()> | |
40 | ||
41 | =over 4 | |
42 | ||
43 | =item * Purpose | |
44 | ||
45 | Exit from a process with an error code and a message. | |
46 | ||
47 | =item * Arguments | |
48 | ||
49 | List of arguments to be passed with the error message. Example: | |
50 | ||
51 | close $fh or my_die("close 'utils.lst': $!"); | |
52 | ||
53 | =item * Return Value | |
54 | ||
55 | Exit code C<255>. | |
56 | ||
57 | =item * Comment | |
58 | ||
59 | Prints C<ABORTED> to STDERR. | |
60 | ||
61 | =back | |
62 | ||
63 | =cut | |
d7816c47 NC |
64 | |
65 | sub my_die { | |
66 | print STDERR "$0: ", @_; | |
67 | print STDERR "\n" unless $_[-1] =~ /\n\z/; | |
68 | print STDERR "ABORTED\n"; | |
69 | exit 255; | |
70 | } | |
71 | ||
1e62a62d JK |
72 | =head2 C<open_or_die()> |
73 | ||
74 | =over 4 | |
75 | ||
76 | =item * Purpose | |
77 | ||
78 | Opens a file or fails if it cannot. | |
79 | ||
80 | =item * Arguments | |
81 | ||
82 | String holding filename to be opened. Example: | |
83 | ||
84 | $fh = open_or_die('utils.lst'); | |
85 | ||
86 | =item * Return Value | |
87 | ||
88 | Handle to opened file. | |
89 | ||
90 | =back | |
91 | ||
92 | =cut | |
93 | ||
d7816c47 NC |
94 | sub open_or_die { |
95 | my $filename = shift; | |
96 | open my $fh, '<', $filename or my_die "Can't open $filename: $!"; | |
97 | return $fh; | |
98 | } | |
99 | ||
1e62a62d JK |
100 | =head2 C<slurp_or_die()> |
101 | ||
102 | =over 4 | |
103 | ||
104 | =item * Purpose | |
105 | ||
106 | Read the contents of a file into memory as a single string. | |
107 | ||
108 | =item * Arguments | |
109 | ||
110 | String holding name of file to be read into memory. | |
111 | ||
112 | $olddelta = slurp_or_die('pod/perldelta.pod'); | |
113 | ||
114 | =item * Return Value | |
115 | ||
116 | String holding contents of file. | |
117 | ||
118 | =back | |
119 | ||
120 | =cut | |
121 | ||
bcfe7366 NC |
122 | sub slurp_or_die { |
123 | my $filename = shift; | |
124 | my $fh = open_or_die($filename); | |
125 | binmode $fh; | |
126 | local $/; | |
127 | my $contents = <$fh>; | |
128 | die "Can't read $filename: $!" unless defined $contents and close $fh; | |
129 | return $contents; | |
130 | } | |
131 | ||
1e62a62d JK |
132 | =head2 C<write_or_die()> |
133 | ||
134 | =over 4 | |
135 | ||
136 | =item * Purpose | |
137 | ||
138 | Write out a string to a file. | |
139 | ||
140 | =item * Arguments | |
141 | ||
142 | List of two arguments: (i) String holding name of file to be written to; (ii) | |
143 | String holding contents to be written. | |
144 | ||
145 | write_or_die($olddeltaname, $olddelta); | |
146 | ||
147 | =item * Return Value | |
148 | ||
149 | Implicitly returns true value upon success. | |
150 | ||
151 | =back | |
152 | ||
153 | =cut | |
154 | ||
bcfe7366 NC |
155 | sub write_or_die { |
156 | my ($filename, $contents) = @_; | |
157 | open my $fh, '>', $filename or die "Can't open $filename for writing: $!"; | |
158 | binmode $fh; | |
159 | print $fh $contents or die "Can't write to $filename: $!"; | |
160 | close $fh or die "Can't close $filename: $!"; | |
161 | } | |
162 | ||
1e62a62d JK |
163 | =head2 C<pods_to_install()> |
164 | ||
165 | =over 4 | |
166 | ||
167 | =item * Purpose | |
168 | ||
169 | Create a lookup table holding information about PODs to be installed. | |
170 | ||
171 | =item * Arguments | |
172 | ||
173 | None. | |
174 | ||
175 | =item * Return Value | |
176 | ||
177 | Reference to a hash with a structure like this: | |
178 | ||
179 | $found = { | |
180 | 'MODULE' => { | |
181 | 'CPAN::Bundle' => 'lib/CPAN/Bundle.pm', | |
182 | 'Locale::Codes::Script_Retired' => | |
183 | 'lib/Locale/Codes/Script_Retired.pm', | |
184 | 'Pod::Simple::DumpAsText' => | |
185 | 'lib/Pod/Simple/DumpAsText.pm', | |
186 | # ... | |
187 | 'Locale::Codes::LangVar' => | |
188 | 'lib/Locale/Codes/LangVar.pod' | |
189 | }, | |
190 | 'PRAGMA' => { | |
191 | 'fields' => 'lib/fields.pm', | |
192 | 'subs' => 'lib/subs.pm', | |
193 | # ... | |
194 | }, | |
195 | ||
196 | =item * Comment | |
197 | ||
198 | Broadly speaking, the function assembles a list of all F<.pm> and F<.pod> | |
199 | files in the distribution and then excludes certain files from installation. | |
200 | ||
201 | =back | |
202 | ||
203 | =cut | |
204 | ||
9bbb230a NC |
205 | sub pods_to_install { |
206 | # manpages not to be installed | |
207 | my %do_not_install = map { ($_ => 1) } | |
208 | qw(Pod::Functions XS::APItest XS::Typemap); | |
209 | ||
210 | my (%done, %found); | |
211 | ||
212 | File::Find::find({no_chdir=>1, | |
213 | wanted => sub { | |
65e5b016 NC |
214 | if (m!/t\z!) { |
215 | ++$File::Find::prune; | |
216 | return; | |
217 | } | |
218 | ||
9bbb230a NC |
219 | # $_ is $File::Find::name when using no_chdir |
220 | return unless m!\.p(?:m|od)\z! && -f $_; | |
9bbb230a NC |
221 | return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-) |
222 | # Skip .pm files that have corresponding .pod files | |
223 | return if s!\.pm\z!.pod! && -e $_; | |
224 | s!\.pod\z!!; | |
225 | s!\Alib/!!; | |
226 | s!/!::!g; | |
227 | ||
228 | my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'") | |
229 | if exists $done{$_}; | |
230 | $done{$_} = $File::Find::name; | |
231 | ||
232 | return if $do_not_install{$_}; | |
233 | return if is_duplicate_pod($File::Find::name); | |
234 | $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_} | |
235 | = $File::Find::name; | |
236 | }}, 'lib'); | |
237 | return \%found; | |
238 | } | |
9887f448 NC |
239 | |
240 | my %state = ( | |
241 | # Don't copy these top level READMEs | |
242 | ignore => { | |
243 | micro => 1, | |
244 | # vms => 1, | |
245 | }, | |
246 | ); | |
247 | ||
4027e27b NC |
248 | { |
249 | my (%Lengths, %MD5s); | |
250 | ||
251 | sub is_duplicate_pod { | |
252 | my $file = shift; | |
75d90f49 | 253 | local $_; |
4027e27b NC |
254 | |
255 | # Initialise the list of possible source files on the first call. | |
256 | unless (%Lengths) { | |
257 | __prime_state() unless $state{master}; | |
258 | foreach (@{$state{master}}) { | |
2ce3647c | 259 | next unless $_->[2]{dual}; |
4027e27b NC |
260 | # This is a dual-life perl*.pod file, which will have be copied |
261 | # to lib/ by the build process, and hence also found there. | |
262 | # These are the only pod files that might become duplicated. | |
2ce3647c NC |
263 | ++$Lengths{-s $_->[1]}; |
264 | ++$MD5s{md5(slurp_or_die($_->[1]))}; | |
4027e27b NC |
265 | } |
266 | } | |
267 | ||
268 | # We are a file in lib. Are we a duplicate? | |
269 | # Don't bother calculating the MD5 if there's no interesting file of | |
270 | # this length. | |
271 | return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))}; | |
272 | } | |
449e2f79 NC |
273 | } |
274 | ||
9887f448 | 275 | sub __prime_state { |
d7816c47 NC |
276 | my $source = 'perldelta.pod'; |
277 | my $filename = "pod/$source"; | |
64587559 | 278 | my $contents = slurp_or_die($filename); |
d7816c47 | 279 | my @want = |
bcfe7366 | 280 | $contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\n/; |
d7816c47 | 281 | die "Can't extract version from $filename" unless @want; |
0aef0fe5 NC |
282 | my $delta_leaf = join '', 'perl', @want, 'delta'; |
283 | $state{delta_target} = "$delta_leaf.pod"; | |
bcfe7366 | 284 | $state{delta_version} = \@want; |
d7816c47 NC |
285 | |
286 | # This way round so that keys can act as a MANIFEST skip list | |
287 | # Targets will always be in the pod directory. Currently we can only cope | |
288 | # with sources being in the same directory. | |
289 | $state{copies}{$state{delta_target}} = $source; | |
290 | ||
0aef0fe5 NC |
291 | # The default flags if none explicitly set for the current file. |
292 | my $current_flags = ''; | |
293 | my (%flag_set, @paths); | |
d7816c47 | 294 | |
0aef0fe5 NC |
295 | my $master = open_or_die('pod/perl.pod'); |
296 | ||
297 | while (<$master>) { | |
298 | last if /^=begin buildtoc$/; | |
299 | } | |
300 | die "Can't find '=begin buildtoc':" if eof $master; | |
301 | ||
302 | while (<$master>) { | |
303 | next if /^$/ or /^#/; | |
304 | last if /^=end buildtoc/; | |
305 | my ($command, @args) = split ' '; | |
306 | if ($command eq 'flag') { | |
307 | # For the named pods, use these flags, instead of $current_flags | |
308 | my $flags = shift @args; | |
309 | my_die("Malformed flag $flags") | |
310 | unless $flags =~ /\A=([a-z]*)\z/; | |
311 | $flag_set{$_} = $1 foreach @args; | |
312 | } elsif ($command eq 'path') { | |
313 | # If the pod's name matches the regex, prepend the given path. | |
314 | my_die("Malformed path for /$args[0]/") | |
315 | unless @args == 2; | |
316 | push @paths, [qr/\A$args[0]\z/, $args[1]]; | |
317 | } elsif ($command eq 'aux') { | |
318 | # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section | |
4e604983 | 319 | $state{aux} = [sort @args]; |
0aef0fe5 NC |
320 | } else { |
321 | my_die("Unknown buildtoc command '$command'"); | |
322 | } | |
323 | } | |
d7816c47 NC |
324 | |
325 | foreach (<$master>) { | |
0aef0fe5 NC |
326 | next if /^$/ or /^#/; |
327 | next if /^=head2/; | |
328 | last if /^=for buildtoc __END__$/; | |
329 | ||
330 | if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) { | |
331 | if ($action eq '+') { | |
332 | $current_flags .= $flags; | |
333 | } else { | |
334 | my_die("Attempt to unset [$flags] failed - flags are '$current_flags") | |
335 | unless $current_flags =~ s/[\Q$flags\E]//g; | |
336 | } | |
337 | } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) { | |
338 | my $podname = $leafname; | |
339 | my $filename = "pod/$podname.pod"; | |
340 | foreach (@paths) { | |
341 | my ($re, $path) = @$_; | |
342 | if ($leafname =~ $re) { | |
343 | $podname = $path . $leafname; | |
344 | $filename = "$podname.pod"; | |
345 | last; | |
346 | } | |
347 | } | |
348 | ||
349 | # Keep this compatible with pre-5.10 | |
350 | my $flags = delete $flag_set{$leafname}; | |
351 | $flags = $current_flags unless defined $flags; | |
352 | ||
353 | my %flags; | |
d7816c47 | 354 | $flags{toc_omit} = 1 if $flags =~ tr/o//d; |
dc437300 | 355 | $flags{dual} = $podname ne $leafname; |
d7816c47 NC |
356 | |
357 | $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d; | |
358 | ||
359 | if ($flags =~ tr/r//d) { | |
360 | my $readme = $podname; | |
361 | $readme =~ s/^perl//; | |
64587559 | 362 | $state{readmes}{$readme} = $desc; |
d7816c47 | 363 | $flags{readme} = 1; |
d7816c47 NC |
364 | } else { |
365 | $state{pods}{$podname} = $desc; | |
366 | } | |
367 | my_die "Unknown flag found in section line: $_" if length $flags; | |
449e2f79 | 368 | |
d7816c47 | 369 | push @{$state{master}}, |
2ce3647c | 370 | [$leafname, $filename, \%flags]; |
0aef0fe5 NC |
371 | |
372 | if ($podname eq 'perldelta') { | |
373 | local $" = '.'; | |
0aef0fe5 | 374 | push @{$state{master}}, |
2ce3647c | 375 | [$delta_leaf, "pod/$state{delta_target}"]; |
dc437300 | 376 | $state{pods}{$delta_leaf} = "Perl changes in version @want"; |
0aef0fe5 NC |
377 | } |
378 | ||
d7816c47 | 379 | } else { |
0aef0fe5 | 380 | my_die("Malformed line: $_"); |
d7816c47 NC |
381 | } |
382 | } | |
0aef0fe5 | 383 | close $master or my_die("close pod/perl.pod: $!"); |
e1aae8e4 NC |
384 | # This has to be special-cased somewhere. Turns out this is cleanest: |
385 | push @{$state{master}}, ['a2p', 'x2p/a2p.pod', {toc_omit => 1}]; | |
0aef0fe5 NC |
386 | |
387 | my_die("perl.pod sets flags for unknown pods: " | |
388 | . join ' ', sort keys %flag_set) | |
389 | if keys %flag_set; | |
9887f448 NC |
390 | } |
391 | ||
1e62a62d JK |
392 | =head2 C<get_pod_metadata()> |
393 | ||
394 | =over 4 | |
395 | ||
396 | =item * Purpose | |
397 | ||
398 | =item * Arguments | |
399 | ||
400 | List of one or more arguments. | |
401 | ||
402 | =over 4 | |
403 | ||
404 | =item * Boolean true or false | |
405 | ||
730ad6b9 | 406 | =item * Reference to a subroutine. |
1e62a62d JK |
407 | |
408 | =item * Various other arguments. | |
409 | ||
410 | =back | |
411 | ||
412 | Example: | |
413 | ||
414 | $state = get_pod_metadata( | |
415 | 0, sub { warn @_ if @_ }, 'pod/perltoc.pod'); | |
416 | ||
417 | get_pod_metadata( | |
418 | 1, sub { warn @_ if @_ }, values %Build); | |
419 | ||
420 | =item * Return Value | |
421 | ||
422 | Hash reference; each element provides either a list or a lookup table for | |
423 | information about various types of POD files. | |
424 | ||
425 | 'aux' => [ # utility programs like | |
426 | 'h2xs' and 'perlbug' ] | |
427 | 'generated' => { # lookup table for generated POD files | |
428 | like 'perlapi.pod' } | |
429 | 'ignore' => { # lookup table for files to be ignored } | |
430 | 'pods' => { # lookup table in "name" => | |
431 | "short description" format } | |
432 | 'readmes' => { # lookup table for OS-specific | |
433 | and other READMEs } | |
434 | 'delta_version' => [ # major version number, minor no., | |
435 | patch no. ] | |
436 | 'delta_target' => 'perl<Mmmpp>delta.pod', | |
437 | 'master' => [ # list holding entries for files callable | |
438 | by 'perldoc' ] | |
439 | 'copies' => { # patch version perldelta => | |
440 | minor version perldelta } | |
441 | ||
442 | =back | |
443 | ||
444 | =cut | |
445 | ||
9887f448 NC |
446 | sub get_pod_metadata { |
447 | # Do we expect to find generated pods on disk? | |
448 | my $permit_missing_generated = shift; | |
449 | # Do they want a consistency report? | |
450 | my $callback = shift; | |
75d90f49 | 451 | local $_; |
d7816c47 | 452 | |
9887f448 | 453 | __prime_state() unless $state{master}; |
d4c6b7ae NC |
454 | return \%state unless $callback; |
455 | ||
9887f448 NC |
456 | my %BuildFiles; |
457 | ||
458 | foreach my $path (@_) { | |
459 | $path =~ m!([^/]+)$!; | |
460 | ++$BuildFiles{$1}; | |
461 | } | |
462 | ||
d7816c47 NC |
463 | # Sanity cross check |
464 | ||
0aef0fe5 | 465 | my (%disk_pods, %manipods, %manireadmes); |
852355fc | 466 | my (%cpanpods, %cpanpods_leaf); |
d7816c47 NC |
467 | my (%our_pods); |
468 | ||
6ca94f41 RGS |
469 | # There are files that we don't want to list in perl.pod. |
470 | # Maybe the various stub manpages should be listed there. | |
471 | my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( ); | |
d7816c47 NC |
472 | |
473 | # Convert these to a list of filenames. | |
64587559 NC |
474 | ++$our_pods{"$_.pod"} foreach keys %{$state{pods}}; |
475 | foreach (@{$state{master}}) { | |
2ce3647c NC |
476 | ++$our_pods{"$_->[0].pod"} |
477 | if $_->[2]{readme}; | |
d7816c47 NC |
478 | } |
479 | ||
480 | opendir my $dh, 'pod'; | |
481 | while (defined ($_ = readdir $dh)) { | |
482 | next unless /\.pod\z/; | |
d7816c47 NC |
483 | ++$disk_pods{$_}; |
484 | } | |
485 | ||
486 | # Things we copy from won't be in perl.pod | |
487 | # Things we copy to won't be in MANIFEST | |
488 | ||
489 | my $mani = open_or_die('MANIFEST'); | |
490 | while (<$mani>) { | |
491 | chomp; | |
492 | s/\s+.*$//; | |
493 | if (m!^pod/([^.]+\.pod)!i) { | |
6fdb59a5 | 494 | ++$manipods{$1}; |
d7816c47 NC |
495 | } elsif (m!^README\.(\S+)!i) { |
496 | next if $state{ignore}{$1}; | |
6fdb59a5 | 497 | ++$manireadmes{"perl$1.pod"}; |
d7816c47 | 498 | } elsif (exists $our_pods{$_}) { |
852355fc NC |
499 | ++$cpanpods{$_}; |
500 | m!([^/]+)$!; | |
501 | ++$cpanpods_leaf{$1}; | |
d7816c47 NC |
502 | $disk_pods{$_}++ |
503 | if -e $_; | |
504 | } | |
505 | } | |
506 | close $mani or my_die "close MANIFEST: $!\n"; | |
507 | ||
c26a697b NC |
508 | # Are we running before known generated files have been generated? |
509 | # (eg in a clean checkout) | |
510 | my %not_yet_there; | |
511 | if ($permit_missing_generated) { | |
512 | # If so, don't complain if these files aren't yet in place | |
513 | %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}}) | |
514 | } | |
515 | ||
d7816c47 NC |
516 | my @inconsistent; |
517 | foreach my $i (sort keys %disk_pods) { | |
518 | push @inconsistent, "$0: $i exists but is unknown by buildtoc\n" | |
6ca94f41 | 519 | unless $our_pods{$i} || $ignoredpods{$i}; |
d7816c47 | 520 | push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n" |
9e241592 NC |
521 | if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST |
522 | && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i} | |
523 | && !$state{generated}{$i} && !$cpanpods{$i}; | |
d7816c47 NC |
524 | } |
525 | foreach my $i (sort keys %our_pods) { | |
526 | push @inconsistent, "$0: $i is known by buildtoc but does not exist\n" | |
c26a697b | 527 | unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i}; |
d7816c47 | 528 | } |
9e241592 NC |
529 | unless ($BuildFiles{'MANIFEST'}) { |
530 | # Again, ignore these if we're about to rebuild MANIFEST | |
531 | foreach my $i (sort keys %manipods) { | |
532 | push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n" | |
533 | unless $disk_pods{$i}; | |
534 | push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n" | |
535 | if $state{generated}{$i}; | |
536 | } | |
d7816c47 | 537 | } |
d4c6b7ae | 538 | &$callback(@inconsistent); |
d7816c47 NC |
539 | return \%state; |
540 | } | |
541 | ||
542 | 1; | |
543 | ||
544 | # Local variables: | |
545 | # cperl-indent-level: 4 | |
546 | # indent-tabs-mode: nil | |
547 | # End: | |
548 | # | |
549 | # ex: set ts=8 sts=4 sw=4 et: |