File Coverage

blib/lib/Module/CPANfile/Environment.pm

Criterion	Covered	Total	%
statement	80	87	91.9
branch	7	8	87.5
condition	3	6	50.0
subroutine	30	34	88.2
pod	0	19	0.0
total	120	154	77.9

package Module::CPANfile::Environment;
use strict;
use warnings;
use Module::CPANfile::Prereqs;
use Carp ();

my @bindings = qw(
    on requires recommends suggests conflicts
    feature
    osname
    mirror
    configure_requires build_requires test_requires author_requires
);

my $file_id = 1;

sub new {
    my($class, $file) = @_;
    bless {
        file     => $file,
        phase    => 'runtime', # default phase
        feature  => undef,
        features => {},
        prereqs  => Module::CPANfile::Prereqs->new,
        mirrors  => [],
    }, $class;
}

sub bind {
    my $self = shift;
    my $pkg = caller;

    for my $binding (@bindings) {
        no strict 'refs';
        *{"$pkg\::$binding"} = sub { $self->$binding(@_) };
    }
}

sub parse {
    my($self, $code) = @_;

    my $err;
    {
        local $@;
        $file_id++;
        $self->_evaluate(<<EVAL);
package Module::CPANfile::Sandbox$file_id;
no warnings;
BEGIN { \$_environment->bind }

# line 1 "$self->{file}"
$code;
EVAL
        $err = $@;
    }

    if ($err) { die "Parsing $self->{file} failed: $err" };

    return 1;
}

sub _evaluate {
    my $_environment = $_[0];
    eval $_[1];
}

sub prereqs { $_[0]->{prereqs} }

sub mirrors { $_[0]->{mirrors} }

# DSL goes from here

sub on {
    my($self, $phase, $code) = @_;
    local $self->{phase} = $phase;
    $code->();
}

sub feature {
    my($self, $identifier, $description, $code) = @_;

    # shortcut: feature identifier => sub { ... }
    if (@_ == 3 && ref($description) eq 'CODE') {
        $code = $description;
        $description = $identifier;
    }

    unless (ref $description eq '' && ref $code eq 'CODE') {
        Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }");
    }

    local $self->{feature} = $identifier;
    $self->prereqs->add_feature($identifier, $description);

    $code->();
}

sub osname { die "TODO" }

sub mirror {
    my($self, $url) = @_;
    push @{$self->{mirrors}}, $url;
}

sub requirement_for {
    my($self, $module, @args) = @_;

    my $requirement = 0;
    $requirement = shift @args if @args % 2;

    return Module::CPANfile::Requirement->new(
        name    => $module,
        version => $requirement,
        @args,
    );
}

sub requires {
    my $self = shift;
    $self->add_prereq(requires => @_);
}

sub recommends {
    my $self = shift;
    $self->add_prereq(recommends => @_);
}

sub suggests {
    my $self = shift;
    $self->add_prereq(suggests => @_);
}

sub conflicts {
    my $self = shift;
    $self->add_prereq(conflicts => @_);
}

sub add_prereq {
    my($self, $type, $module, @args) = @_;

    $self->prereqs->add_prereq(
        feature => $self->{feature},
        phase   => $self->{phase},
        type    => $type,
        module  => $module,
        requirement => $self->requirement_for($module, @args),
    );
}

# Module::Install compatible shortcuts

sub configure_requires {
    my($self, @args) = @_;
    $self->on(configure => sub { $self->requires(@args) });
}

sub build_requires {
    my($self, @args) = @_;
    $self->on(build => sub { $self->requires(@args) });
}

sub test_requires {
    my($self, @args) = @_;
    $self->on(test => sub { $self->requires(@args) });
}

sub author_requires {
    my($self, @args) = @_;
    $self->on(develop => sub { $self->requires(@args) });
}

1;