From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 7 Nov 2010 04:00:43 +0000 (+0000)
Subject: constructor generation, add option to quote_sub to name without installing
X-Git-Tag: 0.009001~69
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6f68f0223ec7172929c907fc898c1ef0785c71f2;p=gitmo%2FRole-Tiny.git

constructor generation, add option to quote_sub to name without installing
---

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 292900d..b473764 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -7,7 +7,7 @@ use Sub::Quote;
 use B 'perlstring';
 
 sub generate_method {
-  my ($self, $into, $name, $spec) = @_;
+  my ($self, $into, $name, $spec, $quote_opts) = @_;
   die "Must have an is" unless my $is = $spec->{is};
   my $name_str = perlstring $name;
   my $body = do {
@@ -19,7 +19,10 @@ sub generate_method {
       die "Unknown is ${is}";
     }
   };
-  quote_sub "${into}::${name}" => '    '.$body."\n";
+  quote_sub
+    "${into}::${name}" => '    '.$body."\n",
+    (ref($quote_opts) ? ({}, $quote_opts) : ())
+  ;
 }
 
 sub _generate_get {
diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm
new file mode 100644
index 0000000..d8578b3
--- /dev/null
+++ b/lib/Method/Generate/Constructor.pm
@@ -0,0 +1,64 @@
+package Method::Generate::Constructor;
+
+use strictures 1;
+use Sub::Quote;
+use base qw(Class::Tiny::Object);
+
+##{
+##  use Method::Generate::Accessor;
+##  my $gen = Method::Generate::Accessor->new;
+##  $gen->generate_method(__PACKAGE__, $_, { is => 'ro' })
+##    for qw(accessor_generator);
+##}
+
+sub generate_method {
+  my ($self, $into, $name, $spec, $quote_opts) = @_;
+  foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) {
+    $spec->{$no_init}{init_arg} = $no_init;
+  }
+  my $body = '    my $class = shift;'."\n";
+  $body .= $self->_generate_args;
+  $body .= $self->_check_required($spec);
+  $body .= '    my $new = bless({}, $class);'."\n";
+  $body .= $self->_assign_new($spec);
+  $body .= '    return $new;';
+  quote_sub
+    "${into}::${name}" => '    '.$body."\n",
+    (ref($quote_opts) ? ({}, $quote_opts) : ())
+  ;
+}
+
+sub _generate_args {
+  my ($self) = @_;
+  q{    my $args = ref($_[0]) eq 'HASH' ? $_[0] : { @_ };}."\n";
+}
+
+sub _assign_new {
+  my ($self, $spec) = @_;
+  my (@init, @slots);
+  NAME: foreach my $name (keys %$spec) {
+    my $attr_spec = $spec->{$name};
+    push @init, do {
+      next NAME unless defined(my $i = $attr_spec->{init_arg});
+      $i;
+    };
+    push @slots, $name;
+  }
+  '    @{$new}{qw('.join(' ',@slots).')} = @{$args}{qw('.join(' ',@init).')};'
+    ."\n";
+}
+
+sub _check_required {
+  my ($self, $spec) = @_;
+  my @required_init =
+    map $spec->{$_}{init_arg},
+      grep $spec->{$_}{required},
+	keys %$spec;
+  return '' unless @required_init;
+  '    if (my @missing = grep !exists $args->{$_}, qw('
+    .join(' ',@required_init).')) {'."\n"
+    .q{      die "Missing required arguments: ".join(', ', sort @missing);}."\n"
+    ."    }\n";
+}
+
+1;
diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm
index 485f6d3..38f4ea4 100644
--- a/lib/Sub/Quote.pm
+++ b/lib/Sub/Quote.pm
@@ -74,15 +74,20 @@ sub _unquote_all_outstanding {
 
 sub quote_sub {
   # HOLY DWIMMERY, BATMAN!
+  # $name => $code => \%captures => \%options
   # $name => $code => \%captures
   # $name => $code
-  # $code => \%captures
+  # $code => \%captures => \%options
   # $code
+  my $options =
+    (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
+      ? pop
+      : {};
   my $captures = pop if ref($_[-1]) eq 'HASH';
   my $code = pop;
   my $name = $_[0];
   my $outstanding;
-  my $deferred = defer_sub $name => sub {
+  my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
     unquote_sub($outstanding);
   };
   $outstanding = "$deferred";
diff --git a/t/method-generate-accessor.t b/t/method-generate-accessor.t
index 3b2af68..4c15a94 100644
--- a/t/method-generate-accessor.t
+++ b/t/method-generate-accessor.t
@@ -16,12 +16,12 @@ $gen->generate_method('Foo' => 'one' => { is => 'ro' });
 $gen->generate_method('Foo' => 'two' => { is => 'rw' });
 
 like(
-  exception { $gen->generate_methods('Foo' => 'three' => {}) },
+  exception { $gen->generate_method('Foo' => 'three' => {}) },
   qr/Must have an is/, 'No is rejected'
 );
 
 like(
-  exception { $gen->generate_methods('Foo' => 'three' => { is => 'purple' }) },
+  exception { $gen->generate_method('Foo' => 'three' => { is => 'purple' }) },
   qr/Unknown is purple/, 'is purple rejected'
 );
 
diff --git a/t/method-generate-constructor.t b/t/method-generate-constructor.t
new file mode 100644
index 0000000..96d604c
--- /dev/null
+++ b/t/method-generate-constructor.t
@@ -0,0 +1,51 @@
+use strictures 1;
+use Test::More;
+use Test::Fatal;
+
+use Method::Generate::Constructor;
+
+my $gen = Method::Generate::Constructor->new;
+
+$gen->generate_method('Foo', 'new', {
+  one => { },
+  two => { init_arg => undef },
+  three => { init_arg => 'THREE' }
+});
+
+my $first = Foo->new({
+  one => 1,
+  two => 2,
+  three => -75,
+  THREE => 3,
+  four => 4,
+});
+
+is_deeply(
+  { %$first }, { one => 1, three => 3 },
+  'init_arg handling ok'
+);
+
+$gen->generate_method('Bar', 'new' => {
+  one => { required => 1 },
+  three => { init_arg => 'THREE', required => 1 }
+});
+
+like(
+  exception { Bar->new },
+  qr/Missing required arguments: THREE, one/,
+  'two missing args reported correctly'
+);
+
+like(
+  exception { Bar->new(THREE => 3) },
+  qr/Missing required arguments: one/,
+  'one missing arg reported correctly'
+);
+
+is(
+  exception { Bar->new(one => 1, THREE => 3) },
+  undef,
+  'pass with both required args'
+);
+
+done_testing;