Massive refactor to eliminate Result intermediate class and add Featu…

…re/Prereqs objects
miyagawa · Sep 19, 2013 · 674222d · 674222d
1 parent 8d62a1b
commit 674222d
Show file tree

Hide file tree

Showing 7 changed files with 201 additions and 155 deletions.
diff --git a/cpanfile b/cpanfile
@@ -1,5 +1,6 @@
 requires 'CPAN::Meta', 2.12091;
 requires 'CPAN::Meta::Prereqs', 2.12091;
+requires 'parent';
 
 recommends 'Pod::Usage';
 

diff --git a/lib/Module/CPANfile.pm b/lib/Module/CPANfile.pm
@@ -4,8 +4,9 @@ use warnings;
 use Cwd;
 use Carp ();
 use Module::CPANfile::Environment;
+use Module::CPANfile::Features;
+use Module::CPANfile::Prereqs;
 use Module::CPANfile::Requirement;
-use Module::CPANfile::Result;
 
 our $VERSION = '1.0002';
 
@@ -38,42 +39,36 @@ sub parse {
     };
 
     my $env = Module::CPANfile::Environment->new($file);
-    $self->{result} = $env->parse($code) or die $@;
+    $env->parse($code) or die $@;
+
+    $self->{_features} = Module::CPANfile::Features->new($env->features);
+    $self->{_prereqs}  = Module::CPANfile::Prereqs->new($env->prereqs);
 }
 
 sub from_prereqs {
     my($proto, $prereqs) = @_;
 
     my $self = $proto->new;
-    $self->{result} = Module::CPANfile::Result->from_prereqs($prereqs);
+    $self->{_prereqs} = Module::CPANfile::Prereqs->new($prereqs);
 
     $self;
 }
 
 sub features {
     my $self = shift;
-    map $self->feature($_), keys %{$self->{result}{features}};
+    $self->{_features} ? $self->{_features}->all : ();
 }
 
 sub feature {
     my($self, $identifier) = @_;
-
-    my $data = $self->{result}{features}{$identifier}
-      or Carp::croak("Unknown feature '$identifier'");
-
-    require CPAN::Meta::Feature;
-    CPAN::Meta::Feature->new($data->{identifier}, {
-        description => $data->{description},
-        prereqs => $self->_normalize_prereqs($data->{spec}),
-    });
+    $self->{_features}->get($identifier);
 }
 
 sub prereq { shift->prereqs }
 
 sub prereqs {
     my $self = shift;
-    require CPAN::Meta::Prereqs;
-    CPAN::Meta::Prereqs->new($self->prereq_specs);
+    $self->{_prereqs};
 }
 
 sub effective_prereqs {
@@ -92,23 +87,7 @@ sub prereqs_with {
 
 sub prereq_specs {
     my $self = shift;
-    $self->_normalize_prereqs($self->{result}{spec});
-}
-
-sub _normalize_prereqs {
-    my($self, $prereqs) = @_;
-
-    my $copy = {};
-
-    for my $phase (keys %$prereqs) {
-        for my $type (keys %{ $prereqs->{$phase} }) {
-            while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) {
-                $copy->{$phase}{$type}{$module} = ref $requirement ? $requirement->version : $requirement;
-            }
-        }
-    }
-
-    $copy;
+    $self->prereqs->as_string_hash;
 }
 
 sub merge_meta {
@@ -137,12 +116,12 @@ sub _dump {
 sub to_string {
     my($self, $include_empty) = @_;
 
-    my $prereqs = $self->{result}{spec};
+    my $prereqs = $self->prereq_specs;
 
     my $code = '';
-    $code .= $self->_dump_prereqs($self->{result}{spec}, $include_empty);
+    $code .= $self->_dump_prereqs($prereqs, $include_empty);
 
-    for my $feature (values %{$self->{result}{features}}) {
+    for my $feature ($self->features) {
         $code .= sprintf "feature %s, %s => sub {\n", _dump($feature->{identifier}), _dump($feature->{description});
         $code .= $self->_dump_prereqs($feature->{spec}, $include_empty, 4);
         $code .= "}\n\n";

diff --git a/lib/Module/CPANfile/Environment.pm b/lib/Module/CPANfile/Environment.pm
@@ -16,48 +16,140 @@ my $file_id = 1;
 sub new {
     my($class, $file) = @_;
     bless {
-        file => $file,
+        file     => $file,
+        phase    => 'runtime', # default phase
+        features => {},
+        feature  => undef,
+        prereqs  => {},
     }, $class;
 }
 
 sub bind {
-    my $class = shift;
+    my $self = shift;
     my $pkg = caller;
 
-    my $result = Module::CPANfile::Result->new;
     for my $binding (@bindings) {
         no strict 'refs';
-        *{"$pkg\::$binding"} = sub { $result->$binding(@_) };
+        *{"$pkg\::$binding"} = sub { $self->$binding(@_) };
     }
-
-    return $result;
 }
 
 sub parse {
     my($self, $code) = @_;
 
-    my($res, $err);
-
+    my $err;
     {
         local $@;
         $file_id++;
-        $res = eval <<EVAL;
+        $self->_evaluate(<<EVAL);
 package Module::CPANfile::Sandbox$file_id;
 no warnings;
-my \$_result;
-BEGIN { \$_result = Module::CPANfile::Environment->bind }
+BEGIN { \$_environment->bind }
 
 # line 1 "$self->{file}"
 $code;
-
-\$_result;
 EVAL
         $err = $@;
     }
 
     if ($err) { die "Parsing $self->{file} failed: $err" };
 
-    return $res;
+    return 1;
+}
+
+sub _evaluate {
+    my $_environment = $_[0];
+    eval $_[1];
+}
+
+sub features { $_[0]->{features} }
+sub prereqs  { $_[0]->{prereqs} }
+
+# 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} = $self->{features}{$identifier}
+      = { identifier => $identifier, description => $description, prereqs => {} };
+    $code->();
+}
+
+sub osname { die "TODO" }
+
+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, $module, @args) = @_;
+    ($self->{feature} ? $self->{feature}{prereqs} : $self->{prereqs})
+      ->{$self->{phase}}{requires}{$module} = $self->requirement_for($module, @args);
+}
+
+sub recommends {
+    my($self, $module, @args) = @_;
+    ($self->{feature} ? $self->{feature}{prereqs} : $self->{prereqs})
+      ->{$self->{phase}}{recommends}{$module} = $self->requirement_for($module, @args);
+}
+
+sub suggests {
+    my($self, $module, @args) = @_;
+    ($self->{feature} ? $self->{feature}{prereqs} : $self->{prereqs})
+      ->{$self->{phase}}{suggests}{$module} = $self->requirement_for($module, @args);
+}
+
+sub conflicts {
+    my($self, $module, @args) = @_;
+    ($self->{feature} ? $self->{feature}{prereqs} : $self->{prereqs})
+      ->{$self->{phase}}{conflicts}{$module} = $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/Feature.pm b/lib/Module/CPANfile/Feature.pm
@@ -0,0 +1,15 @@
+package Module::CPANfile::Feature;
+use strict;
+use parent qw(CPAN::Meta::Feature);
+
+sub new {
+    my($class, $identifier, $spec) = @_;
+
+    bless {
+        identifier  => $identifier,
+        description => $spec->{description},
+        prereqs     => Module::CPANfile::Prereqs->new($spec->{prereqs}),
+    }, $class;
+}
+
+1;
diff --git a/lib/Module/CPANfile/Features.pm b/lib/Module/CPANfile/Features.pm
@@ -0,0 +1,34 @@
+package Module::CPANfile::Features;
+use strict;
+use Carp ();
+use Module::CPANfile::Feature;
+
+sub new {
+    my($class, $features) = @_;
+    bless { features => $features }, $class;
+}
+
+sub identifiers {
+    my $self = shift;
+    keys %{$self->{features}};
+}
+
+sub all {
+    my $self = shift;
+    map $self->get($_), $self->identifiers;
+}
+
+sub get {
+    my($self, $identifier) = @_;
+
+    my $data = $self->{features}{$identifier}
+      or Carp::croak("Unknown feature '$identifier'");
+
+    Module::CPANfile::Feature->new($data->{identifier}, {
+        description => $data->{description},
+        prereqs => $data->{prereqs},
+    });
+}
+
+1;
+
diff --git a/lib/Module/CPANfile/Prereqs.pm b/lib/Module/CPANfile/Prereqs.pm
@@ -0,0 +1,31 @@
+package Module::CPANfile::Prereqs;
+use strict;
+use parent qw(CPAN::Meta::Prereqs);
+
+sub _normalize_prereqs {
+    my $prereqs = shift;
+
+    my $copy = {};
+
+    for my $phase (keys %$prereqs) {
+        for my $type (keys %{ $prereqs->{$phase} }) {
+            while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) {
+                $copy->{$phase}{$type}{$module} = ref $requirement ? $requirement->version : $requirement;
+            }
+        }
+    }
+
+    $copy;
+}
+
+sub new {
+    my($class, $prereq_spec) = @_;
+
+    my $prereqs = _normalize_prereqs($prereq_spec);
+    my $self = $class->SUPER::new($prereqs);
+    $self->{_prereq_spec} = $prereq_spec;
+    $self;
+}
+
+1;
+