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 <dagol...@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 _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits