File Coverage

blib/lib/App/DocKnot/Dist.pm

Criterion	Covered	Total	%
statement	147	150	98.0
branch	31	40	77.5
condition	6	6	100.0
subroutine	27	27	100.0
pod	4	4	100.0
total	215	227	94.7

# Generate a distribution tarball for a package.
#
# This is the implementation of the docknot dist command, which determines and
# runs the commands necessary to build a distribution tarball for a given
# package.
#
# SPDX-License-Identifier: MIT

##############################################################################
# Modules and declarations
##############################################################################

package App::DocKnot::Dist 3.02;

use 5.024;
use autodie;
use warnings;

use App::DocKnot::Config;
use Archive::Tar ();
use Carp qw(croak);
use Cwd qw(getcwd);
use File::Copy qw(move);
use File::Find qw(find);
use File::Path qw(remove_tree);
use IPC::Run qw(run);
use IPC::System::Simple qw(systemx);
use List::MoreUtils qw(any lastval);

# Base commands to run for various types of distributions.  Additional
# variations may be added depending on additional configuration parameters.
#<<<
our %COMMANDS = (
    'Autoconf' => [
        ['./bootstrap'],
        ['./configure', 'CC=clang'],
        ['make', 'warnings'],
        ['make', 'check'],
        ['make', 'clean'],
        ['./configure', 'CC=gcc'],
        ['make', 'warnings'],
        ['make', 'check'],
        ['make', 'clean'],
        ['make', 'check-cppcheck'],
        ['make', 'distcheck'],
    ],
    'ExtUtils::MakeMaker' => [
        ['perl', 'Makefile.PL'],
        ['make', 'disttest'],
        ['make', 'dist'],
    ],
    'Module::Build' => [
        ['perl', 'Build.PL'],
        ['./Build', 'disttest'],
        ['./Build', 'dist'],
    ],
    'make' => [
        ['make', 'dist'],
    ],
);
#>>>

# Regexes matching files or directories in the source tree to ignore when
# comparing it against the generated distribution (in other words, we don't
# care whether these files or any files in these directories are included in
# the distribution).  These should match the full file path relative to the
# top directory.
#
# Include all of the build-generated files for docknot itself so that we can
# use the new version to release the new version.
## no critic (RegularExpressions::ProhibitFixedStringMatches)
our @DIST_IGNORE = (
    qr{ \A [.]git \z }xms,
    qr{ \A autom4te[.]cache \z }xms,
    qr{ \A Build \z }xms,
    qr{ \A MANIFEST[.]bak \z }xms,
    qr{ \A MYMETA [.] (?:json (?:[.]lock)? | yml) \z }xms,
    qr{ \A _build \z }xms,
    qr{ \A blib \z }xms,
    qr{ \A config[.]h[.]in~ \z }xms,
    qr{ \A cover_db \z }xms,
    qr{ \A tests/config \z }xms,
    qr{ [.]tar[.][gx]z \z }xms,
);
## use critic

##############################################################################
# Helper methods
##############################################################################

# Given the path to the source tree, generate a list of files that we expect
# to find in the distribution tarball.
#
# $self - The App::DocKnot::Dist object
# $path - The directory path
#
# Returns: A list of files (no directories) that the distribution tarball
#          should contain.
sub _expected_dist_files {
    my ($self, $path) = @_;
    my @files;

    # Find all files in the source directory, stripping its path from the file
    # name and excluding (and pruning) anything matching @DIST_IGNORE.
    my $wanted = sub {
        my $name = $File::Find::name;
        $name =~ s{ \A \Q$path\E / }{}xms;
        return if !$name;
        if (any { $name =~ $_ } @DIST_IGNORE) {
            $File::Find::prune = 1;
            return;
        }
        return if -d;
        push(@files, $name);
    };

    # Generate and return the list of files.
    find($wanted, $path);
    return @files;
}

# Find the tarball compressed with gzip given a directory and a prefix.
#
# $self   - The App::DocKnot::Dist object
# $path   - The directory path
# $prefix - The tarball file prefix
#
# Returns: The full path to the gzip tarball
#  Throws: Text exception if no gzip tarball was found
sub _find_gzip_tarball {
    my ($self, $path, $prefix) = @_;
    my @files     = $self->_find_matching_tarballs($path, $prefix);
    my $gzip_file = lastval { m{ [.]tar [.]gz \z }xms } @files;
    if (!defined($gzip_file)) {
        die "cannot find gzip tarball for $prefix in $path\n";
    }
    return File::Spec->catfile($path, $gzip_file);
}

# Find matching tarballs given a directory and a prefix.
#
# $self   - The App::DocKnot::Dist object
# $path   - The directory path
# $prefix - The tarball file prefix
#
# Returns: All matching files, without the directory name, as a list
sub _find_matching_tarballs {
    my ($self, $path, $prefix) = @_;
    my $pattern = qr{ \A \Q$prefix\E - \d.* [.]tar [.][xg]z \z }xms;
    opendir(my $source, $path);
    my @files = grep { $_ =~ $pattern } readdir($source);
    closedir($source);
    return @files;
}

# Given a directory and a prefix for tarballs in that directory, ensure that
# all the desired compression formats exist.  Currently this only handles
# generating the xz version of a gzip tarball.
#
# $self   - The App::DocKnot::Dist object
# $path   - The directory path
# $prefix - The tarball file prefix
sub _generate_compression_formats {
    my ($self, $path, $prefix) = @_;
    my @files = $self->_find_matching_tarballs($path, $prefix);
    if (!any { m{ [.]tar [.]xz \z }xms } @files) {
        my $gzip_file = lastval { m{ [.]tar [.]gz \z }xms } @files;
        systemx('gzip', '-dk', File::Spec->catfile($path, $gzip_file));
        my $tar_file = $gzip_file;
        $tar_file =~ s{ [.]gz \z }{}xms;
        systemx('xz', File::Spec->catfile($path, $tar_file));
    }
    return;
}

# Given a source directory, a prefix for tarballs and related files (such as
# signatures), and a destination directory, move all matching files from the
# source directory to the destination directory.
#
# $self        - The App::DocKnot::Dist object
# $source_path - The source directory path
# $prefix      - The tarball file prefix
# $dest_path   - The destination directory path
#
# Throws: Text exception if no files are found
#         Text exception on failure to move a file
sub _move_tarballs {
    my ($self, $source_path, $prefix, $dest_path) = @_;
    my @files = $self->_find_matching_tarballs($source_path, $prefix);
    for my $file (@files) {
        my $source_file = File::Spec->catfile($source_path, $file);
        move($source_file, $dest_path)
          or die "cannot move $source_file to $dest_path: $!\n";
    }
    return;
}

# Given a command with arguments, replace a command of "perl" with the
# configured path to Perl, if any.  Assumes that the perl configuration
# parameter is set in the object and should not be called if this is not true.
#
# $self        - The App::DocKnot::Dist object
# $command_ref - Reference to an array representing a command with arguments
#
# Returns: Reference to an array representing a command with arguments, with
#          the command replaced with the configured path to Perl if it was
#          "perl"
sub _replace_perl_path {
    my ($self, $command_ref) = @_;
    if ($command_ref->[0] ne 'perl') {
        return $command_ref;
    }
    my @command = $command_ref->@*;
    $command[0] = $self->{perl};
    return [@command];
}

##############################################################################
# Public interface
##############################################################################

# Create a new App::DocKnot::Dist object, which will be used for subsequent
# calls.
#
# $class - Class of object ot create
# $args  - Anonymous hash of arguments with the following keys:
#   distdir  - Path to the directory for distribution tarball
#   metadata - Path to the directory containing package metadata
#   perl     - Path to Perl to use (default: search the user's PATH)
#
# Returns: Newly created object
#  Throws: Text exceptions on invalid metadata directory path
#          Text exception on missing or invalid distdir argument
sub new {
    my ($class, $args_ref) = @_;

    # Create the config reader.
    my %config_args;
    if ($args_ref->{metadata}) {
        $config_args{metadata} = $args_ref->{metadata};
    }
    my $config = App::DocKnot::Config->new(\%config_args);

    # Ensure we were given a valid distdir argument.
    my $distdir = $args_ref->{distdir};
    if (!defined($distdir)) {
        croak('distdir path not given');
    } elsif (!-d $distdir) {
        croak("distdir path $distdir does not exist or is not a directory");
    }

    # Create and return the object.
    my $self = {
        config  => $config->config(),
        distdir => $distdir,
        perl    => $args_ref->{perl},
    };
    bless($self, $class);
    return $self;
}

# Given a distribution tarball compressed with gzip, ensure that every file
# from the source directory that is expected to be there is in the
# distribution tarball.  Assumes that it is run from the root of the source
# directory.
#
# $self    - The App::DocKnot::Dist object
# $source  - Path to the source directory
# $tarball - Path to a gzip-compressed distribution tarball
#
# Returns: A list of files missing from the distribution (so an empty list
#          means all expected files were found)
sub check_dist {
    my ($self, $source, $tarball) = @_;
    my @expected = $self->_expected_dist_files(getcwd());
    my %expected = map { $_ => 1 } @expected;
    my $archive  = Archive::Tar->new($tarball);
    for my $file ($archive->list_files()) {
        $file =~ s{ \A [^/]* / }{}xms;
        delete $expected{$file};
    }
    my @missing = sort(keys(%expected));
    return @missing;
}

# Analyze a source directory and return the list of commands to run to
# generate a distribution tarball.
#
# $self - The App::DocKnot::Dist object
#
# Returns: List of commands, each of which is a list of strings representing
#          a command and its arguments
sub commands {
    my ($self)   = @_;
    my $type     = $self->{config}{build}{type};
    my @commands = map { [@$_] } $COMMANDS{$type}->@*;

    # Special-case: If a specific path to Perl was configured, use that path
    # rather than searching for perl in the user's PATH.  This is used
    # primarily by the test suite, which wants to run a Module::Build Build.PL
    # and thus has to use the same perl binary as the one running the tests.
    if (defined($self->{perl})) {
        @commands = map { $self->_replace_perl_path($_) } @commands;
    }

    # Special-case: Autoconf packages with C++ support should also attempt a
    # build with a C++ compiler.
    if ($type eq 'Autoconf' && $self->{config}{build}{cplusplus}) {
        #<<<
        my @extra = (
            ['./configure', 'CC=g++'],
            ['make', 'check'],
            ['make', 'clean'],
        );
        #>>>
        splice(@commands, 1, 0, @extra);
    }

    # Special-case: Autoconf packages with Valgrind support should also run
    # make check-valgrind.
    if ($type eq 'Autoconf' && $self->{config}{build}{valgrind}) {
        splice(@commands, -3, 0, ['make', 'check-valgrind']);
    }

    return @commands;
}

# Generate a distribution tarball.  This assumes it is run from the root
# directory of the package to release and that it is a Git repository.  It
# exports the Git repository, runs the commands to generate the tarball, and
# then removes the working tree.
#
# $self - The App::DocKnot::Dist object
#
# Throws: Text exception if any of the commands fail
#         Text exception if the distribution is missing files
sub make_distribution {
    my ($self) = @_;

    # Determine the source directory and the distribution directory name.
    my $source = getcwd() or die "cannot get current directory: $!\n";
    my $prefix = $self->{config}{distribution}{tarname};

    # If the distribution directory name already exists, remove it.  Automake
    # may have made parts of it read-only, so be forceful in the removal.
    # Note that this does not pass the safe parameter and therefore should not
    # be called on attacker-controlled directories.
    chdir($self->{distdir});
    if (-d $prefix) {
        remove_tree($prefix);
    }

    # Export the Git repository into a new directory.
    my @git = ('git', 'archive', "--remote=$source", "--prefix=${prefix}/",
        'master',);
    my @tar = qw(tar xf -);
    run(\@git, q{|}, \@tar) or die "@git | @tar failed with status $?\n";

    # Change to that directory and run the configured commands.
    chdir($prefix);
    for my $command_ref ($self->commands()) {
        systemx($command_ref->@*);
    }

    # Move the generated tarball to the parent directory.
    $self->_move_tarballs(File::Spec->curdir(), $prefix, File::Spec->updir());

    # Remove the working tree.
    chdir(File::Spec->updir());
    remove_tree($prefix, { safe => 1 });

    # Generate additional compression formats if needed.
    $self->_generate_compression_formats(getcwd(), $prefix);

    # Check the distribution for any missing files.  If there are any, report
    # them and then fail with an error.
    my $tarball = $self->_find_gzip_tarball(getcwd(), $prefix);
    chdir($source);
    my @missing = $self->check_dist($source, $tarball);
    if (@missing) {
        print "Files found in local tree but not in distribution:\n"
          or die "cannot print to stdout: $!\n";
        print q{    } . join(qq{\n    }, @missing) . "\n"
          or die "cannot print to stdout: $!\n";
        my $count = scalar(@missing);
        my $files = ($count == 1) ? '1 file' : "$count files";
        die "$files missing from distribution\n";
    }
    return;
}

##############################################################################
# Module return value and documentation
##############################################################################

1;
__END__