[libclass-tiny-perl] 07/11: Change constructor behavior: permissive and non-polluting
gregor herrmann
gregoa at debian.org
Sun May 31 14:03:53 UTC 2015
This is an automated email from the git hooks/post-receive script.
gregoa pushed a commit to annotated tag release-1.000
in repository libclass-tiny-perl.
commit 5cab2ad964b0980b1fad73d9408b6cf9457bb229
Author: David Golden <dagolden at cpan.org>
Date: Tue Jul 15 19:32:34 2014 -0400
Change constructor behavior: permissive and non-polluting
This is a backwards-breaking change.
First, unknown constructor arguments are now ignored rather than being
fatal. This makes interoperation with other object systems much easier.
For example, Moo or Moose can now subclass Class::Tiny classes with
less work.
Second, this means that all attributes, including custom ones, must
be declared. Only declared attributes are populated into the new
object.
Third, as a side-benefit of declaration, attributes with custom
accessors can have defaults and the custom accessor merely needs to use
the introspection API to retrieve and use it.
---
lib/Class/Tiny.pm | 109 ++++++++++++++++++++++++++----------------------------
t/alfa.t | 11 +++---
t/baker.t | 9 -----
t/charlie.t | 5 +++
t/delta.t | 7 ----
t/echo.t | 7 ----
t/golf.t | 8 ----
t/juliett.t | 11 ------
t/lib/Charlie.pm | 13 ++++++-
t/lib/Delta.pm | 2 -
10 files changed, 73 insertions(+), 109 deletions(-)
diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm
index ac7eb36..6e99e2a 100644
--- a/lib/Class/Tiny.pm
+++ b/lib/Class/Tiny.pm
@@ -80,7 +80,7 @@ package Class::Tiny::Object;
# ABSTRACT: Base class for classes built with Class::Tiny
# VERSION
-my ( %LINEAR_ISA_CACHE, %BUILD_CACHE, %DEMOLISH_CACHE, %CAN_CACHE );
+my ( %LINEAR_ISA_CACHE, %BUILD_CACHE, %DEMOLISH_CACHE, %ATTR_CACHE );
my $_PRECACHE = sub {
my ($class) = @_;
@@ -93,12 +93,15 @@ my $_PRECACHE = sub {
$BUILD_CACHE{$s} = *{"$s\::BUILD"}{CODE};
$DEMOLISH_CACHE{$s} = *{"$s\::DEMOLISH"}{CODE};
}
+ $ATTR_CACHE{$class} =
+ { map { $_ => 1 } Class::Tiny->get_all_attributes_for($class) };
return $LINEAR_ISA_CACHE{$class};
};
sub new {
- my $class = shift;
- my $linear_isa = $LINEAR_ISA_CACHE{$class} || $_PRECACHE->($class);
+ my $class = shift;
+ my $linear_isa = $LINEAR_ISA_CACHE{$class} || $_PRECACHE->($class);
+ my $valid_attrs = $ATTR_CACHE{$class};
# handle hash ref or key/value arguments
my $args;
@@ -115,21 +118,14 @@ sub new {
}
# create object and invoke BUILD (unless we were given __no_BUILD__)
- my $no_build = delete $args->{__no_BUILD__};
- my $self = bless {%$args}, $class;
- for my $s ( $no_build ? () : reverse @$linear_isa ) {
+ my $self =
+ bless { map { $_ => $args->{$_} } grep { exists $valid_attrs->{$_} } keys %$args },
+ $class;
+ for my $s ( delete $args->{__no_BUILD__} ? () : reverse @$linear_isa ) {
next unless my $builder = $BUILD_CACHE{$s};
$builder->( $self, $args );
}
- # unknown attributes still in $args are fatal
- my @bad;
- for my $k ( keys %$args ) {
- push( @bad, $k )
- unless $CAN_CACHE{$class}{$k} ||= $self->can($k); # a heuristic to catch typos
- }
- Carp::croak("Invalid attributes for $class: @bad") if @bad;
-
return $self;
}
@@ -188,9 +184,9 @@ In F<example.pl>:
my $obj = Employee->new( name => "Larry", ssn => "111-22-3333" );
- # unknown attributes are fatal:
- eval { Employee->new( name => "Larry", OS => "Linux" ) };
- die "Error creating Employee: $@" if $@;
+ # unknown attributes are ignored
+ my $obj = Employee->new( name => "Larry", OS => "Linux" );
+ # $obj->{OS} does not exist
=head1 DESCRIPTION
@@ -204,7 +200,6 @@ code. Here is a list of features:
* supports custom accessors
* superclass provides a standard C<new> constructor
* C<new> takes a hash reference or list of key/value pairs
-* C<new> has heuristics to catch constructor attribute typos
* C<new> calls C<BUILD> for each class from parent to child
* superclass provides a C<DESTROY> method
* C<DESTROY> calls C<DEMOLISH> for each class from child to parent
@@ -268,9 +263,32 @@ loading Class::Tiny:
sub id { ... }
-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.
+Even if you pre-declare a method name, you must include it in the attribute
+list for Class::Tiny to register it as a valid attribute.
+
+If you set a default for a custom accessor, your accessor will need to retrieve
+the default and do something with it:
+
+ package Foo::Bar;
+
+ use subs 'id';
+
+ use Class::Tiny qw( name ), { id => sub { int(rand(2*31)) } };
+
+ sub id {
+ my $self = shift;
+ if (@_) {
+ return $self->{id} = shift;
+ }
+ elsif ( exists $self->{id} ) {
+ return $self->{id};
+ }
+ else {
+ my $defaults =
+ Class::Tiny->get_all_attribute_defaults_for( ref $self );
+ return $self->{id} = $defaults->{id}->();
+ }
+ }
=head2 Class::Tiny::Object is your base class
@@ -306,14 +324,11 @@ of key/value pairs:
$obj = Foo::Bar->new( { name => "David" } );
If a reference is passed as a single argument, it must be able to be
-dereferenced as a hash or an exception is thrown. A shallow copy is made of
-the reference provided.
+dereferenced as a hash or an exception is thrown.
-In order to help catch typos in constructor arguments, any argument that is
-not also a valid method (e.g. an accessor or other method) will result in a
-fatal exception. This is not perfect, but should catch typical transposition
-typos. Also see L</BUILD> for how to explicitly hide non-attribute, non-method
-arguments if desired.
+Unknown attributes in the constructor arguments will be ignored. Prior to
+version 1.000, unknown attributes were an error, but this made it harder for
+people to cleanly subclass Class::Tiny classes so this feature was removed.
=head2 BUILD
@@ -322,36 +337,17 @@ by the constructor from the furthest parent class down to the child class after
the object has been created.
It is passed the constructor arguments as a hash reference. The return value
-is ignored. Use C<BUILD> for validation or setting default values.
+is ignored. Use C<BUILD> for validation or setting default values that
+depend on other attributes.
sub BUILD {
my ($self, $args) = @_;
- $self->foo(42) unless defined $self->foo;
- croak "Foo must be non-negative" if $self->foo < 0;
- }
-
-If you want to hide a non-attribute constructor argument from validation,
-delete it from the passed-in argument hash reference.
-
- sub BUILD {
- my ($self, $args) = @_;
-
- if ( delete $args->{do_something_special} ) {
- ...
- }
+ $self->msg( "Hello " . $self->name );
+ croak "Age must be non-negative" if $self->age < 0;
}
The argument reference is a copy, so deleting elements won't affect data in the
-object. You have to delete it from both if that's what you want.
-
- sub BUILD {
- my ($self, $args) = @_;
-
- if ( delete $args->{do_something_special} ) {
- delete $self->{do_something_special};
- ...
- }
- }
+original (but changes will be passed to other BUILD methods in C<@ISA>).
=head2 DEMOLISH
@@ -391,10 +387,10 @@ C<create_attributes> to set up the C<@ISA> array and attributes. Anyone
attempting to extend Class::Tiny itself should use these instead of mocking up
a call to C<import>.
-When the first object is created, linearized C<@ISA> and various subroutines
-references are cached for speed. Ensure that all inheritance and methods are
-in place before creating objects. (You don't want to be changing that once you
-create objects anyway, right?)
+When the first object is created, linearized C<@ISA>, the valid attribute list
+and various subroutine references are cached for speed. Ensure that all
+inheritance and methods are in place before creating objects. (You don't want
+to be changing that once you create objects anyway, right?)
=head1 RATIONALE
@@ -430,7 +426,6 @@ Specifically, here is how Class::Tiny ("C::T") compares to Object::Tiny
provides new yes yes yes
provides DESTROY yes no no
new takes either hashref or list yes no (list) no (hash)
- new validates arguments yes no no
Moo(se)-like BUILD/DEMOLISH yes no no
no extraneous methods via @ISA yes yes no
diff --git a/t/alfa.t b/t/alfa.t
index 780e2a2..b293590 100644
--- a/t/alfa.t
+++ b/t/alfa.t
@@ -58,13 +58,12 @@ subtest "attributes are RW" => sub {
is( $obj->foo, 24, "accessing foo returns changed value" );
};
-subtest "exceptions" => sub {
- like(
- exception { Alfa->new( foo => 23, bar => 42, baz => 13 ) },
- qr/Invalid attributes for Alfa: baz/,
- "creating object with 'baz' dies",
- );
+subtest "unknown attributes stripped" => sub {
+ my $obj = new_ok( "Alfa", [ { wibble => 1 } ], "new( wibble => 1 )" );
+ ok( !exists $obj->{wibble}, "unknown attribute 'wibble' not in object" );
+};
+subtest "exceptions" => sub {
like(
exception { Alfa->new(qw/ foo bar baz/) },
qr/Alfa->new\(\) got an odd number of elements/,
diff --git a/t/baker.t b/t/baker.t
index 36cfaf1..6e0aa26 100644
--- a/t/baker.t
+++ b/t/baker.t
@@ -59,15 +59,6 @@ subtest "attributes are RW" => sub {
is( $obj->baz, 42, "accessing baz returns changed value" );
};
-subtest "exceptions" => sub {
- like(
- exception { Baker->new( foo => 23, bar => 42, baz => 13, wibble => 0 ) },
- qr/Invalid attributes for Baker: wibble/,
- "creating object with 'wibble' dies",
- );
-
-};
-
done_testing;
# COPYRIGHT
# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/charlie.t b/t/charlie.t
index 3569196..48a0b91 100644
--- a/t/charlie.t
+++ b/t/charlie.t
@@ -19,6 +19,11 @@ subtest "custom accessor" => sub {
is_deeply( $obj->bar(qw/1 1 2 3 5/), [qw/1 1 2 3 5/], "bar is set" );
};
+subtest "custom accessor with default" => sub {
+ my $obj = new_ok( "Charlie", [ foo => 13, bar => [42] ] );
+ is( $obj->baz, 23, "custom accessor has default" );
+};
+
done_testing;
# COPYRIGHT
# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/delta.t b/t/delta.t
index 26e5e3e..54b4ef3 100644
--- a/t/delta.t
+++ b/t/delta.t
@@ -14,13 +14,6 @@ subtest "attribute set as list" => sub {
is( $obj->bar, 23, "bar is set" );
};
-subtest "hiding constructor argument" => sub {
- my $obj = new_ok( "Delta", [ foo => 42, bar => 23, hide_me => 1 ] );
- is( $obj->foo, 42, "foo is set" );
- is( $obj->bar, 23, "bar is set" );
- is( $obj->{hide_me}, 1, "hidden constructor argument still in object" );
-};
-
subtest "__no_BUILD__" => sub {
my $obj = new_ok( "Delta", [ __no_BUILD__ => 1 ], "new( __no_BUILD__ => 1 )" );
is( $Delta::counter, 0, "BUILD method didn't run" );
diff --git a/t/echo.t b/t/echo.t
index c5c87b7..4999d77 100644
--- a/t/echo.t
+++ b/t/echo.t
@@ -24,13 +24,6 @@ subtest "destructor" => sub {
is( $Delta::exception, 0, "cleanup worked in correct order" );
};
-subtest "constructor argument heuristic hiding" => sub {
- my $obj = new_ok( "Echo", [ foo => 42, bar => 23, a_method => 1 ] );
- is( $obj->foo, 42, "foo is set" );
- is( $obj->bar, 23, "bar is set" );
- is( $obj->{a_method}, 1, "hidden constructor argument still in object" );
-};
-
subtest "exceptions" => sub {
like(
exception { Echo->new( foo => 0, bar => 23 ) },
diff --git a/t/golf.t b/t/golf.t
index ebeec47..5892f11 100644
--- a/t/golf.t
+++ b/t/golf.t
@@ -22,14 +22,6 @@ subtest "lazy defaults" => sub {
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/juliett.t b/t/juliett.t
index e7adb20..db5be6f 100644
--- a/t/juliett.t
+++ b/t/juliett.t
@@ -74,17 +74,6 @@ subtest "attributes are RW" => sub {
is( $obj->kit, 31, "accessing kit rerutns changed value" );
};
-subtest "exceptions" => sub {
- like(
- exception {
- Juliett->new( foo => 23, bar => 42, baz => 13, qux => 11, kit => 31, wibble => 0 );
- },
- qr/Invalid attributes for Juliett: wibble/,
- "creating object with 'wibble' dies",
- );
-
-};
-
done_testing;
# COPYRIGHT
# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/lib/Charlie.pm b/t/lib/Charlie.pm
index 5ba6fab..7d312bd 100644
--- a/t/lib/Charlie.pm
+++ b/t/lib/Charlie.pm
@@ -4,9 +4,9 @@ use warnings;
package Charlie;
-use subs qw/bar/;
+use subs qw/bar baz/;
-use Class::Tiny qw/foo bar/;
+use Class::Tiny qw/foo bar/, { baz => 23 };
sub bar {
my $self = shift;
@@ -16,4 +16,13 @@ sub bar {
return $self->{bar};
}
+sub baz {
+ my $self = shift;
+ if (@_) {
+ $self->{baz} = shift;
+ }
+ return $self->{baz} ||=
+ Class::Tiny->get_all_attribute_defaults_for( ref $self )->{baz};
+}
+
1;
diff --git a/t/lib/Delta.pm b/t/lib/Delta.pm
index 6dd2837..119bb4f 100644
--- a/t/lib/Delta.pm
+++ b/t/lib/Delta.pm
@@ -19,8 +19,6 @@ sub BUILD {
$self->bar(42) unless defined $self->bar;
$counter++;
-
- delete $args->{hide_me};
}
sub DEMOLISH {
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libclass-tiny-perl.git
More information about the Pkg-perl-cvs-commits
mailing list