[libclass-tiny-perl] 02/05: implement lazy defaults

[gregor herrmann]

This is an automated email from the git hooks/post-receive script.

gregoa pushed a commit to annotated tag release-0.005
in repository libclass-tiny-perl.

commit afc5430725bf18d8c6d4694ec1258a30b97da7c7
Author: David Golden <dagolden at cpan.org>
Date:   Wed Aug 21 17:36:01 2013 -0400

    implement lazy defaults
---
 lib/Class/Tiny.pm | 50 ++++++++++++++++++++++++++++++++++++++++----------
 t/golf.t          | 35 +++++++++++++++++++++++++++++++++++
 t/lib/Golf.pm     | 12 ++++++++++++
 3 files changed, 87 insertions(+), 10 deletions(-)

diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm
index 211c9ee..76ec15a 100644
--- a/lib/Class/Tiny.pm
+++ b/lib/Class/Tiny.pm
@@ -35,20 +35,35 @@ sub prepare_class {
 # adapted from Object::Tiny and Object::Tiny::RW
 sub create_attributes {
     no strict 'refs';
-    my ( $class, $pkg, @attr ) = @_;
-    @attr = grep {
+    my ( $class, $pkg, @spec ) = @_;
+    my %defaults = map { ref $_ eq 'HASH' ? %$_ : ( $_ => undef ) } @spec;
+    my @attr = grep {
         defined and !ref and /^[^\W\d]\w*$/s
           or Carp::croak "Invalid accessor name '$_'"
-    } @attr;
-    $CLASS_ATTRIBUTES{$pkg}{$_} = undef for @attr;
+    } keys %defaults;
+    $CLASS_ATTRIBUTES{$pkg}{$_} = $defaults{$_} for @attr;
     #<<< No perltidy
     eval join "\n", ## no critic: intentionally eval'ing subs here
-      "package $pkg;",
+      "package $pkg;\n",
       map {
-        "sub $_ { return \@_ == 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }\n"
+      <<CODE
+        sub $_ {
+            if ( \@_ == 1 ) {
+                if ( !exists \$_[0]{$_} && defined \$CLASS_ATTRIBUTES{'$pkg'}{$_} ) {
+                    \$_[0]{$_} = ref \$CLASS_ATTRIBUTES{'$pkg'}{$_} eq 'CODE' 
+                        ? \$CLASS_ATTRIBUTES{'$pkg'}{$_}->(\$_[0])
+                        : \$CLASS_ATTRIBUTES{'$pkg'}{$_};
+                }
+                return \$_[0]{$_};
+            }
+            else {
+                return \$_[0]{$_} = \$_[1];
+            }
+        }
+CODE
       } grep { ! *{"$pkg\::$_"}{CODE} } @attr;
     #>>>
-    Carp::croak("Failed to generate attributes for $pkg: @attr") if $@;
+    Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
     return;
 }
 
@@ -166,6 +181,7 @@ code.  Here is a list of features:
 =for :list
 * defines attributes via import arguments
 * generates read-write accessors
+* supports lazy attribute defaults
 * supports custom accessors
 * superclass provides a standard C<new> constructor
 * C<new> takes a hash reference or list of key/value pairs
@@ -210,7 +226,7 @@ Define attributes as a list of import arguments:
         weight
     );
 
-For each item, a read-write accessor is created unless a subroutine of that
+For each attribute, a read-write accessor is created unless a subroutine of that
 name already exists:
 
     $obj->name;               # getter
@@ -219,6 +235,19 @@ name already exists:
 Attribute names must be valid subroutine identifiers or an exception will
 be thrown.
 
+You can specify lazy defaults by defining attributes with a hash reference.
+Keys define attribute names and values are constants or code references that
+will be evaluated when the attribute is first accessed if no value has been
+set.  The object is passed as an argument to a code reference.
+
+    package Foo::WithDefaults;
+
+    use Class::Tiny qw/name id/, {
+        title     => 'Peon',
+        skills    => sub { [] },
+        hire_date => sub { $_[0]->_build_hire_date }, 
+    };
+
 To make your own custom accessors, just pre-declare the method name before
 loading Class::Tiny:
 
@@ -230,8 +259,9 @@ loading Class::Tiny:
 
     sub id { ... }
 
-By declaring C<id> also with Class::Tiny, you include it in the list
-of allowed constructor parameters.
+By declaring C<id> also with Class::Tiny, you include it in the list of known
+attributes for introspection.  Default values will not be set for custom
+accessors unless you handle that yourself.
 
 =head2 Class::Tiny::Object is your base class
 
diff --git a/t/golf.t b/t/golf.t
new file mode 100644
index 0000000..8d0395e
--- /dev/null
+++ b/t/golf.t
@@ -0,0 +1,35 @@
+use 5.008001;
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More 0.96;
+use TestUtils;
+
+require_ok("Golf");
+
+subtest "lazy defaults" => sub {
+    my $obj = new_ok("Golf");
+    is( $obj->foo, undef, "foo is undef" );
+    is( $obj->bar, undef, "bar is undef" );
+    ok( !exists( $obj->{wibble} ), "lazy wibble doesn't exist" );
+    ok( !exists( $obj->{wobble} ), "lazy wobble doesn't exist" );
+    is( $obj->wibble,     42,      "wibble access gives default" );
+    is( ref $obj->wobble, 'ARRAY', "wobble access gives default" );
+    ok( exists( $obj->{wibble} ), "lazy wibble does exist" );
+    ok( exists( $obj->{wobble} ), "lazy wobble does exist" );
+    my $obj2 = new_ok("Golf");
+    isnt( $obj->wobble, $obj2->wobble, "coderefs run for each object" );
+};
+
+subtest "exceptions" => sub {
+    like(
+        exception { Golf->new( foo => 23, bar => 42, zoom => 13 ) },
+        qr/Invalid attributes for Golf: zoom/,
+        "creating object with 'baz' dies",
+    );
+};
+
+done_testing;
+# COPYRIGHT
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/lib/Golf.pm b/t/lib/Golf.pm
new file mode 100644
index 0000000..315e58b
--- /dev/null
+++ b/t/lib/Golf.pm
@@ -0,0 +1,12 @@
+use 5.008001;
+use strict;
+use warnings;
+
+package Golf;
+
+use Class::Tiny qw/foo bar/, {
+    wibble => 42,
+    wobble => sub { [] },
+}, qw/zig zag/;
+
+1;

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libclass-tiny-perl.git