8 Porting/pod_lib.pl - functions for building and installing POD
12 require './Porting/pod_lib.pl';
18 This program, when C<require>d into other programs in the Perl 5 core
19 distribution, provides functions useful during building and, secondarily,
22 As of this writing, the functions in this program are used in these other
29 Porting/new-perldelta.pl
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>).
44 Exit from a process with an error code and a message.
48 List of arguments to be passed with the error message. Example:
50 close $fh or my_die("close 'utils.lst': $!");
58 Prints C<ABORTED> to STDERR.
64 # In some situations, eg cross-compiling, we get run with miniperl, so we can't use Digest::MD5
68 $has_md5 = eval { require Digest::MD5; Digest::MD5->import('md5'); 1; };
72 # make it clearer when we haven't run to completion, as we can be quite
73 # noisy when things are working ok
76 print STDERR "$0: ", @_;
77 print STDERR "\n" unless $_[-1] =~ /\n\z/;
78 print STDERR "ABORTED\n";
82 =head2 C<open_or_die()>
88 Opens a file or fails if it cannot.
92 String holding filename to be opened. Example:
94 $fh = open_or_die('utils.lst');
98 Handle to opened file.
105 my $filename = shift;
106 open my $fh, '<', $filename or my_die "Can't open $filename: $!";
110 =head2 C<slurp_or_die()>
116 Read the contents of a file into memory as a single string.
120 String holding name of file to be read into memory.
122 $olddelta = slurp_or_die('pod/perldelta.pod');
126 String holding contents of file.
133 my $filename = shift;
134 my $fh = open_or_die($filename);
137 my $contents = <$fh>;
138 die "Can't read $filename: $!" unless defined $contents and close $fh;
142 =head2 C<write_or_die()>
148 Write out a string to a file.
152 List of two arguments: (i) String holding name of file to be written to; (ii)
153 String holding contents to be written.
155 write_or_die($olddeltaname, $olddelta);
159 Implicitly returns true value upon success.
166 my ($filename, $contents) = @_;
167 open my $fh, '>', $filename or die "Can't open $filename for writing: $!";
169 print $fh $contents or die "Can't write to $filename: $!";
170 close $fh or die "Can't close $filename: $!";
173 =head2 C<verify_contiguous()>
179 Verify that a file contains exactly one contiguous run of lines which matches
180 the passed in pattern. C<croak()>s if the pattern is not found, or found in
189 =item * Contents of file
191 =item * Pattern of interest
193 =item * Name to report on error
199 The contents of the file, with C<qr/\0+/> substituted for the pattern.
205 sub verify_contiguous {
206 my ($name, $content, $re, $what) = @_;
208 $content =~ s/$re/\0/g;
209 my $sections = () = $content =~ m/\0+/g;
210 Carp::croak("$0: $name contains no $what") if $sections < 1;
211 Carp::croak("$0: $name contains discontiguous $what") if $sections > 1;
221 Read a file from disk, pass the contents to the callback, and either update
222 the file on disk (if changed) or generate TAP output to confirm that the
223 version on disk is up to date. C<die>s if the file contains any C<NUL> bytes.
224 This permits the callback routine to use C<NUL> bytes as placeholders while
225 manipulating the file's contents.
231 =item * Description for use in error messages
237 Passed description and file contents, should return updated file contents.
241 If defined, generate TAP output to C<STDOUT>. If defined and false, generate
242 an unnumbered test. Otherwise this is the test number in the I<ok> line.
246 If true, generate verbose output.
252 Does not return anything.
259 my ($desc, $filename, $callback, $test, $verbose) = @_;
261 print "Now processing $filename\n" if $verbose;
262 my $orig = slurp_or_die($filename);
263 my_die "$filename contains NUL bytes" if $orig =~ /\0/;
265 my $new = $callback->($desc, $orig);
268 printf "%s%s # $filename is up to date\n",
269 ($new eq $orig ? 'ok' : 'not ok'), ($test ? " $test" : '');
271 } elsif ($new eq $orig) {
272 print "Was not modified\n"
277 my $mode = (stat $filename)[2];
278 my_die "Can't stat $filename: $!"
279 unless defined $mode;
280 rename $filename, "$filename.old"
281 or my_die "Can't rename $filename to $filename.old: $!";
283 write_or_die($filename, $new);
284 chmod $mode & 0777, $filename or my_die "can't chmod $mode $filename: $!";
287 =head2 C<pods_to_install()>
293 Create a lookup table holding information about PODs to be installed.
301 Reference to a hash with a structure like this:
305 'CPAN::Bundle' => 'lib/CPAN/Bundle.pm',
306 'Locale::Codes::Script_Retired' =>
307 'lib/Locale/Codes/Script_Retired.pm',
308 'Pod::Simple::DumpAsText' =>
309 'lib/Pod/Simple/DumpAsText.pm',
311 'Locale::Codes::LangVar' =>
312 'lib/Locale/Codes/LangVar.pod'
315 'fields' => 'lib/fields.pm',
316 'subs' => 'lib/subs.pm',
322 Broadly speaking, the function assembles a list of all F<.pm> and F<.pod>
323 files in the distribution and then excludes certain files from installation.
329 sub pods_to_install {
330 # manpages not to be installed
331 my %do_not_install = map { ($_ => 1) }
332 qw(Pod::Functions XS::APItest XS::Typemap);
336 File::Find::find({no_chdir=>1,
339 ++$File::Find::prune;
343 # $_ is $File::Find::name when using no_chdir
344 return unless m!\.p(?:m|od)\z! && -f $_;
345 return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-)
346 # Skip .pm files that have corresponding .pod files
347 return if s!\.pm\z!.pod! && -e $_;
352 my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
354 $done{$_} = $File::Find::name;
356 return if $do_not_install{$_};
357 return if is_duplicate_pod($File::Find::name);
358 $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
365 # Don't copy these top level READMEs
373 my (%Lengths, %MD5s);
375 sub is_duplicate_pod {
381 # Initialise the list of possible source files on the first call.
383 __prime_state() unless $state{master};
384 foreach (@{$state{master}}) {
385 next unless $_->[2]{dual};
386 # This is a dual-life perl*.pod file, which will have be copied
387 # to lib/ by the build process, and hence also found there.
388 # These are the only pod files that might become duplicated.
389 ++$Lengths{-s $_->[1]};
390 ++$MD5s{md5(slurp_or_die($_->[1]))};
394 # We are a file in lib. Are we a duplicate?
395 # Don't bother calculating the MD5 if there's no interesting file of
397 return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
402 my $source = 'perldelta.pod';
403 my $filename = "pod/$source";
404 my $contents = slurp_or_die($filename);
406 $contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\n/;
407 die "Can't extract version from $filename" unless @want;
408 my $delta_leaf = join '', 'perl', @want, 'delta';
409 $state{delta_target} = "$delta_leaf.pod";
410 $state{delta_version} = \@want;
412 # This way round so that keys can act as a MANIFEST skip list
413 # Targets will always be in the pod directory. Currently we can only cope
414 # with sources being in the same directory.
415 $state{copies}{$state{delta_target}} = $source;
417 # The default flags if none explicitly set for the current file.
418 my $current_flags = '';
419 my (%flag_set, @paths);
421 my $master = open_or_die('pod/perl.pod');
424 last if /^=begin buildtoc$/;
426 die "Can't find '=begin buildtoc':" if eof $master;
429 next if /^$/ or /^#/;
430 last if /^=end buildtoc/;
431 my ($command, @args) = split ' ';
432 if ($command eq 'flag') {
433 # For the named pods, use these flags, instead of $current_flags
434 my $flags = shift @args;
435 my_die("Malformed flag $flags")
436 unless $flags =~ /\A=([a-z]*)\z/;
437 $flag_set{$_} = $1 foreach @args;
438 } elsif ($command eq 'path') {
439 # If the pod's name matches the regex, prepend the given path.
440 my_die("Malformed path for /$args[0]/")
442 push @paths, [qr/\A$args[0]\z/, $args[1]];
443 } elsif ($command eq 'aux') {
444 # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
445 $state{aux} = [sort @args];
447 my_die("Unknown buildtoc command '$command'");
451 foreach (<$master>) {
452 next if /^$/ or /^#/;
454 last if /^=for buildtoc __END__$/;
456 if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
457 if ($action eq '+') {
458 $current_flags .= $flags;
460 my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
461 unless $current_flags =~ s/[\Q$flags\E]//g;
463 } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
464 my $podname = $leafname;
465 my $filename = "pod/$podname.pod";
467 my ($re, $path) = @$_;
468 if ($leafname =~ $re) {
469 $podname = $path . $leafname;
470 $filename = "$podname.pod";
475 # Keep this compatible with pre-5.10
476 my $flags = delete $flag_set{$leafname};
477 $flags = $current_flags unless defined $flags;
480 $flags{toc_omit} = 1 if $flags =~ tr/o//d;
481 $flags{dual} = $podname ne $leafname;
483 $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
485 if ($flags =~ tr/r//d) {
486 my $readme = $podname;
487 $readme =~ s/^perl//;
488 $state{readmes}{$readme} = $desc;
491 $state{pods}{$podname} = $desc;
493 my_die "Unknown flag found in section line: $_" if length $flags;
495 push @{$state{master}},
496 [$leafname, $filename, \%flags];
498 if ($podname eq 'perldelta') {
500 push @{$state{master}},
501 [$delta_leaf, "pod/$state{delta_target}"];
502 $state{pods}{$delta_leaf} = "Perl changes in version @want";
506 my_die("Malformed line: $_");
509 close $master or my_die("close pod/perl.pod: $!");
511 my_die("perl.pod sets flags for unknown pods: "
512 . join ' ', sort keys %flag_set)
516 =head2 C<get_pod_metadata()>
524 List of one or more arguments.
528 =item * Boolean true or false
530 =item * Reference to a subroutine.
532 =item * Various other arguments.
538 $state = get_pod_metadata(
539 0, sub { warn @_ if @_ }, 'pod/perltoc.pod');
542 1, sub { warn @_ if @_ }, values %Build);
546 Hash reference; each element provides either a list or a lookup table for
547 information about various types of POD files.
549 'aux' => [ # utility programs like
550 'h2xs' and 'perlbug' ]
551 'generated' => { # lookup table for generated POD files
553 'ignore' => { # lookup table for files to be ignored }
554 'pods' => { # lookup table in "name" =>
555 "short description" format }
556 'readmes' => { # lookup table for OS-specific
558 'delta_version' => [ # major version number, minor no.,
560 'delta_target' => 'perl<Mmmpp>delta.pod',
561 'master' => [ # list holding entries for files callable
563 'copies' => { # patch version perldelta =>
564 minor version perldelta }
570 sub get_pod_metadata {
571 # Do we expect to find generated pods on disk?
572 my $permit_missing_generated = shift;
573 # Do they want a consistency report?
574 my $callback = shift;
577 __prime_state() unless $state{master};
578 return \%state unless $callback;
582 foreach my $path (@_) {
583 $path =~ m!([^/]+)$!;
589 my (%disk_pods, %manipods, %manireadmes);
590 my (%cpanpods, %cpanpods_leaf);
593 # There are files that we don't want to list in perl.pod.
594 # Maybe the various stub manpages should be listed there.
595 my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( );
597 # Convert these to a list of filenames.
598 ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
599 foreach (@{$state{master}}) {
600 ++$our_pods{"$_->[0].pod"}
604 opendir my $dh, 'pod';
605 while (defined ($_ = readdir $dh)) {
606 next unless /\.pod\z/;
610 # Things we copy from won't be in perl.pod
611 # Things we copy to won't be in MANIFEST
613 my $mani = open_or_die('MANIFEST');
617 if (m!^pod/([^.]+\.pod)!i) {
619 } elsif (m!^README\.(\S+)!i) {
620 next if $state{ignore}{$1};
621 ++$manireadmes{"perl$1.pod"};
622 } elsif (exists $our_pods{$_}) {
625 ++$cpanpods_leaf{$1};
630 close $mani or my_die "close MANIFEST: $!\n";
632 # Are we running before known generated files have been generated?
633 # (eg in a clean checkout)
635 if ($permit_missing_generated) {
636 # If so, don't complain if these files aren't yet in place
637 %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
641 foreach my $i (sort keys %disk_pods) {
642 push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
643 unless $our_pods{$i} || $ignoredpods{$i};
644 push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
645 if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
646 && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
647 && !$state{generated}{$i} && !$cpanpods{$i};
649 foreach my $i (sort keys %our_pods) {
650 push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
651 unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
653 unless ($BuildFiles{'MANIFEST'}) {
654 # Again, ignore these if we're about to rebuild MANIFEST
655 foreach my $i (sort keys %manipods) {
656 push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
657 unless $disk_pods{$i};
658 push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
659 if $state{generated}{$i};
662 &$callback(@inconsistent);
668 # ex: set ts=8 sts=4 sw=4 et: