From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 7 Nov 2010 05:11:51 +0000 (+0000)
Subject: deferred constructor construction
X-Git-Tag: 0.009001~65
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=14f3203234f0758b7af103010ca709b9e47aa60e;p=gitmo%2FMoo.git

deferred constructor construction
---

diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm
index c36c3ec..2e308da 100644
--- a/lib/Class/Tiny.pm
+++ b/lib/Class/Tiny.pm
@@ -3,6 +3,8 @@ package Class::Tiny;
 use strictures 1;
 use Class::Tiny::_Utils;
 
+our %MAKERS;
+
 sub import {
   my $target = caller;
   strictures->import;
@@ -14,6 +16,17 @@ sub import {
     die "Only one role supported at a time by with" if @_ > 1;
     Role::Tiny->apply_role_to_package($_[0], $target);
   };
+  *{_getglob("${target}::has")} = sub {
+    my ($name, %spec) = @_;
+    ($MAKERS{$target}{accessor} ||= do {
+      require Method::Generate::Accessor;
+      Method::Generate::Accessor->new
+    })->generate_method($target, $name, \%spec);
+    ($MAKERS{$target}{constructor} ||= do {
+      require Method::Generate::Constructor;
+      Method::Generate::Constructor->new(package => $target)->install_delayed
+    })->register_attribute_spec($name, \%spec);
+  };
   foreach my $type (qw(before after around)) {
     *{_getglob "${target}::${type}"} = sub {
       _install_modifier($target, $type, @_);
diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm
index 0cecf2d..b08385d 100644
--- a/lib/Method/Generate/Constructor.pm
+++ b/lib/Method/Generate/Constructor.pm
@@ -3,13 +3,23 @@ package Method::Generate::Constructor;
 use strictures 1;
 use Sub::Quote;
 use base qw(Class::Tiny::Object);
+use Sub::Defer;
 
-##{
-##  use Method::Generate::Accessor;
-##  my $gen = Method::Generate::Accessor->new;
-##  $gen->generate_method(__PACKAGE__, $_, { is => 'ro' })
-##    for qw(accessor_generator);
-##}
+sub register_attribute_spec {
+  my ($self, $name, $spec) = @_;
+  $self->{attribute_specs}{$name} = $spec;
+}
+
+sub install_delayed {
+  my ($self) = @_;
+  my $package = $self->{package};
+  defer_sub "${package}::new" => sub {
+    unquote_sub $self->generate_method(
+      $package, 'new', $self->{attribute_specs}, { no_install => 1 }
+    )
+  };
+  $self;
+}
 
 sub generate_method {
   my ($self, $into, $name, $spec, $quote_opts) = @_;
@@ -44,6 +54,7 @@ sub _assign_new {
     };
     push @slots, $name;
   }
+  return '' unless @init;
   '    @{$new}{qw('.join(' ',@slots).')} = @{$args}{qw('.join(' ',@init).')};'
     ."\n";
 }
diff --git a/t/class-tiny-accessors.t b/t/class-tiny-accessors.t
new file mode 100644
index 0000000..053b01c
--- /dev/null
+++ b/t/class-tiny-accessors.t
@@ -0,0 +1,23 @@
+use strictures 1;
+use Test::More;
+
+{
+  package Foo;
+
+  use Class::Tiny;
+
+  has one => (is => 'ro');
+  has two => (is => 'rw', init_arg => undef);
+  has three => (is => 'ro', init_arg => 'THREE', required => 1);
+}
+
+my $foo = Foo->new(
+  one => 1,
+  THREE => 3
+);
+
+is_deeply(
+  { %$foo }, { one => 1, three => 3 }, 'internals ok'
+);
+
+done_testing;