X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/852355fc8bd0e2a73e60ad29e169fe586d240117..8b523b63de9d345e1a95eb95ff44652618f2fd08:/Porting/pod_lib.pl

diff --git a/Porting/pod_lib.pl b/Porting/pod_lib.pl
index 684b494..3088d16 100644
--- a/Porting/pod_lib.pl
+++ b/Porting/pod_lib.pl
@@ -1,6 +1,73 @@
 #!/usr/bin/perl -w
 
 use strict;
+use File::Find;
+
+=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
+
+# In some situations, eg cross-compiling, we get run with miniperl, so we can't use Digest::MD5
+my $has_md5;
+BEGIN {
+    use Carp;
+    $has_md5 = eval { require Digest::MD5; Digest::MD5->import('md5');  1; };
+}
+
 
 # make it clearer when we haven't run to completion, as we can be quite
 # noisy when things are working ok
@@ -12,114 +79,526 @@ sub my_die {
     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;
 }
 
-sub get_pod_metadata {
-    my %BuildFiles;
+=head2 C<slurp_or_die()>
 
-    foreach my $path (@_) {
-        $path =~ m!([^/]+)$!;
-        ++$BuildFiles{$1};
+=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);
+    binmode $fh;
+    local $/;
+    my $contents = <$fh>;
+    die "Can't read $filename: $!" unless defined $contents and close $fh;
+    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: $!";
+    binmode $fh;
+    print $fh $contents or die "Can't write to $filename: $!";
+    close $fh or die "Can't close $filename: $!";
+}
+
+=head2 C<verify_contiguous()>
+
+=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 $_;
+
+        return if !$has_md5;
+
+        # 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 v5\.(\d+)\.(\d+)\n/;
+        $contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\n/;
     die "Can't extract version from $filename" unless @want;
-    $state{delta_target} = "perl5$want[0]$want[1]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
     # Targets will always be in the pod directory. Currently we can only cope
     # 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);
+
+    my $master = open_or_die('pod/perl.pod');
+
+    while (<$master>) {
+        last if /^=begin buildtoc$/;
+    }
+    die "Can't find '=begin buildtoc':" if eof $master;
 
-    # process pod.lst
-    my %Readmepods;
-    my $master = open_or_die('pod.lst');
+    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: $!");
+
+    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';
@@ -150,43 +629,37 @@ sub get_pod_metadata {
     }
     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"};
-            }
-        }
+    # Are we running before known generated files have been generated?
+    # (eg in a clean checkout)
+    my %not_yet_there;
+    if ($permit_missing_generated) {
+        # If so, don't complain if these files aren't yet in place
+        %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
     }
-    close $perlpod or my_die "close perlpod: $!\n";
-    my_die "could not find the pod listing of perl.pod\n"
-        unless %perlpods;
 
     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};
-    }
-    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};
+            unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$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};
+    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;
 }