Skip to content
Browse files

Massive refactor to eliminate Result intermediate class and add Featu…

…re/Prereqs objects
  • Loading branch information...
1 parent 8d62a1b commit 674222d21d2c74b3885f00523f30f2981085b816 @miyagawa committed Sep 19, 2013
View
1 cpanfile
@@ -1,5 +1,6 @@
requires 'CPAN::Meta', 2.12091;
requires 'CPAN::Meta::Prereqs', 2.12091;
+requires 'parent';
recommends 'Pod::Usage';
View
49 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";
View
120 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;
View
15 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;
View
34 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;
+
View
31 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;
+
View
106 lib/Module/CPANfile/Result.pm
@@ -1,106 +0,0 @@
-package Module::CPANfile::Result;
-use strict;
-
-sub from_prereqs {
- my($class, $spec) = @_;
- bless {
- phase => 'runtime',
- spec => $spec,
- }, $class;
-}
-
-sub new {
- bless {
- phase => 'runtime', # default phase
- features => {},
- feature => undef,
- spec => {},
- }, shift;
-}
-
-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, spec => {} };
- $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}{spec} : $self->{spec})
- ->{$self->{phase}}{requires}{$module} = $self->requirement_for($module, @args);
-}
-
-sub recommends {
- my($self, $module, @args) = @_;
- ($self->{feature} ? $self->{feature}{spec} : $self->{spec})
- ->{$self->{phase}}{recommends}{$module} = $self->requirement_for($module, @args);
-}
-
-sub suggests {
- my($self, $module, @args) = @_;
- ($self->{feature} ? $self->{feature}{spec} : $self->{spec})
- ->{$self->{phase}}{suggests}{$module} = $self->requirement_for($module, @args);
-}
-
-sub conflicts {
- my($self, $module, @args) = @_;
- ($self->{feature} ? $self->{feature}{spec} : $self->{spec})
- ->{$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;

0 comments on commit 674222d

Please sign in to comment.
Something went wrong with that request. Please try again.