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