r20160 - in /branches/upstream/libcoat-perl/current: CHANGES lib/Coat.pm lib/Coat/Meta.pm lib/Coat/Object.pm t/027_handles.t t/028_build_demolish.t
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Mon May 19 17:47:15 UTC 2008
Author: gregoa
Date: Mon May 19 17:47:15 2008
New Revision: 20160
URL: http://svn.debian.org/wsvn/?sc=1&rev=20160
Log:
[svn-upgrade] Integrating new upstream version, libcoat-perl (0.320)
Added:
branches/upstream/libcoat-perl/current/t/027_handles.t
branches/upstream/libcoat-perl/current/t/028_build_demolish.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
Modified: branches/upstream/libcoat-perl/current/CHANGES
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/CHANGES?rev=20160&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/CHANGES (original)
+++ branches/upstream/libcoat-perl/current/CHANGES Mon May 19 17:47:15 2008
@@ -1,3 +1,41 @@
+2008-05-18 -- release 0.320
+
+ * support for attr overloading (has '+foo')
+ * support for handles (with tests)
+ * fixed BUILD inheritance
+ * added DEMOLISH and BUILD support in Coat::Object
+ * added a dump() method in Coat::Object
+
+2008-05-15 -- release 0.310
+
+ * Fixing parameterized parsing
+
+2008-05-14 -- release 0.300
+
+ * support for anon type constraint
+
+
+2008-05-14 -- release 0.240
+
+ * Bugfix and support for real automatic class constraint
+
+2008-05-14 -- release 0.230
+
+ * support for parameterized type constraint HashRef[] and ArrayRef[]
+ * removed useless and buggy find_matching_types, fixed ->coerce()
+ * documentation of type-constraints & friends
+
+2008-05-12 -- release 0.210
+
+ * only coerce if attr want coercion
+ * Fixing an issue when Type constraint triggers and exception
+ * extends now try to import missing classes by himself
+ (closes: #35516).
+
+2008-05-11 -- release 0.200
+
+ * Support for real type constraints and coercion
+
2007-10-11 -- release 0.1_0.6
* Supports for "required" and "trigger" options
Modified: branches/upstream/libcoat-perl/current/lib/Coat.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/lib/Coat.pm?rev=20160&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat.pm Mon May 19 17:47:15 2008
@@ -14,7 +14,7 @@
use Coat::Object;
use Coat::Types;
-$VERSION = '0.310';
+$VERSION = '0.320';
$AUTHORITY = 'cpan:SUKRIA';
# our exported keywords for class description
@@ -78,6 +78,26 @@
# now bind the subref to the appropriate symbol in the caller class
_bind_coderef_to_symbol( $accessor_code, $accessor );
+
+ my $handles = $attr->{'handles'};
+ if ($handles && ref $handles eq 'HASH') {
+
+ foreach my $method ( keys %{$handles} ) {
+ my $handler = "${class}::${method}";
+ my $handle = $handles->{$method};
+ my $handles_code = sub {
+ my ( $self, @args ) = @_;
+
+ if ( $self->$attribute->can( $handle ) ) {
+ return $self->$attribute->$handle( @args );
+ }
+ else {
+ confess( 'Cannot call ' . $handle . ' from ' . $attribute );
+ }
+ };
+ _bind_coderef_to_symbol( $handles_code, $handler );
+ }
+ }
}
# the public inheritance method, takes a list of class we should inherit from
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=20160&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm Mon May 19 17:47:15 2008
@@ -126,6 +126,19 @@
{
my ($self, $class) = @_;
{ no strict 'refs'; return \@{"${class}::ISA"}; }
+}
+
+sub class_precedence_list {
+ my ($self, $class) = @_;
+ return if !$class;
+
+ ( $class, map { $self->class_precedence_list($_) } @{$self->parents($class)} );
+}
+
+sub linearized_isa {
+ my ($self, $class) = @_;
+ my %seen;
+ grep { !( $seen{$_}++ ) } $self->class_precedence_list($class);
}
sub is_parent
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=20160&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Object.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Object.pm Mon May 19 17:47:15 2008
@@ -31,7 +31,6 @@
sub init {
my ( $self, %attrs ) = @_;
my $class_attr = Coat::Meta->all_attributes( ref( $self ) );
-
# setting all default values
foreach my $attr ( keys %{$class_attr} ) {
@@ -69,11 +68,49 @@
$class_attr->{$attr}{'is'} = $is;
}
+ $self->BUILDALL(\%attrs);
+ return $self;
+}
- # try to run the BUILD method, if exists
+# All the BUILD/DEMOLISH stuff here is taken from Moose and
+# uses some Coat::Meta.
+
+sub BUILDALL {
+ return unless $_[0]->can('BUILD');
+ my ($self, $params) = @_;
+
my $build_sub;
- { no strict 'refs'; $build_sub = *{ref($self)."::BUILD"}; }
- $self->BUILD( %attrs ) if ( defined &$build_sub );
+ foreach my $pkg (reverse Coat::Meta->linearized_isa(ref($self))) {
+ {
+ no strict 'refs';
+ $build_sub = *{$pkg."::BUILD"};
+ }
+ $self->$build_sub( %$params ) if defined &$build_sub;
+ }
+}
+
+sub DEMOLISHALL {
+ return unless $_[0]->can('DEMOLISH');
+ my ($self) = @_;
+
+ my $demolish_sub;
+ foreach my $pkg (reverse Coat::Meta->linearized_isa(ref($self))) {
+ {
+ no strict 'refs';
+ $demolish_sub = *{$pkg."::DEMOLISH"};
+ }
+ $self->$demolish_sub() if defined &$demolish_sub;
+ }
+}
+
+sub DESTROY { goto &DEMOLISHALL }
+
+# taken from Moose::Object
+sub dump {
+ my $self = shift;
+ require Data::Dumper;
+ local $Data::Dumper::Maxdepth = shift if @_;
+ Data::Dumper::Dumper $self;
}
# end Coat::Object
Added: 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=20160&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/027_handles.t (added)
+++ branches/upstream/libcoat-perl/current/t/027_handles.t Mon May 19 17:47:15 2008
@@ -1,0 +1,46 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 2;
+
+package Spanish;
+
+use Coat;
+
+has uno => (
+ is => 'ro',
+ default => sub {
+ return 1;
+ }
+);
+
+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;
+
+my $eng = English->new;
+
+is $eng->one, 1, 'one';
+is $eng->two, 2, 'two';
Added: branches/upstream/libcoat-perl/current/t/028_build_demolish.t
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/t/028_build_demolish.t?rev=20160&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/028_build_demolish.t (added)
+++ branches/upstream/libcoat-perl/current/t/028_build_demolish.t Mon May 19 17:47:15 2008
@@ -1,0 +1,57 @@
+use Test::More 'no_plan';
+
+use strict;
+use warnings;
+
+my $REG = {};
+
+{
+ package A;
+ use Coat;
+
+ has id => (is => 'rw', isa => 'Int');
+
+ has buffer => (
+ is => 'rw',
+ isa => 'ArrayRef[Str]',
+ required => 1,
+ default => sub { [] },
+ );
+
+ sub BUILD {
+ push @{ $_[0]->buffer }, 'BUILD A' ;
+ }
+
+ sub DEMOLISH {
+ $REG->{'A'}{ $_[0]->id } = $_[0]->buffer;
+ }
+
+ package B;
+ use Coat;
+ extends 'A';
+
+ sub BUILD {
+ push @{ $_[0]->buffer }, 'BUILD B' ;
+ }
+
+ sub DEMOLISH {
+ $REG->{'B'}{ $_[0]->id } = $_[0]->buffer;
+ }
+}
+
+my $a = A->new( id => 1 );
+is_deeply( $a->buffer, ['BUILD A'], 'A::BUILD called on new' );
+
+my $b = B->new( id => 2 );
+is_deeply( $b->buffer, ['BUILD A', 'BUILD B'], 'A::BUILD and B::BUILD called' );
+
+undef $a;
+is_deeply( $REG->{'A'}{1}, ['BUILD A'],
+ 'A::DEMOLISH called for $a' );
+
+undef $b;
+is_deeply( $REG->{'A'}{2}, ['BUILD A', 'BUILD B'],
+ 'A::DEMOLISH called for $b' );
+is_deeply( $REG->{'B'}{2}, ['BUILD A', 'BUILD B'],
+ 'B::DEMOLISH called for $b' );
+
More information about the Pkg-perl-cvs-commits
mailing list