view release on metacpan or  search on metacpan

inc/Module/CPANfile/Environment.pm  view on Meta::CPAN

#line 1
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;