r20649 - in /branches/upstream/libcoat-perl/current: CHANGES lib/Coat.pm lib/Coat/Meta.pm lib/Coat/Object.pm lib/Coat/Types.pm t/027_handles.t t/029_predicate_clearer.t t/031_lazy_attr.t
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Tue Jun 3 17:30:31 UTC 2008
Author: gregoa
Date: Tue Jun 3 17:30:30 2008
New Revision: 20649
URL: http://svn.debian.org/wsvn/?sc=1&rev=20649
Log:
[svn-upgrade] Integrating new upstream version, libcoat-perl (0.330)
Added:
branches/upstream/libcoat-perl/current/t/029_predicate_clearer.t
branches/upstream/libcoat-perl/current/t/031_lazy_attr.t
Modified:
branches/upstream/libcoat-perl/current/CHANGES
branches/upstream/libcoat-perl/current/lib/Coat.pm
branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm
branches/upstream/libcoat-perl/current/lib/Coat/Object.pm
branches/upstream/libcoat-perl/current/lib/Coat/Types.pm
branches/upstream/libcoat-perl/current/t/027_handles.t
Modified: branches/upstream/libcoat-perl/current/CHANGES
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/CHANGES?rev=20649&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/CHANGES (original)
+++ branches/upstream/libcoat-perl/current/CHANGES Tue Jun 3 17:30:30 2008
@@ -1,3 +1,8 @@
+2008-06-01 -- release 0.330
+
+ * Possible to coerce from an external class
+ * support for lazy attributes
+
2008-05-18 -- release 0.320
* support for attr overloading (has '+foo')
Modified: branches/upstream/libcoat-perl/current/lib/Coat.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/lib/Coat.pm?rev=20649&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat.pm Tue Jun 3 17:30:30 2008
@@ -14,7 +14,7 @@
use Coat::Object;
use Coat::Types;
-$VERSION = '0.320';
+$VERSION = '0.330';
$AUTHORITY = 'cpan:SUKRIA';
# our exported keywords for class description
@@ -33,53 +33,31 @@
# has() declares an attribute and builds the corresponding accessors
sub has {
- my ( $attribute, %options ) = @_;
- confess "Attribute is a reference, cannot declare" if ref($attribute);
+ my ( $attr_name, %options ) = @_;
+ confess "Attribute is a reference, cannot declare" if ref($attr_name);
my $class = $options{'!caller'} || getscope();
- my $accessor = "${class}::${attribute}";
+ my $accessor = "${class}::${attr_name}";
# handle here attr overloading (eg: has '+foo' overload SUPER::foo)
- if ($attribute =~ /^\+(\S+)$/) {
- $attribute = $1;
+ if ($attr_name =~ /^\+(\S+)$/) {
+ $attr_name = $1;
my $inherited_attrs = Coat::Meta->all_attributes( $class );
- (exists $inherited_attrs->{$attribute}) ||
- confess "Cannot overload unknown attribute ($attribute)";
+ (exists $inherited_attrs->{$attr_name}) ||
+ confess "Cannot overload unknown attribute ($attr_name)";
- %options = (%{$inherited_attrs->{$attribute}}, %options );
- }
-
- my $attr = Coat::Meta->attribute( $class, $attribute, \%options);
-
- my $accessor_code = sub {
- my ( $self, $value ) = @_;
-
- # want a set()
- if ( @_ > 1 ) {
- confess "Cannot set a read-only attribute ($attribute)"
- if ($attr->{'is'} eq 'ro');
-
- $value = Coat::Types->validate( $attr, $attribute, $value );
- $self->{$attribute} = $value;
-
- # handle the trigger, if exists
- $attr->{'trigger'}->($self, $value)
- if defined $attr->{'trigger'};
-
- return $value;
- }
-
- # want a get()
- else {
- return $self->{$attribute};
- }
- };
+ %options = (%{$inherited_attrs->{$attr_name}}, %options );
+ }
+
+ my $attr_meta = Coat::Meta->attribute( $class, $attr_name, \%options);
+
+ my $accessor_code = _accessor_for_attr($attr_name, $attr_meta);
# now bind the subref to the appropriate symbol in the caller class
_bind_coderef_to_symbol( $accessor_code, $accessor );
- my $handles = $attr->{'handles'};
+ my $handles = $attr_meta->{'handles'};
if ($handles && ref $handles eq 'HASH') {
foreach my $method ( keys %{$handles} ) {
@@ -88,15 +66,29 @@
my $handles_code = sub {
my ( $self, @args ) = @_;
- if ( $self->$attribute->can( $handle ) ) {
- return $self->$attribute->$handle( @args );
+ if ( $self->$attr_name->can( $handle ) ) {
+ return $self->$attr_name->$handle( @args );
}
else {
- confess( 'Cannot call ' . $handle . ' from ' . $attribute );
+ confess( 'Cannot call ' . $handle . ' from ' . $attr_name );
}
};
_bind_coderef_to_symbol( $handles_code, $handler );
}
+ }
+
+ my $predicate = $attr_meta->{'predicate'};
+ if ($predicate) {
+ my $full = "${class}::$predicate";
+ my $predicate_code = sub { exists $_[0]->{$attr_name} };
+ _bind_coderef_to_symbol( $predicate_code => $full );
+ }
+
+ my $clearer = $attr_meta->{'clearer'};
+ if ($clearer) {
+ my $full = "${class}::$clearer";
+ my $clearer_code = sub { delete $_[0]->{$attr_name} };
+ _bind_coderef_to_symbol( $clearer_code => $full );
}
}
@@ -158,12 +150,7 @@
confess "Class cannot be named like a built-in type constraint ($class_name)";
# register the class as a valid type
- Coat::Types::register_type_constraint( Coat::Meta::TypeConstraint->new(
- name => $class_name,
- parent => 'Object',
- validation => sub { ref($_) eq $class_name },
- message => sub { "Value is not a member of class '$class_name' ($_)" },
- ));
+ Coat::Types::find_or_create_type_constraint( $class_name );
# force inheritance from Coat::Object
_extends_class( ['Coat::Object'], $class_name );
@@ -216,6 +203,40 @@
##############################################################################
# Private methods
##############################################################################
+
+
+# TODO : Should find a way to build optimized non-mutable accessors here
+# It's ugly to check the meta of the attribute whenver using the setter or the
+# getter.
+sub _accessor_for_attr($$) {
+ my ($name, $meta) = @_;
+
+ return sub {
+ my ( $self, $value ) = @_;
+
+ # setter
+ if ( @_ > 1 ) {
+ confess "Cannot set a read-only attribute ($name)"
+ if ($meta->{'is'} eq 'ro');
+
+ $value = Coat::Types->validate( $meta, $name, $value );
+ $self->{$name} = $value;
+
+ $meta->{'trigger'}->($self, $value)
+ if defined $meta->{'trigger'};
+
+ return $value;
+ }
+
+ # getter
+ else {
+ $self->{$name} = Coat::Meta->attr_default( $self, $name)
+ if ($meta->{lazy} && !defined($self->{$name}));
+
+ return $self->{$name};
+ }
+ };
+}
# The idea here is to loop on each coderef given
# and build subs to ensure the orig coderef is correctly propagated.
Modified: branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm?rev=20649&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm Tue Jun 3 17:30:30 2008
@@ -74,6 +74,21 @@
{
my ($self, $class) = @_;
return exists $CLASSES->{ $class };
+}
+
+# returns the default value for the given $class/$attr
+sub attr_default($$) {
+ my( $self, $obj, $attr) = @_;
+ my $class = ref $obj;
+
+ my $meta = Coat::Meta->has( $class, $attr );
+
+ my $default = $meta->{'default'};
+ return undef unless defined $default;
+
+ return (ref $default)
+ ? $default->($obj) # we have a CODE ref
+ : $default; # we have a plain scalar
}
# this method looks for the attribute description in the whole hierarchy
Modified: branches/upstream/libcoat-perl/current/lib/Coat/Object.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/lib/Coat/Object.pm?rev=20649&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Object.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Object.pm Tue Jun 3 17:30:30 2008
@@ -30,32 +30,37 @@
# given at instanciation time
sub init {
my ( $self, %attrs ) = @_;
- my $class_attr = Coat::Meta->all_attributes( ref( $self ) );
+ my $class = ref $self;
+
+ my $class_attr = Coat::Meta->all_attributes( $class );
# setting all default values
foreach my $attr ( keys %{$class_attr} ) {
- # handling default values
- if ( defined $class_attr->{$attr}{'default'} ) {
+ my $meta = $class_attr->{$attr};
+
+ confess "You cannot have lazy attribute ($attr) without specifying a default value for it"
+ if ($meta->{lazy} && !exists($meta->{default}));
+
+ # handling default values for non-lazy slots
+ if ( (! $meta->{'lazy'}) && defined $meta->{'default'} ) {
+
# saving original permission and setting it to read/write
- my $is = $class_attr->{$attr}{'is'};
- $class_attr->{$attr}{'is'} = 'rw';
+ my $is = $meta->{'is'};
+ $meta->{'is'} = 'rw';
- # setting the default value
- my $default = $class_attr->{$attr}{'default'};
- ref $default
- ? $self->$attr( &$default(@_) ) # we have a CODE ref
- : $self->$attr( $default ); # we have a plain scalar
-
+ # set default value
+ $self->$attr( Coat::Meta->attr_default( $self, $attr) );
+
# restoring original permissions
- $class_attr->{$attr}{'is'} = $is;
+ $meta->{'is'} = $is;
}
# a required read-only field must have a default value or be set at
# instanciation time
confess "Attribute ($attr) is required"
- if ($class_attr->{$attr}{'required'} &&
- $class_attr->{$attr}{'is'} eq 'ro' &&
- (! defined $class_attr->{$attr}{'default'}) &&
+ if ($meta->{'required'} &&
+ $meta->{'is'} eq 'ro' &&
+ (! defined $meta->{'default'}) &&
(! exists $attrs{$attr}));
}
Modified: branches/upstream/libcoat-perl/current/lib/Coat/Types.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/lib/Coat/Types.pm?rev=20649&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Types.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Types.pm Tue Jun 3 17:30:30 2008
@@ -26,6 +26,7 @@
register_type_constraint
find_type_constraint
+ find_or_create_type_constraint
list_all_type_constraints
list_all_builtin_type_constraints
@@ -58,6 +59,20 @@
sub list_all_type_constraints { keys %$REGISTRY }
sub get_type_constraint_registry { $REGISTRY }
+sub find_or_create_type_constraint {
+ my ($type_name) = @_;
+
+ my $tc = find_type_constraint( $type_name );
+ return $tc if defined $tc;
+
+ return register_type_constraint( Coat::Meta::TypeConstraint->new(
+ name => $type_name,
+ parent => 'Object',
+ validation => sub { ref($_) eq $type_name},
+ message => sub { "Value is not a member of class '$type_name' ($_)" },
+ ));
+}
+
# }}}
# {{{ - macro (type, subtype, coerce, enum)
@@ -96,10 +111,7 @@
sub coerce($@) {
my ($type_name, %coercion_map) = @_;
- my $tc = find_type_constraint($type_name);
-
- (defined $tc) ||
- confess "Cannot find type '$type_name', perhaps you forgot to load it.";
+ my $tc = find_or_create_type_constraint($type_name);
if ($tc->has_coercion) {
$tc->coercion_map ( { %{ $tc->coercion_map }, %coercion_map });
Modified: branches/upstream/libcoat-perl/current/t/027_handles.t
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/t/027_handles.t?rev=20649&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/t/027_handles.t (original)
+++ branches/upstream/libcoat-perl/current/t/027_handles.t Tue Jun 3 17:30:30 2008
@@ -1,46 +1,41 @@
-#!/usr/bin/perl -w
+use Test::More tests => 2;
+use strict;
-use strict;
-use Test::More tests => 2;
+{
+ package Spanish;
+ use Coat;
-package Spanish;
+ has uno => (
+ is => 'ro',
+ default => sub {
+ return 1;
+ }
+ );
-use Coat;
+ has dos => (
+ is => 'ro',
+ default => sub {
+ return 2;
+ }
+ );
-has uno => (
- is => 'ro',
- default => sub {
- return 1;
- }
-);
+ package English;
+ use Coat;
-has dos => (
- is => 'ro',
- default => sub {
- return 2;
- }
-);
-
-package English;
-
-use Coat;
-
-has translate => (
- is => 'ro',
- default => sub {
- return Spanish->new;
- },
- handles => {
- one => 'uno',
- two => 'dos',
- }
-);
-
-package main;
-
-use Data::Dumper;
+ has translate => (
+ is => 'ro',
+ default => sub {
+ return Spanish->new;
+ },
+ handles => {
+ one => 'uno',
+ two => 'dos',
+ }
+ );
+}
my $eng = English->new;
is $eng->one, 1, 'one';
is $eng->two, 2, 'two';
+
Added: branches/upstream/libcoat-perl/current/t/029_predicate_clearer.t
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/t/029_predicate_clearer.t?rev=20649&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/029_predicate_clearer.t (added)
+++ branches/upstream/libcoat-perl/current/t/029_predicate_clearer.t Tue Jun 3 17:30:30 2008
@@ -1,0 +1,46 @@
+use Test::More 'no_plan';
+
+use strict;
+use warnings;
+
+my $REG = {};
+
+{
+ package A;
+ use Coat;
+
+ has id => (
+ is => 'rw',
+ predicate => 'has_id',
+ clearer => 'clear_id',
+ );
+}
+
+can_ok(A => 'has_id', 'clear_id');
+my $a = A->new;
+ok(!$a->has_id, "no ID yet");
+$a->clear_id;
+ok(!$a->has_id, "clearer didn't set ID");
+
+$a->id(1);
+is($a->id, 1, "value is set");
+ok($a->has_id, "setting the value did set the ID");
+$a->clear_id;
+is($a->id, undef, "no value after clearer");
+ok(!$a->has_id, "running the clearer makes predicate return false");
+
+$a->id(1);
+ok($a->has_id, "we have a value again..");
+
+$a->id(undef);
+ok($a->has_id, "setting to undef means we still have a value");
+
+TODO: {
+ local $TODO = "uhh what?";
+ is($a->id, undef, "value is undef");
+};
+
+$a->clear_id;
+ok(!$a->has_id, "clearing from undef still makes predicate false");
+is($a->id, undef, "value is still undef");
+
Added: branches/upstream/libcoat-perl/current/t/031_lazy_attr.t
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/t/031_lazy_attr.t?rev=20649&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/031_lazy_attr.t (added)
+++ branches/upstream/libcoat-perl/current/t/031_lazy_attr.t Tue Jun 3 17:30:30 2008
@@ -1,0 +1,43 @@
+use Test::More tests => 5;
+
+use strict;
+use warnings;
+
+{
+ package A;
+ use Coat;
+
+ has x => (isa => 'Num', is => 'rw', lazy => 1, default => 2);
+ has y => (isa => 'Num', is => 'rw', default => 2);
+
+ package B;
+ use Coat;
+
+ has x => (isa => 'Num', is => 'rw', lazy => 1);
+
+ package Test;
+ use Coat;
+
+ has dir => ( is => 'rw', isa => 'Str');
+ has name => ( is => 'rw', isa => 'Str');
+ has path => ( is => 'ro', isa => 'Str', lazy => 1,
+ default => sub {
+ return $_[0]->dir . '/' . $_[0]->name;
+ }
+ );
+}
+
+my $a = A->new;
+
+ok(! $a->{x}, 'x is not set on new (lazy)' );
+ok( $a->{y}, 'y is set on new (non-lazy)' );
+
+is( $a->x, 2, 'x is set when read' );
+
+my $b;
+eval { $b = B->new };
+ok( $@, 'Cannot have a lazy attribute without a default value');
+
+my $t = Test->new(dir => '/tmp', name => 'file');
+is($t->path, '/tmp/file', 'default lazy value with dynamic values');
+
More information about the Pkg-perl-cvs-commits
mailing list