File Coverage

blib/lib/App/ModuleBuildTiny/Dist.pm

Criterion	Covered	Total	%
statement	62	374	16.5
branch	0	144	0.0
condition	0	103	0.0
subroutine	21	53	39.6
pod	0	24	0.0
total	83	698	11.8

package App::ModuleBuildTiny::Dist;

use 5.014;
use warnings;
our $VERSION = '0.051';

use CPAN::Meta;
use Config;
use Encode qw/encode_utf8 decode_utf8/;
use File::Basename qw/basename dirname/;
use File::Copy qw/copy/;
use File::Path qw/mkpath rmtree/;
use File::Spec::Functions qw/catfile catdir rel2abs/;
use File::Slurper qw/write_text read_text read_binary/;
use File::chdir;
use ExtUtils::Manifest qw/manifind maniskip maniread/;
use Module::Runtime 'require_module';
use Module::Metadata 1.000037;
use Pod::Escapes qw/e2char/;
use Pod::Simple::Text 3.23;
use POSIX 'strftime';
use Text::ParseWords 'shellwords';

use Env qw/@PERL5LIB @PATH/;

my $Build = $^O eq 'MSWin32' ? 'Build' : './Build';

sub find {
	my ($re, @dir) = @_;
	my $ret;
	File::Find::find(sub { $ret++ if /$re/ }, @dir);
	return $ret;
}

sub mbt_version {
	return -f 'dynamic-prereqs.yml' ? '0.048' : '0.044';
}

sub prereqs_for {
	my ($meta, $phase, $type, $module, $default) = @_;
	return $meta->effective_prereqs->requirements_for($phase, $type)->requirements_for_module($module) // $default // 0;
}

sub uptodate {
	my ($destination, @source) = @_;
	return if not -e $destination;
	for my $source (grep { defined && -e } @source) {
		return if -M $destination > -M $source;
	}
	return 1;
}

sub distfilename {
	my $distname = shift;
	return catfile('lib', split /-/, $distname) . '.pm';
}

sub generate_readme {
	my $distname = shift;
	my $filename = distfilename($distname);
	die "Main module file $filename doesn't exist\n" if not -f $filename;
	my $parser = Pod::Simple::Text->new;
	$parser->output_string( \my $content );
	$parser->parse_characters(1);
	$parser->parse_file($filename);
	return decode_utf8($content);
}

sub load_jsonyaml {
	my $file = shift;
	require Parse::CPAN::Meta;
	return Parse::CPAN::Meta->load_file($file);
}

sub load_mergedata {
	my $mergefile = shift;
	if (defined $mergefile and -r $mergefile) {
		return load_jsonyaml($mergefile);
	}
	return;
}

sub distname {
	my $extra = shift;
	return delete $extra->{name} if defined $extra->{name};
	return basename(rel2abs('.')) =~ s/ (?: ^ (?: perl|p5 ) - | [\-\.]pm $ )//xr;
}

sub detect_license {
	my ($data, $filename, $authors, $mergedata) = @_;
	if ($mergedata->{license} && @{$mergedata->{license}} == 1) {
		require Software::LicenseUtils;
		Software::LicenseUtils->VERSION(0.103014);
		my $spec_version = $mergedata->{'meta-spec'} && $mergedata->{'meta-spec'}{version} ? $mergedata->{'meta-spec'}{version} : 2;
		my @guess = Software::LicenseUtils->guess_license_from_meta_key($mergedata->{license}[0], $spec_version);
		die "Couldn't parse license from metamerge: @guess\n" if @guess > 1;
		if (@guess) {
			my $class = $guess[0];
			require_module($class);
			return $class->new({holder => join(', ', @{$authors})});
		}
	}
	my (@license_sections) = grep { /licen[cs]e|licensing|copyright|legal|authors?\b/i } $data->pod_inside;
	for my $license_section (@license_sections) {
		next unless defined ( my $license_pod = $data->pod($license_section) );
		require Software::LicenseUtils;
		Software::LicenseUtils->VERSION(0.103014);
		my $content = "=head1 LICENSE\n" . $license_pod;
		my @guess = Software::LicenseUtils->guess_license_from_pod($content);
		next if not @guess;
		die "Couldn't parse license from $license_section in $filename: @guess\n" if @guess != 1;
		my $class = $guess[0];
		my ($year) = $license_pod =~ /.*? copyright .*? ([\d\-]+)/;
		require_module($class);
		return $class->new({holder => join(', ', @{$authors}), year => $year});
	}
	die "No license found in $filename\n";
}

sub get_changes {
	my $self = shift;
	my $version = quotemeta $self->meta->version;
	open my $changes, '<:raw', 'Changes' or die "Couldn't open Changes file";
	my (undef, @content) = grep { / ^ $version (?:-TRIAL)? (?:\s+|$) /x ... /^\S/ } <$changes>;
	pop @content while @content && $content[-1] =~ / ^ (?: \S | \s* $ ) /x;
	return @content;
}

sub preflight_check {
	my ($self, %opts) = @_;

	die "Changes appears to be empty\n" if not $self->get_changes;

	my $meta_version = $self->{meta}->version;
	die "Version is still zero\n" if $meta_version eq '0.000';

	die "Abstract is not set\n" if $self->{meta}->abstract eq 'INSERT YOUR ABSTRACT HERE';

	if ($opts{tag}) {
		require Git::Wrapper;
		my $git = Git::Wrapper->new('.');

		die "Dirty state in repository\n" if $git->status->is_dirty;
		die "Tag v$meta_version already exists\n" if eval { $git->rev_parse({ quiet => 1, verify => 1}, "v$meta_version") };
	}

	my $module_name = $self->{meta}->name =~ s/-/::/gr;
	my $detected_version = $self->{data}->version($module_name);
	die sprintf "Version mismatch between module and meta, did you forgot to run regenerate? (%s versus %s)\n", $detected_version, $meta_version if $detected_version != $meta_version;
}

sub scan_files {
	my ($files, $omit, %extra_args) = @_;
	my $combined = CPAN::Meta::Requirements->new;
	require Perl::PrereqScanner;
	my $scanner = Perl::PrereqScanner->new(\%extra_args);
	for my $file (@{$files}) {
		my $prereqs = $scanner->scan_file($file);
		$combined->add_requirements($prereqs);
	}
	$combined->clear_requirement($_) for @{$omit};
	return $combined
}

sub _scan_prereqs {
	my ($omit, %opts) = @_;
	my (@runtime_files, @test_files, @planner_files);
	File::Find::find(sub { push @runtime_files, $File::Find::name if -f && /\.pm$/ }, 'lib') if -d 'lib';
	File::Find::find(sub { push @runtime_files, $File::Find::name if -f }, 'script') if -d 'script';
	File::Find::find(sub { push @test_files, $File::Find::name if -f && /\.(t|pm)$/ }, 't') if -d 't';

	my $runtime = scan_files(\@runtime_files, $omit);
	my $test = scan_files(\@test_files, $omit);

	my %prereqs = (
		runtime => { requires => $runtime->as_string_hash },
		test    => { requires => $test->as_string_hash },
	);

	if (-d 'planner') {
		File::Find::find(sub { push @planner_files, $File::Find::name if -f && /\.pl$/ }, 'planner');
		require Perl::PrereqScanner::Scanner::DistBuild;
		my $configure = scan_files(\@planner_files, ['strict', 'warnings', @{$omit}], extra_scanners => [ 'DistBuild' ]);
		$configure->add_minimum('Dist::Build' => '0.003');
		$prereqs{configure} = { requires => $configure->as_string_hash };
	} else {
		$prereqs{configure} = { requires => { 'Module::Build::Tiny' => mbt_version() } };
	}

	my $prereqs = CPAN::Meta::Prereqs->new(\%prereqs);
	require CPAN::Meta::Prereqs::Filter;
	return CPAN::Meta::Prereqs::Filter::filter_prereqs($prereqs, %opts);
}


sub scan_prereqs {
	my ($self, %opts) = @_;
	my @omit = (@{ $opts{omit} // [] }, keys %{ $self->{meta}->provides });
	return _scan_prereqs(\@omit, %opts);
}

sub load_prereqs {
	my ($provides, %opts) = @_;
	my @prereqs;
	if (-f 'prereqs.json') {
		push @prereqs, load_jsonyaml('prereqs.json');
	}
	if (-f 'prereqs.yml') {
		push @prereqs, load_jsonyaml('prereqs.yml');
	}
	if (-f 'cpanfile') {
		require Module::CPANfile;
		push @prereqs, Module::CPANfile->load('cpanfile')->prereq_specs;
	}
	if ($opts{scan}) {
		push @prereqs, _scan_prereqs([ keys %{$provides} ])->as_string_hash;
	}

	if (@prereqs == 1) {
		return $prereqs[0];
	}
	elsif (@prereqs == 0) {
		return {};
	}
	else {
		@prereqs = map { CPAN::Meta::Prereqs->new($_) } @prereqs;
		my $prereqs = $prereqs[0]->with_merged_prereqs([ @prereqs[1..$#prereqs] ]);
		$prereqs->as_string_hash;
	}
}

sub new {
	my ($class, %opts) = @_;
	my $mergefile = $opts{mergefile} // (grep { -f } qw/metamerge.json metamerge.yml/)[0];
	my $mergedata = load_mergedata($mergefile) // {};
	my $distname = distname($mergedata);
	my $filename = distfilename($distname);
	my $podname = $filename =~ s/\.pm$/.pod/r;

	my $data = Module::Metadata->new_from_file($filename, collect_pod => 1, decode_pod => 1) or die "Couldn't analyse $filename: $!";
	my $pod_data = -e $podname && Module::Metadata->new_from_file($podname, collect_pod => 1, decode_pod => 1) // $data;
	my @authors = map { s/E<([^>]+)>/e2char($1)/ge; m/ \A \s* (.+?) \s* \z /x } grep { /\S/ } split /\n/, $pod_data->pod('AUTHOR') // $pod_data->pod('AUTHORS') // '' or warn "Could not parse any authors from `=head1 AUTHOR` in $filename";
	my $license = detect_license($pod_data, $filename, \@authors, $mergedata);

	my $load_meta = !%{ $opts{regenerate} // {} } && uptodate('META.json', 'cpanfile', 'prereqs.json', 'prereqs.yml', $mergefile);

	my $mode = -d 'planner' ? 'DB' : 'MBT';
	my $meta = $load_meta ? CPAN::Meta->load_file('META.json', { lazy_validation => 0 }) : do {
		my ($abstract) = ($pod_data->pod('NAME') // '')  =~ / \A \s+ \S+ \s? - \s? (.+?) \s* \z /x or warn "Could not parse abstract from `=head1 NAME` in $filename";
		my $version = $data->version($data->name) // die "Cannot parse \$VERSION from $filename";

		my $provides = Module::Metadata->provides(version => 2, dir => 'lib');
		my $prereqs = load_prereqs($provides, %opts);
		if ($mode eq 'MBT') {
			$prereqs->{configure}{requires}{'Module::Build::Tiny'} //= mbt_version();
		} else {
			$prereqs->{configure}{requires}{'Dist::Build'} //= '0.003';
		}
		$prereqs->{develop}{requires}{'App::ModuleBuildTiny'} //= $VERSION;
		my %resources = $class->generate_resources(%opts);

		my $metahash = {
			name                => $distname,
			version             => $version->stringify,
			author              => \@authors,
			abstract            => $abstract,
			dynamic_config      => 0,
			license             => [ $license->meta2_name ],
			prereqs             => $prereqs,
			release_status      => $opts{trial} // $version =~ /_/ ? 'testing' : 'stable',
			generated_by        => "App::ModuleBuildTiny version $VERSION",
			'meta-spec'         => {
				version         => 2,
				url             => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec'
			},
			(resources          => \%resources) x!! %resources,
			x_spdx_expression   => $license->spdx_expression,
			x_generated_by_perl => "$^V",
		};

		if (-e 'dynamic-prereqs.yml') {
			my $dynamic_prereqs = load_jsonyaml('dynamic-prereqs.yml');
			for my $expression (@{ $dynamic_prereqs->{expressions}}) {
				$expression->{condition} = [ shellwords($expression->{condition}) ] unless ref $expression->{condition};
				if (not ref $expression->{prereqs}) {
					my ($module, $version) = shellwords($expression->{prereqs});
					$version //= '0';
					$expression->{prereqs} = { $module => $version };
				}
			}
			$metahash->{x_dynamic_prereqs} = $dynamic_prereqs;
		}
		if (%{$mergedata}) {
			require CPAN::Meta::Merge;
			$metahash = CPAN::Meta::Merge->new(default_version => '2')->merge($metahash, $mergedata);
		}
		if ($metahash->{x_dynamic_prereqs}) {
			$metahash->{dynamic_config} = 1;
			$metahash->{prereqs}{configure}{requires}{'CPAN::Requirements::Dynamic'} //= '0.002' if $mode eq 'MBT';
		}

		# this avoids a long-standing CPAN.pm bug that incorrectly merges runtime and
		# "build" (build+test) requirements by ensuring requirements stay unified
		# across all three phases
		require CPAN::Meta::Prereqs::Filter;
		my $filtered = CPAN::Meta::Prereqs::Filter::filter_prereqs(CPAN::Meta::Prereqs->new($metahash->{prereqs}), sanitize => 1);
		my $merged_prereqs = $filtered->merged_requirements([qw/runtime build test/], ['requires']);
		my %seen;
		for my $phase (qw/runtime build test/) {
			my $requirements = $filtered->requirements_for($phase, 'requires');
			for my $module ($requirements->required_modules) {
				$requirements->clear_requirement($module);
				next if $seen{$module}++;
				my $module_requirement = $merged_prereqs->requirements_for_module($module);
				$requirements->add_string_requirement($module => $module_requirement);
			}
		}
		$metahash->{prereqs} = $filtered->as_string_hash;

		$metahash->{provides} //= $provides if not $metahash->{no_index};
		CPAN::Meta->create($metahash, { lazy_validation => 0 });
	};

	my %files;
	if (not $opts{regenerate}{MANIFEST} and -r 'MANIFEST') {
		%files = %{ maniread() };
	}
	else {
		my $maniskip = maniskip;
		%files = %{ manifind() };
		delete $files{$_} for grep { $maniskip->($_) } keys %files;
	}
	delete $files{$_} for keys %{ $opts{regenerate} };

	my $dist_name = $meta->name;
	$files{'Build.PL'} //= do {
		my $minimum_perl = prereqs_for($meta, qw/runtime requires perl 5.008/);
		my $header = "# This Build.PL for $dist_name was generated by mbtiny $VERSION.";
		if ($mode eq 'MBT') {
			my $minimum_mbt = prereqs_for($meta, qw/configure requires Module::Build::Tiny/);
			"$header\nuse $minimum_perl;\nuse Module::Build::Tiny $minimum_mbt;\nBuild_PL();\n";
		} else {
			my $minimum_db = prereqs_for($meta, qw/configure requires Dist::Build/);
			"$header\nuse $minimum_perl;\nuse Dist::Build $minimum_db;\nBuild_PL(\\\@ARGV, \\\%ENV);\n";
		}
	};
	{
		local $ENV{CPAN_META_JSON_BACKEND} = JSON::MaybeXS::JSON();
		$files{'META.json'} //= $meta->as_string;
		$files{'META.yml'} //= $meta->as_string({ version => 1.4 });
	}
	$files{LICENSE} //= $license->fulltext;
	$files{README} //= generate_readme($dist_name);
	if ($opts{regenerate}{Changes}) {
		my $time = strftime("%Y-%m-%d %H:%M:%S%z", localtime);
		my $header = sprintf "%-9s %s\n", $meta->version, $time;
		$files{Changes} = read_text('Changes') =~ s/(?<=\n\n)/$header/er;
	}
	# This must come last
	$files{MANIFEST} //= join '', map { "$_\n" } sort keys %files;

	return bless {
		files => \%files,
		meta  => $meta,
		license => $license,
		data => $data,
	}, $class
}


sub generate_resources {
	my ($class, %opts) = @_;
	my %result;

	if ($opts{add_repository}) {
		require Git::Wrapper;
		my $git = Git::Wrapper->new('.');
		my ($origin) = $git->remote('get-url' => 'origin');
		if ($origin =~ m{https://github.com/([\w.-]+)/([\w.-]+).git}) {
			$result{repository} = {
				type => 'git',
				web  => "https://github.com/$1/$2",
				url  => $origin,
			};
		} elsif ($origin =~ m{git\@github.com:([\w.-]+)/([\w.-]+).git}) {
			$result{repository} = {
				type => 'git',
				web  => "https://github.com/$1/$2",
				url  => "https://github.com/$1/$2.git",
			};
		} elsif ($origin =~ m{^https?://}) {
			$result{repository} = {
				type => 'git',
				url  => $origin,
			};
		}
	}

	if ($opts{add_bugtracker}) {
		require Git::Wrapper;
		my $git = Git::Wrapper->new('.');
		my ($origin) = $git->remote('get-url' => 'origin');
		if ($origin =~ m{https://github.com/([\w.-]+)/([\w.-]+).git}) {
			$result{bugtracker} = {
				web  => "https://github.com/$1/$2/issues",
			};
		} elsif ($origin =~ m{git\@github.com:([\w.-]+)/([\w.-]+).git}) {
			$result{bugtracker} = {
				web  => "https://github.com/$1/$2/issues",
			};
		}
	}
	return %result;
}

sub write_dir {
	my ($self, $dir, $verbose) = @_;
	mkpath($dir, $verbose, oct '755');
	my $files = $self->{files};
	for my $filename (keys %{$files}) {
		my $target = "$dir/$filename";
		mkpath(dirname($target)) if not -d dirname($target);
		if ($files->{$filename}) {
			write_text($target, $files->{$filename});
		}
		else {
			copy($filename, $target);
		}
	}
}

sub write_tarball {
	my ($self, $name) = @_;
	require Archive::Tar;
	my $arch = Archive::Tar->new;
	for my $filename ($self->files) {
		$arch->add_data($filename, $self->get_file($filename), { mode => oct '0644'} );
	}
	$arch->write($name, &Archive::Tar::COMPRESS_GZIP, $name =~ s/.tar.gz$//r);
	return $name;
}

sub files {
	my $self = shift;
	return keys %{ $self->{files} };
}

sub get_file {
	my ($self, $filename) = @_;
	return if not exists $self->{files}{$filename};
	my $raw = $self->{files}{$filename};
	return $raw ? encode_utf8($raw) : read_binary($filename);
}

sub run {
	my ($self, %opts) = @_;
	require File::Temp;
	my $dir  = File::Temp::tempdir(CLEANUP => 1);
	$self->write_dir($dir, $opts{verbose});
	local $CWD = $dir;
	my $ret = !!1;
	if ($opts{build}) {
		system $Config{perlpath}, 'Build.PL' and ($opts{allow_failure} or die "Could not run Build.PL");
		system $Config{perlpath}, 'Build' and ($opts{allow_failure} or die "Could not run Build");
		my @extralib = map { rel2abs("blib/$_") } 'arch', 'lib';
		local @PERL5LIB = (@extralib, @PERL5LIB);
		local @PATH = (rel2abs(catdir('blib', 'script')), @PATH);
		for my $command (@{ $opts{commands} }) {
			say join ' ', @{$command} if $opts{verbose};
			$ret &&= not system @{$command};
		}
	}
	else {
		for my $command (@{ $opts{commands} }) {
			say join ' ', @{$command} if $opts{verbose};
			$ret &&= not system @{$command};
		}
	}
	return $ret;
}

for my $method (qw/meta license/) {
	no strict 'refs';
	*$method = sub { my $self = shift; return $self->{$method}; };
}

for my $method (qw/name version release_status/) {
	no strict 'refs';
	*$method = sub { my $self = shift; return $self->{meta}->$method; }
}

sub fullname {
	my $self = shift;
	my $trial = $self->release_status eq 'testing' && $self->version !~ /_/;
	return $self->meta->name . '-' . $self->meta->version . ($trial ? '-TRIAL' : '' );
}

sub archivename {
	my $self = shift;
	return $self->fullname . '.tar.gz';
}

1;