r20651 - in /trunk/libcoat-perl: CHANGES debian/changelog 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:31:46 UTC 2008
Author: gregoa
Date: Tue Jun 3 17:31:46 2008
New Revision: 20651
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=20651
Log:
New upstream release.
Added:
trunk/libcoat-perl/t/029_predicate_clearer.t
- copied unchanged from r20650, branches/upstream/libcoat-perl/current/t/029_predicate_clearer.t
trunk/libcoat-perl/t/031_lazy_attr.t
- copied unchanged from r20650, branches/upstream/libcoat-perl/current/t/031_lazy_attr.t
Modified:
trunk/libcoat-perl/CHANGES
trunk/libcoat-perl/debian/changelog
trunk/libcoat-perl/lib/Coat.pm
trunk/libcoat-perl/lib/Coat/Meta.pm
trunk/libcoat-perl/lib/Coat/Object.pm
trunk/libcoat-perl/lib/Coat/Types.pm
trunk/libcoat-perl/t/027_handles.t
Modified: trunk/libcoat-perl/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/CHANGES?rev=20651&op=diff
==============================================================================
--- trunk/libcoat-perl/CHANGES (original)
+++ trunk/libcoat-perl/CHANGES Tue Jun 3 17:31:46 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: trunk/libcoat-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/debian/changelog?rev=20651&op=diff
==============================================================================
--- trunk/libcoat-perl/debian/changelog (original)
+++ trunk/libcoat-perl/debian/changelog Tue Jun 3 17:31:46 2008
@@ -1,3 +1,9 @@
+libcoat-perl (0.330-1) UNRELEASED; urgency=low
+
+ * New upstream release.
+
+ -- gregor herrmann <gregoa at debian.org> Tue, 03 Jun 2008 19:30:55 +0200
+
libcoat-perl (0.320-1) unstable; urgency=low
* New upstream release.
Modified: trunk/libcoat-perl/lib/Coat.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat.pm?rev=20651&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat.pm (original)
+++ trunk/libcoat-perl/lib/Coat.pm Tue Jun 3 17:31:46 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: trunk/libcoat-perl/lib/Coat/Meta.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Meta.pm?rev=20651&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Meta.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Meta.pm Tue Jun 3 17:31:46 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: trunk/libcoat-perl/lib/Coat/Object.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Object.pm?rev=20651&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Object.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Object.pm Tue Jun 3 17:31:46 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: trunk/libcoat-perl/lib/Coat/Types.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Types.pm?rev=20651&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Types.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Types.pm Tue Jun 3 17:31:46 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: trunk/libcoat-perl/t/027_handles.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/t/027_handles.t?rev=20651&op=diff
==============================================================================
--- trunk/libcoat-perl/t/027_handles.t (original)
+++ trunk/libcoat-perl/t/027_handles.t Tue Jun 3 17:31:46 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';
+
More information about the Pkg-perl-cvs-commits
mailing list