#!/usr/bin/perl -w
use strict;
+use Digest::MD5 'md5';
+use File::Find;
-# make it clearer when we haven't run to completion, as we can be quite
-# noisy when things are working ok
+=head1 NAME
+
+Porting/pod_lib.pl - functions for building and installing POD
+
+=head1 SYNOPSIS
+
+ require './Porting/pod_lib.pl';
+
+=cut
+
+=head1 DESCRIPTION
+
+This program, when C<require>d into other programs in the Perl 5 core
+distribution, provides functions useful during building and, secondarily,
+testing.
+
+As of this writing, the functions in this program are used in these other
+programs:
+
+ installman
+ installperl
+ pod/buildtoc
+ pod/perl.pod
+ Porting/new-perldelta.pl
+ Porting/pod_rules.pl
+
+Note: Since these functions are used during the Perl build process, they must
+work with F<miniperl>. That necessarily implies that these functions must not
+rely on XS modules, either directly or indirectly (e.g., C<autodie>).
+
+=head1 SUBROUTINES
+
+=head2 C<my_die()>
+
+=over 4
+
+=item * Purpose
+
+Exit from a process with an error code and a message.
+
+=item * Arguments
+
+List of arguments to be passed with the error message. Example:
+
+ close $fh or my_die("close 'utils.lst': $!");
+
+=item * Return Value
+
+Exit code C<255>.
+
+=item * Comment
+
+Prints C<ABORTED> to STDERR.
+
+=back
+
+=cut
sub my_die {
print STDERR "$0: ", @_;
exit 255;
}
+=head2 C<open_or_die()>
+
+=over 4
+
+=item * Purpose
+
+Opens a file or fails if it cannot.
+
+=item * Arguments
+
+String holding filename to be opened. Example:
+
+ $fh = open_or_die('utils.lst');
+
+=item * Return Value
+
+Handle to opened file.
+
+=back
+
+=cut
+
sub open_or_die {
my $filename = shift;
open my $fh, '<', $filename or my_die "Can't open $filename: $!";
return $fh;
}
+=head2 C<slurp_or_die()>
+
+=over 4
+
+=item * Purpose
+
+Read the contents of a file into memory as a single string.
+
+=item * Arguments
+
+String holding name of file to be read into memory.
+
+ $olddelta = slurp_or_die('pod/perldelta.pod');
+
+=item * Return Value
+
+String holding contents of file.
+
+=back
+
+=cut
+
sub slurp_or_die {
my $filename = shift;
my $fh = open_or_die($filename);
return $contents;
}
+=head2 C<write_or_die()>
+
+=over 4
+
+=item * Purpose
+
+Write out a string to a file.
+
+=item * Arguments
+
+List of two arguments: (i) String holding name of file to be written to; (ii)
+String holding contents to be written.
+
+ write_or_die($olddeltaname, $olddelta);
+
+=item * Return Value
+
+Implicitly returns true value upon success.
+
+=back
+
+=cut
+
sub write_or_die {
my ($filename, $contents) = @_;
open my $fh, '>', $filename or die "Can't open $filename for writing: $!";
close $fh or die "Can't close $filename: $!";
}
-sub get_pod_metadata {
- # Do we expect to find generated pods on disk?
- my $permit_missing_generated = shift;
- my %BuildFiles;
+=head2 C<verify_contiguous()>
- foreach my $path (@_) {
- $path =~ m!([^/]+)$!;
- ++$BuildFiles{$1};
+=over 4
+
+=item * Purpose
+
+Verify that a file contains exactly one contiguous run of lines which matches
+the passed in pattern. C<croak()>s if the pattern is not found, or found in
+more than one place.
+
+=item * Arguments
+
+=over 4
+
+=item * Name of file
+
+=item * Contents of file
+
+=item * Pattern of interest
+
+=item * Name to report on error
+
+=back
+
+=item * Return Value
+
+The contents of the file, with C<qr/\0+/> substituted for the pattern.
+
+=back
+
+=cut
+
+sub verify_contiguous {
+ my ($name, $content, $re, $what) = @_;
+ require Carp;
+ $content =~ s/$re/\0/g;
+ my $sections = () = $content =~ m/\0+/g;
+ Carp::croak("$0: $name contains no $what") if $sections < 1;
+ Carp::croak("$0: $name contains discontiguous $what") if $sections > 1;
+ return $content;
+}
+
+=head2 C<process()>
+
+=over 4
+
+=item * Purpose
+
+Read a file from disk, pass the contents to the callback, and either update
+the file on disk (if changed) or generate TAP output to confirm that the
+version on disk is up to date. C<die>s if the file contains any C<NUL> bytes.
+This permits the callback routine to use C<NUL> bytes as placeholders while
+manipulating the file's contents.
+
+=item * Arguments
+
+=over 4
+
+=item * Description for use in error messages
+
+=item * Name of file
+
+=item * Callback
+
+Passed description and file contents, should return updated file contents.
+
+=item * Test number
+
+If defined, generate TAP output to C<STDOUT>. If defined and false, generate
+an unnumbered test. Otherwise this is the test number in the I<ok> line.
+
+=item * Verbose flag
+
+If true, generate verbose output.
+
+=back
+
+=item * Return Value
+
+Does not return anything.
+
+=back
+
+=cut
+
+sub process {
+ my ($desc, $filename, $callback, $test, $verbose) = @_;
+
+ print "Now processing $filename\n" if $verbose;
+ my $orig = slurp_or_die($filename);
+ my_die "$filename contains NUL bytes" if $orig =~ /\0/;
+
+ my $new = $callback->($desc, $orig);
+
+ if (defined $test) {
+ printf "%s%s # $filename is up to date\n",
+ ($new eq $orig ? 'ok' : 'not ok'), ($test ? " $test" : '');
+ return;
+ } elsif ($new eq $orig) {
+ print "Was not modified\n"
+ if $verbose;
+ return;
}
- my %state =
- (
- # Don't copy these top level READMEs
- ignore =>
- {
- micro => 1,
- # vms => 1,
- },
- );
+ my $mode = (stat $filename)[2];
+ my_die "Can't stat $filename: $!"
+ unless defined $mode;
+ rename $filename, "$filename.old"
+ or my_die "Can't rename $filename to $filename.old: $!";
+
+ write_or_die($filename, $new);
+ chmod $mode & 0777, $filename or my_die "can't chmod $mode $filename: $!";
+}
+
+=head2 C<pods_to_install()>
+
+=over 4
+
+=item * Purpose
+
+Create a lookup table holding information about PODs to be installed.
+
+=item * Arguments
+
+None.
+
+=item * Return Value
+
+Reference to a hash with a structure like this:
+
+ $found = {
+ 'MODULE' => {
+ 'CPAN::Bundle' => 'lib/CPAN/Bundle.pm',
+ 'Locale::Codes::Script_Retired' =>
+ 'lib/Locale/Codes/Script_Retired.pm',
+ 'Pod::Simple::DumpAsText' =>
+ 'lib/Pod/Simple/DumpAsText.pm',
+ # ...
+ 'Locale::Codes::LangVar' =>
+ 'lib/Locale/Codes/LangVar.pod'
+ },
+ 'PRAGMA' => {
+ 'fields' => 'lib/fields.pm',
+ 'subs' => 'lib/subs.pm',
+ # ...
+ },
+
+=item * Comment
+
+Broadly speaking, the function assembles a list of all F<.pm> and F<.pod>
+files in the distribution and then excludes certain files from installation.
+
+=back
+
+=cut
+
+sub pods_to_install {
+ # manpages not to be installed
+ my %do_not_install = map { ($_ => 1) }
+ qw(Pod::Functions XS::APItest XS::Typemap);
+
+ my (%done, %found);
+ File::Find::find({no_chdir=>1,
+ wanted => sub {
+ if (m!/t\z!) {
+ ++$File::Find::prune;
+ return;
+ }
+
+ # $_ is $File::Find::name when using no_chdir
+ return unless m!\.p(?:m|od)\z! && -f $_;
+ return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-)
+ # Skip .pm files that have corresponding .pod files
+ return if s!\.pm\z!.pod! && -e $_;
+ s!\.pod\z!!;
+ s!\Alib/!!;
+ s!/!::!g;
+
+ my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
+ if exists $done{$_};
+ $done{$_} = $File::Find::name;
+
+ return if $do_not_install{$_};
+ return if is_duplicate_pod($File::Find::name);
+ $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
+ = $File::Find::name;
+ }}, 'lib');
+ return \%found;
+}
+
+my %state = (
+ # Don't copy these top level READMEs
+ ignore => {
+ micro => 1,
+ # vms => 1,
+ },
+ );
+
+{
+ my (%Lengths, %MD5s);
+
+ sub is_duplicate_pod {
+ my $file = shift;
+ local $_;
+
+ # Initialise the list of possible source files on the first call.
+ unless (%Lengths) {
+ __prime_state() unless $state{master};
+ foreach (@{$state{master}}) {
+ next unless $_->[2]{dual};
+ # This is a dual-life perl*.pod file, which will have be copied
+ # to lib/ by the build process, and hence also found there.
+ # These are the only pod files that might become duplicated.
+ ++$Lengths{-s $_->[1]};
+ ++$MD5s{md5(slurp_or_die($_->[1]))};
+ }
+ }
+
+ # We are a file in lib. Are we a duplicate?
+ # Don't bother calculating the MD5 if there's no interesting file of
+ # this length.
+ return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
+ }
+}
+
+sub __prime_state {
my $source = 'perldelta.pod';
my $filename = "pod/$source";
- my $fh = open_or_die($filename);
- my $contents = do {local $/; <$fh>};
+ my $contents = slurp_or_die($filename);
my @want =
$contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\n/;
die "Can't extract version from $filename" unless @want;
- $state{delta_target} = join '', 'perl', @want, 'delta.pod';
+ my $delta_leaf = join '', 'perl', @want, 'delta';
+ $state{delta_target} = "$delta_leaf.pod";
$state{delta_version} = \@want;
# This way round so that keys can act as a MANIFEST skip list
# with sources being in the same directory.
$state{copies}{$state{delta_target}} = $source;
+ # The default flags if none explicitly set for the current file.
+ my $current_flags = '';
+ my (%flag_set, @paths);
- # process pod.lst
- my %Readmepods;
- my $master = open_or_die('pod.lst');
+ my $master = open_or_die('pod/perl.pod');
+
+ while (<$master>) {
+ last if /^=begin buildtoc$/;
+ }
+ die "Can't find '=begin buildtoc':" if eof $master;
+
+ while (<$master>) {
+ next if /^$/ or /^#/;
+ last if /^=end buildtoc/;
+ my ($command, @args) = split ' ';
+ if ($command eq 'flag') {
+ # For the named pods, use these flags, instead of $current_flags
+ my $flags = shift @args;
+ my_die("Malformed flag $flags")
+ unless $flags =~ /\A=([a-z]*)\z/;
+ $flag_set{$_} = $1 foreach @args;
+ } elsif ($command eq 'path') {
+ # If the pod's name matches the regex, prepend the given path.
+ my_die("Malformed path for /$args[0]/")
+ unless @args == 2;
+ push @paths, [qr/\A$args[0]\z/, $args[1]];
+ } elsif ($command eq 'aux') {
+ # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
+ $state{aux} = [sort @args];
+ } else {
+ my_die("Unknown buildtoc command '$command'");
+ }
+ }
foreach (<$master>) {
- next if /^\#/;
-
- # At least one upper case letter somewhere in the first group
- if (/^(\S+)\s(.*)/ && $1 =~ tr/h//) {
- # it's a heading
- my $flags = $1;
- $flags =~ tr/h//d;
- my %flags = (header => 1);
- $flags{toc_omit} = 1 if $flags =~ tr/o//d;
- $flags{aux} = 1 if $flags =~ tr/a//d;
- my_die "Unknown flag found in heading line: $_" if length $flags;
-
- push @{$state{master}}, [\%flags, $2];
- } elsif (/^(\S*)\s+(\S+)\s+(.*)/) {
- # it's a section
- my ($flags, $podname, $desc) = ($1, $2, $3);
- my $filename = "${podname}.pod";
- $filename = "pod/${filename}" if $filename !~ m{/};
-
- my %flags = (indent => 0);
- $flags{indent} = $1 if $flags =~ s/(\d+)//;
+ next if /^$/ or /^#/;
+ next if /^=head2/;
+ last if /^=for buildtoc __END__$/;
+
+ if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
+ if ($action eq '+') {
+ $current_flags .= $flags;
+ } else {
+ my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
+ unless $current_flags =~ s/[\Q$flags\E]//g;
+ }
+ } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
+ my $podname = $leafname;
+ my $filename = "pod/$podname.pod";
+ foreach (@paths) {
+ my ($re, $path) = @$_;
+ if ($leafname =~ $re) {
+ $podname = $path . $leafname;
+ $filename = "$podname.pod";
+ last;
+ }
+ }
+
+ # Keep this compatible with pre-5.10
+ my $flags = delete $flag_set{$leafname};
+ $flags = $current_flags unless defined $flags;
+
+ my %flags;
$flags{toc_omit} = 1 if $flags =~ tr/o//d;
- $flags{aux} = 1 if $flags =~ tr/a//d;
- $flags{perlpod_omit} = "$podname.pod" eq $state{delta_target};
+ $flags{dual} = $podname ne $leafname;
$state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
if ($flags =~ tr/r//d) {
my $readme = $podname;
$readme =~ s/^perl//;
- $Readmepods{$podname} = $state{readmes}{$readme} = $desc;
+ $state{readmes}{$readme} = $desc;
$flags{readme} = 1;
- } elsif ($flags{aux}) {
- $state{aux}{$podname} = $desc;
} else {
$state{pods}{$podname} = $desc;
}
my_die "Unknown flag found in section line: $_" if length $flags;
- my ($leafname) = $podname =~ m!([^/]+)$!;
+
push @{$state{master}},
- [\%flags, $podname, $filename, $desc, $leafname];
- } elsif (/^$/) {
- push @{$state{master}}, undef;
+ [$leafname, $filename, \%flags];
+
+ if ($podname eq 'perldelta') {
+ local $" = '.';
+ push @{$state{master}},
+ [$delta_leaf, "pod/$state{delta_target}"];
+ $state{pods}{$delta_leaf} = "Perl changes in version @want";
+ }
+
} else {
- my_die "Malformed line: $_" if $1 =~ tr/A-Z//;
+ my_die("Malformed line: $_");
}
}
- close $master or my_die "close pod.lst: $!";
+ close $master or my_die("close pod/perl.pod: $!");
+ # This has to be special-cased somewhere. Turns out this is cleanest:
+ push @{$state{master}}, ['a2p', 'x2p/a2p.pod', {toc_omit => 1}];
+
+ my_die("perl.pod sets flags for unknown pods: "
+ . join ' ', sort keys %flag_set)
+ if keys %flag_set;
+}
+
+=head2 C<get_pod_metadata()>
+
+=over 4
+
+=item * Purpose
+
+=item * Arguments
+
+List of one or more arguments.
+
+=over 4
+
+=item * Boolean true or false
+
+=item * Reference to a subroutine.
+
+=item * Various other arguments.
+
+=back
+
+Example:
+
+ $state = get_pod_metadata(
+ 0, sub { warn @_ if @_ }, 'pod/perltoc.pod');
+
+ get_pod_metadata(
+ 1, sub { warn @_ if @_ }, values %Build);
+
+=item * Return Value
+
+Hash reference; each element provides either a list or a lookup table for
+information about various types of POD files.
+
+ 'aux' => [ # utility programs like
+ 'h2xs' and 'perlbug' ]
+ 'generated' => { # lookup table for generated POD files
+ like 'perlapi.pod' }
+ 'ignore' => { # lookup table for files to be ignored }
+ 'pods' => { # lookup table in "name" =>
+ "short description" format }
+ 'readmes' => { # lookup table for OS-specific
+ and other READMEs }
+ 'delta_version' => [ # major version number, minor no.,
+ patch no. ]
+ 'delta_target' => 'perl<Mmmpp>delta.pod',
+ 'master' => [ # list holding entries for files callable
+ by 'perldoc' ]
+ 'copies' => { # patch version perldelta =>
+ minor version perldelta }
+
+=back
+
+=cut
+
+sub get_pod_metadata {
+ # Do we expect to find generated pods on disk?
+ my $permit_missing_generated = shift;
+ # Do they want a consistency report?
+ my $callback = shift;
+ local $_;
+
+ __prime_state() unless $state{master};
+ return \%state unless $callback;
+
+ my %BuildFiles;
+
+ foreach my $path (@_) {
+ $path =~ m!([^/]+)$!;
+ ++$BuildFiles{$1};
+ }
# Sanity cross check
- my (%disk_pods, %manipods, %manireadmes, %perlpods);
+ my (%disk_pods, %manipods, %manireadmes);
my (%cpanpods, %cpanpods_leaf);
my (%our_pods);
- # These are stub files for deleted documents. We don't want them to show up
- # in perl.pod, they just exist so that if someone types "perldoc perltoot"
- # they get some sort of pointer to the new docs.
- my %ignoredpods
- = map { ( "$_.pod" => 1 ) } qw( perlboot perlbot perltooc perltoot );
+ # There are files that we don't want to list in perl.pod.
+ # Maybe the various stub manpages should be listed there.
+ my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( );
# Convert these to a list of filenames.
- foreach (keys %{$state{pods}}, keys %Readmepods) {
- $our_pods{"$_.pod"}++;
+ ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
+ foreach (@{$state{master}}) {
+ ++$our_pods{"$_->[0].pod"}
+ if $_->[2]{readme};
}
opendir my $dh, 'pod';
}
close $mani or my_die "close MANIFEST: $!\n";
- my $perlpod = open_or_die('pod/perl.pod');
- while (<$perlpod>) {
- if (/^For ease of access, /../^\(If you're intending /) {
- if (/^\s+(perl\S*)\s+\w/) {
- ++$perlpods{"$1.pod"};
- }
- }
- }
- close $perlpod or my_die "close perlpod: $!\n";
- my_die "could not find the pod listing of perl.pod\n"
- unless %perlpods;
-
# Are we running before known generated files have been generated?
# (eg in a clean checkout)
my %not_yet_there;
my @inconsistent;
foreach my $i (sort keys %disk_pods) {
push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
- unless $our_pods{$i};
+ unless $our_pods{$i} || $ignoredpods{$i};
push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
- if !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
- && !$state{generated}{$i} && !$cpanpods{$i};
- push @inconsistent, "$0: $i exists but is unknown by perl.pod\n"
- if !$perlpods{$i} && !exists $state{copies}{$i} && !$cpanpods{$i} && !$ignoredpods{$i};
+ if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
+ && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
+ && !$state{generated}{$i} && !$cpanpods{$i};
}
foreach my $i (sort keys %our_pods) {
push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
}
- foreach my $i (sort keys %manipods) {
- push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
- unless $disk_pods{$i};
- push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
- if $state{generated}{$i};
- }
- foreach my $i (sort keys %perlpods) {
- push @inconsistent, "$0: $i is known by perl.pod but does not exist\n"
- unless $disk_pods{$i} or $BuildFiles{$i} or $cpanpods_leaf{$i}
- or $not_yet_there{$i};
+ unless ($BuildFiles{'MANIFEST'}) {
+ # Again, ignore these if we're about to rebuild MANIFEST
+ foreach my $i (sort keys %manipods) {
+ push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
+ unless $disk_pods{$i};
+ push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
+ if $state{generated}{$i};
+ }
}
- $state{inconsistent} = \@inconsistent;
+ &$callback(@inconsistent);
return \%state;
}