—
—
—
—
—
—
—
—

              
#!/usr/bin/perl -w
use strict;
use File::Find;
HideShow 58 lines of Pod
=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
sub my_die {
    print STDERR "$0: ", @_;
    print STDERR "\n" unless $_[-1] =~ /\n\z/;
    print STDERR "ABORTED\n";
    exit 255;
}
HideShow 22 lines of Pod
=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;
}
HideShow 22 lines of Pod
=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);
    binmode $fh;
    local $/;
    my $contents = <$fh>;
    die "Can't read $filename: $!" unless defined $contents and close $fh;
    return $contents;
}
HideShow 23 lines of Pod
=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: $!";
}
HideShow 60 lines of Pod
=head2 C<verify_contiguous()>
=over 4
=item * Purpose
Verify that a makefile or makefile constructor contains exactly one contiguous
run of lines which matches a given pattern. C<croak()>s if the pattern is not
found, or found in more than one place.
By "makefile or makefile constructor" we mean a file which is one of the
right-hand values in this list of key-value pairs:
            manifest => 'MANIFEST',
            vms => 'vms/descrip_mms.template',
            nmake => 'win32/Makefile',
            gmake => 'win32/GNUmakefile',
            podmak => 'win32/pod.mak',
            unix => 'Makefile.SH',
(Currently found in C<%Targets> in F<Porting/pod_rules.pl>.)
=item * Arguments
=over 4
=item * Name of target
String holding the key of one element in C<%Targets> in F<Porting/pod_rules.pl>.
=item * Contents of file
String holding slurped contents of the file named in the value of the element
in C<%Targets> in F<Porting/pod_rules.pl> named in the first argument.
=item * Pattern of interest
Compiled regular expression pertinent to a particular makefile constructor.
=item * Name to report on error
String holding description.
=back
=item * Return Value
The contents of the file, with C<qr/\0+/> substituted for the pattern.
=item * Example (drawn from F<Porting/pod_rules.pl> C<do_unix()>):
    my $makefile_SH = slurp_or_die('./Makefile.SH');
    my $re = qr/some\s+pattern/;
    my $makefile_SH_out =
        verify_contiguous('unix', $makefile_SH, $re, 'copy rules');
=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;
}
HideShow 43 lines of Pod
=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 $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: $!";
}
HideShow 42 lines of Pod
=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);
    $do_not_install{"ExtUtils::XSSymSet"} = 1
        unless $^O eq "VMS";
    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 $contents = slurp_or_die($filename);
    my @want =
        $contents =~ /perldelta - what is new for perl v(\d+)\.(\d+)\.(\d+)\r?\n/;
    die "Can't extract version from $filename" unless @want;
    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;
    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 /^$/ 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{dual} = $podname ne $leafname;
            $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
            if ($flags =~ tr/r//d) {
                my $readme = $podname;
                $readme =~ s/^perl//;
                $state{readmes}{$readme} = $desc;
                $flags{readme} = 1;
            } else {
                $state{pods}{$podname} = $desc;
            }
            my_die "Unknown flag found in section line: $_" if length $flags;
            push @{$state{master}},
                [$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: $_");
        }
    }
    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;
}
HideShow 64 lines of Pod
=head2 C<get_pod_metadata()>
=over 4
=item * Purpose
Create a data structure holding information about files containing text in POD format.
=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 'perldoc' ]
  '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 }
=item * Comment
Instances where this subroutine is used may be found in these files:
    pod/buildtoc
    Porting/new-perldelta.pl
    Porting/pod_rules.pl
=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);
    my (%cpanpods, %cpanpods_leaf);
    my (%our_pods);
    # 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.
    ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
    foreach (@{$state{master}}) {
        ++$our_pods{"$_->[0].pod"}
            if $_->[2]{readme};
    }
    opendir my $dh, 'pod';
    while (defined ($_ = readdir $dh)) {
        next unless /\.pod\z/;
        ++$disk_pods{$_};
    }
    # Things we copy from won't be in perl.pod
    # Things we copy to won't be in MANIFEST
    my $mani = open_or_die('MANIFEST');
    while (<$mani>) {
        chomp;
        s/\s+.*$//;
        if (m!^pod/([^.]+\.pod)!i) {
            ++$manipods{$1};
        } elsif (m!^README\.(\S+)!i) {
            next if $state{ignore}{$1};
            ++$manireadmes{"perl$1.pod"};
        } elsif (exists $our_pods{$_}) {
            ++$cpanpods{$_};
            m!([^/]+)$!;
            ++$cpanpods_leaf{$1};
            $disk_pods{$_}++
                if -e $_;
        }
    }
    close $mani or my_die "close MANIFEST: $!\n";
    # 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}})
    }
    my @inconsistent;
    foreach my $i (sort keys %disk_pods) {
        push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
            unless $our_pods{$i} || $ignoredpods{$i};
        push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
            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};
    }
    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};
        }
    }
    &$callback(@inconsistent);
    return \%state;
}
1;
# ex: set ts=8 sts=4 sw=4 et: