Module-CPANfile-1.1000HEADModule-CPANfile-1.1000master

4 files changed, 336 insertions, 0 deletions

diff --git a/lib/Module/CPANfile/Environment.pm b/lib/Module/CPANfile/Environment.pm
new file mode 100644
index 0000000..e1c0ea1
--- /dev/null
+++ b/lib/Module/CPANfile/Environment.pm
@@ -0,0 +1,173 @@
+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;
+
diff --git a/lib/Module/CPANfile/Prereq.pm b/lib/Module/CPANfile/Prereq.pm
new file mode 100644
index 0000000..cf675f1
--- /dev/null
+++ b/lib/Module/CPANfile/Prereq.pm
@@ -0,0 +1,21 @@
+package Module::CPANfile::Prereq;
+use strict;
+
+sub new {
+    my($class, %options) = @_;
+    bless \%options, $class;
+}
+
+sub feature { $_[0]->{feature} }
+sub phase   { $_[0]->{phase} }
+sub type    { $_[0]->{type} }
+sub module  { $_[0]->{module} }
+sub requirement { $_[0]->{requirement} }
+
+sub match_feature {
+    my($self, $identifier) = @_;
+    no warnings 'uninitialized';
+    $self->feature eq $identifier;
+}
+
+1;
diff --git a/lib/Module/CPANfile/Prereqs.pm b/lib/Module/CPANfile/Prereqs.pm
new file mode 100644
index 0000000..c3126ea
--- /dev/null
+++ b/lib/Module/CPANfile/Prereqs.pm
@@ -0,0 +1,117 @@
+package Module::CPANfile::Prereqs;
+use strict;
+use Carp ();
+use CPAN::Meta::Feature;
+use Module::CPANfile::Prereq;
+
+sub from_cpan_meta {
+    my($class, $prereqs) = @_;
+
+    my $self = $class->new;
+
+    for my $phase (keys %$prereqs) {
+        for my $type (keys %{ $prereqs->{$phase} }) {
+            while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) {
+                $self->add_prereq(
+                    phase => $phase,
+                    type  => $type,
+                    module => $module,
+                    requirement => Module::CPANfile::Requirement->new(name => $module, version => $requirement),
+                );
+            }
+        }
+    }
+
+    $self;
+}
+
+sub new {
+    my $class = shift;
+    bless {
+        prereqs => [],
+        features => {},
+    }, $class;
+}
+
+sub add_feature {
+    my($self, $identifier, $description) = @_;
+    $self->{features}{$identifier} = { description => $description };
+}
+
+sub add_prereq {
+    my($self, %args) = @_;
+    $self->add( Module::CPANfile::Prereq->new(%args) );
+}
+
+sub add {
+    my($self, $prereq) = @_;
+    push @{$self->{prereqs}}, $prereq;
+}
+
+sub as_cpan_meta {
+    my $self = shift;
+    $self->{cpanmeta} ||= $self->build_cpan_meta;
+}
+
+sub build_cpan_meta {
+    my($self, $identifier) = @_;
+
+    my $prereq_spec = {};
+    $self->prereq_each($identifier, sub {
+        my $prereq = shift;
+        $prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module} = $prereq->requirement->version;
+    });
+
+    CPAN::Meta::Prereqs->new($prereq_spec);
+}
+
+sub prereq_each {
+    my($self, $identifier, $code) = @_;
+
+    for my $prereq (@{$self->{prereqs}}) {
+        next unless $prereq->match_feature($identifier);
+        $code->($prereq);
+    }
+}
+
+sub merged_requirements {
+    my $self = shift;
+
+    my $reqs = CPAN::Meta::Requirements->new;
+    for my $prereq (@{$self->{prereqs}}) {
+        $reqs->add_string_requirement($prereq->module, $prereq->requirement->version);
+    }
+
+    $reqs;
+}
+
+sub find {
+    my($self, $module) = @_;
+
+    for my $prereq (@{$self->{prereqs}}) {
+        return $prereq if $prereq->module eq $module;
+    }
+
+    return;
+}
+
+sub identifiers {
+    my $self = shift;
+    keys %{$self->{features}};
+}
+
+sub feature {
+    my($self, $identifier) = @_;
+
+    my $data = $self->{features}{$identifier}
+      or Carp::croak("Unknown feature '$identifier'");
+
+    my $prereqs = $self->build_cpan_meta($identifier);
+
+    CPAN::Meta::Feature->new($identifier, {
+        description => $data->{description},
+        prereqs => $prereqs->as_string_hash,
+    });
+}
+
+1;
diff --git a/lib/Module/CPANfile/Requirement.pm b/lib/Module/CPANfile/Requirement.pm
new file mode 100644
index 0000000..01c6358
--- /dev/null
+++ b/lib/Module/CPANfile/Requirement.pm
@@ -0,0 +1,25 @@
+package Module::CPANfile::Requirement;
+use strict;
+
+sub new {
+    my ($class, %args) = @_;
+
+    $args{version} ||= 0;
+
+    bless +{
+        name    => delete $args{name},
+        version => delete $args{version},
+        options => \%args,
+    }, $class;
+}
+
+sub name    { $_[0]->{name} }
+sub version { $_[0]->{version} }
+
+sub options { $_[0]->{options} }
+
+sub has_options {
+    keys %{$_[0]->{options}} > 0;
+}
+
+1;