File Coverage

blib/lib/ExtUtils/Builder/Planner.pm

Criterion	Covered	Total	%
statement	140	176	79.5
branch	16	36	44.4
condition	4	16	25.0
subroutine	37	46	80.4
pod	16	16	100.0
total	213	290	73.4

package ExtUtils::Builder::Planner;
$ExtUtils::Builder::Planner::VERSION = '0.020';
use strict;
use warnings;

use Carp ();
use File::Basename;
use File::Spec;
use List::Util 1.45 ();
use Scalar::Util ();

use ExtUtils::Builder::Plan;
use ExtUtils::Builder::Node;
use ExtUtils::Builder::Util;

use ExtUtils::Builder::FileSet::Free;
use ExtUtils::Builder::FileSet::Filter;
use ExtUtils::Builder::FileSet::Subst;

my $class_counter = 0;

sub new {
	my $base_class = shift;
	my $all_files = ExtUtils::Builder::FileSet::Free->new;
	return $base_class->_new_scope($base_class, undef, {}, { 'all-files' => $all_files });
}

sub _new_scope {
	my ($self, $base_class, $outer, $nodes, $filesets) = @_;

	my $class = __PACKAGE__ . '::Anon_' . ++$class_counter;
	no strict 'refs';
	push @{ "$class\::ISA" }, $base_class;

	my $new = bless {
		nodes    => $nodes,
		filesets => $filesets
	}, $class;

	$new->add_delegate('self', sub { $new });
	$new->add_delegate('outer', sub { $outer });

	return $new;
}

sub new_scope {
	my ($self) = @_;
	return $self->_new_scope(ref($self), $self, $self->{nodes}, $self->{filesets});
}

sub add_node {
	my ($self, $node) = @_;
	my $target = $node->target;
	if (exists $self->{nodes}{$target}) {
		Carp::croak("Duplicate for target $target") if !$node->mergeable or !$self->{nodes}{$target}->mergeable;
		my @dependencies = List::Util::uniq($self->{nodes}{$target}->dependencies, $node->dependencies);
		my $new = ExtUtils::Builder::Node->new(target => $target, dependencies => \@dependencies, phony => 1);
		$self->{nodes}{$target} = $new;
	} else {
		$self->{nodes}{$target} = $node;
		$self->{filesets}{'all-files'}->add_input($target) if not $node->phony;
	}
	return $node->target;
}

sub create_node {
	my ($self, %args) = @_;
	my $node = ExtUtils::Builder::Node->new(%args);
	return $self->add_node($node);
}

sub create_phony {
	my ($self, $target, @dependencies) = @_;
	return $self->create_node(
		target       => $target,
		dependencies => \@dependencies,
		type         => 'phony',
	);
}

my $counter = 0;

sub _create_callback {
	my ($self, $add_to) = @_;
	return undef unless $add_to;
	my $this = $self;
	Scalar::Util::weaken($this);
	return sub {
		my ($entry) = @_;
		$this->create_phony($add_to, $entry);
	};
}

sub create_filter {
	my ($self, %args) = @_;
	my $set = ExtUtils::Builder::FileSet::Filter->new(
		condition => $args{condition},
		callback  => $self->_create_callback($args{add_to}),
	);
	my $on = $args{on} // 'all-files';
	my @sources = ref($on) eq 'ARRAY' ? @{$on} : $on;
	for my $source (@sources) {
		my $object = $self->{filesets}{$source} or die "No such source $source";
		$object->add_dependent($set);
	}
	my $name = $args{name} // 'filter-' . $counter++;
	$self->{filesets}{$name} = $set;
	return $name;
}

sub _make_pattern {
	my ($self, %options) = @_;
	if ($options{file}) {
		my $file = ExtUtils::Builder::Util::glob_to_regex($options{file});
		if ($options{dir}) {
			my $dir = ExtUtils::Builder::Util::native_to_unix_path($options{dir});
			$dir =~ s{(?
			return sub {
				my ($input) = @_;
				my $filename = ExtUtils::Builder::Util::native_to_unix_path($input);
				return if substr($filename, 0, length $dir) ne $dir;
				return File::Basename::basename($filename) =~ $file;
			};
		} else {
			return sub {
				my ($filename) = @_;
				return File::Basename::basename($filename) =~ $file;
			};
		}
	} elsif ($options{dir}) {
		my $dir = ExtUtils::Builder::Util::native_to_unix_path($options{dir});
		$dir =~ s{(?
		return sub {
			my ($input) = @_;
			my $filename = ExtUtils::Builder::Util::native_to_unix_path($input);
			return substr($filename, 0, length $dir) eq $dir;
		};
	} else {
		Carp::croak("Unknown pattern type");
	}
}

sub create_pattern {
	my ($self, %args) = @_;
	my $positive = $self->_make_pattern(%args);
	my $callback = $args{negate} ? sub { !$positive->($_[0]) } : $positive;
	return $self->create_filter(%args, condition => $callback);
}

sub create_subst {
	my ($self, %args) = @_;
	my $set = ExtUtils::Builder::FileSet::Subst->new(
		subst     => $args{subst},
		callback  => $self->_create_callback($args{add_to}),
	);
	my $on = $args{on} // 'all-files';
	my @sources = ref($on) eq 'ARRAY' ? @{$on} : $on;
	for my $source (@sources) {
		my $object = $self->{filesets}{$source} or die "No such source $source";
		$object->add_dependent($set);
	}
	my $name = $args{name} // 'subst-' . $counter++;
	$self->{filesets}{$name} = $set;
	return $name;
}

sub add_seen {
	my ($self, $entry) = @_;
	$self->{filesets}{'all-files'}->add_input($entry);
	return;
}

sub merge_plan {
	my ($self, $plan) = @_;
	$self->add_node($_) for $plan->nodes;
	return;
}

my $set_subname = eval { require Sub::Util; Sub::Util->VERSION('1.40'); \&Sub::Util::set_subname } // sub { $_[1] };

sub add_delegate {
	my ($self, $name, $sub) = @_;
	my $full_name = ref($self) . '::' . $name;
	no strict 'refs';
	no warnings 'redefine';
	*{$full_name} = $set_subname->($full_name, $sub);
	return;
}

sub load_extension {
	my ($self, $plannable, $version, %options) = @_;
	ExtUtils::Builder::Util::require_module($plannable);
	$plannable->VERSION($version) if $version;
	return $plannable->add_methods($self, %options);
}
*load_module = \&load_extension;

sub materialize {
	my $self = shift;
	my %nodes = %{ $self->{nodes} };
	return ExtUtils::Builder::Plan->new(nodes => \%nodes);
}

my %dsl_commands = (
	command  => \&ExtUtils::Builder::Util::command,
	code     => \&ExtUtils::Builder::Util::code,
	function => \&ExtUtils::Builder::Util::function,
);

sub run_dsl {
	my ($self, $filename) = @_;

	my $dsl_module = ref($self) . '::DSL';

	if (not defined &{ "$dsl_module\::AUTOLOAD" }) {
		no strict 'refs';
		*{ "$dsl_module\::AUTOLOAD" } = sub {
			my $name = our $AUTOLOAD;
			$name =~ s/.*:://;
			if (my $method = $self->can($name)) {
				my $delegate = $set_subname->($name, sub {
					$self->$method(@_);
				});
				*{ "$dsl_module\::$name" } = $delegate;
				goto &$delegate;
			}
			else {
				Carp::croak("No such subroutine $name");
			}
		};

		for my $name (keys %dsl_commands) {
			*{ "$dsl_module\::$name" } = $dsl_commands{$name} if not $dsl_module->can($name);
		}
	}

	my $path = File::Spec->rel2abs($filename);
	eval "package $dsl_module; my \$ret = do \$path; die \$@ if \$@; defined \$ret || !\$!" or die $@ // Carp::shortmess("Can't run $path: $!");
	return;
}

1;

# ABSTRACT: An ExtUtils::Builder Plan builder

__END__