r27471 - in /trunk/libcoat-perl: ./ debian/ debian/patches/ lib/ lib/Coat/ lib/Coat/Meta/ t/ t/lib/ t/moose_tests/
ansgar-guest at users.alioth.debian.org
ansgar-guest at users.alioth.debian.org
Sun Nov 30 13:40:05 UTC 2008
Author: ansgar-guest
Date: Sun Nov 30 13:39:54 2008
New Revision: 27471
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=27471
Log:
* New upstream release.
* Build-depend on libtest-exception-perl for new tests.
* Add patch `Coat.pm-pod-errors.diff' fixing a POD error in lib/Coat.pm.
+ Add quilt framework and debian/README.source for this.
Added:
trunk/libcoat-perl/debian/README.source
trunk/libcoat-perl/debian/patches/
trunk/libcoat-perl/debian/patches/Coat.pm-pod-errors.diff
trunk/libcoat-perl/debian/patches/series
trunk/libcoat-perl/t/012_type_constraints.t
- copied unchanged from r27468, branches/upstream/libcoat-perl/current/t/012_type_constraints.t
trunk/libcoat-perl/t/037_attributes_and_constraints_overides.t
- copied unchanged from r27468, branches/upstream/libcoat-perl/current/t/037_attributes_and_constraints_overides.t
trunk/libcoat-perl/t/lib/
- copied from r27468, branches/upstream/libcoat-perl/current/t/lib/
trunk/libcoat-perl/t/moose_tests/
- copied from r27468, branches/upstream/libcoat-perl/current/t/moose_tests/
Modified:
trunk/libcoat-perl/CHANGES
trunk/libcoat-perl/Makefile.PL
trunk/libcoat-perl/debian/changelog
trunk/libcoat-perl/debian/control
trunk/libcoat-perl/debian/rules
trunk/libcoat-perl/lib/Coat.pm
trunk/libcoat-perl/lib/Coat/Meta.pm
trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm
trunk/libcoat-perl/lib/Coat/Object.pm
Modified: trunk/libcoat-perl/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/CHANGES?rev=27471&op=diff
==============================================================================
--- trunk/libcoat-perl/CHANGES (original)
+++ trunk/libcoat-perl/CHANGES Sun Nov 30 13:39:54 2008
@@ -1,3 +1,10 @@
+2008-11-25 -- release 0.334
+ * feature: support for BUILDARGS in Coat objects
+ * new tests from Moose in t/moose_tests/
+ * change: error message when loading a class (moose)
+ * fix performance gap when coercing thanks to silent_validate
+ (thanks to Rached Ben Mustapha for finding this out).
+
2008-09-26 -- release 0.333
* bugfix: fixes multiple coercions on the same subtype.
* bugfix: fixes cascading inheritance
Modified: trunk/libcoat-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/Makefile.PL?rev=27471&op=diff
==============================================================================
--- trunk/libcoat-perl/Makefile.PL (original)
+++ trunk/libcoat-perl/Makefile.PL Sun Nov 30 13:39:54 2008
@@ -3,9 +3,10 @@
WriteMakefile(
NAME => 'Coat',
VERSION_FROM => 'lib/Coat.pm',
- ABSTRACT => 'Light meta class for writing fast OO Perl code',
+ ABSTRACT => 'Light meta class for writing Moose compatible code',
PREREQ_PM => {
'Scalar::Util' => 0,
+ 'Test::Exception' => 0,
},
- test => {TESTS => join( ' ', glob( 't/*.t' ))},
+ test => {TESTS => join( ' ', glob( 't/*.t' )).' '.join(' ', glob('t/moose_tests/*.t'))},
);
Added: trunk/libcoat-perl/debian/README.source
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/debian/README.source?rev=27471&op=file
==============================================================================
--- trunk/libcoat-perl/debian/README.source (added)
+++ trunk/libcoat-perl/debian/README.source Sun Nov 30 13:39:54 2008
@@ -1,0 +1,6 @@
+This package uses quilt to manage all modifications to the upstream
+source. Changes are stored in the source package as diffs in
+debian/patches and applied during the build.
+
+See /usr/share/doc/quilt/README.source for a detailed explanation.
+
Modified: trunk/libcoat-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/debian/changelog?rev=27471&op=diff
==============================================================================
--- trunk/libcoat-perl/debian/changelog (original)
+++ trunk/libcoat-perl/debian/changelog Sun Nov 30 13:39:54 2008
@@ -1,9 +1,16 @@
-libcoat-perl (0.333-2) UNRELEASED; urgency=low
+libcoat-perl (0.334-1) unstable; urgency=low
+ [ gregor herrmann ]
* debian/control: Changed: Switched Vcs-Browser field to ViewSVN
(source stanza).
- -- gregor herrmann <gregoa at debian.org> Sun, 16 Nov 2008 20:40:46 +0100
+ [ Ansgar Burchardt ]
+ * New upstream release.
+ * Build-depend on libtest-exception-perl for new tests.
+ * Add patch `Coat.pm-pod-errors.diff' fixing a POD error in lib/Coat.pm.
+ + Add quilt framework and debian/README.source for this.
+
+ -- Ansgar Burchardt <ansgar at 43-1.org> Sun, 30 Nov 2008 14:39:34 +0100
libcoat-perl (0.333-1) unstable; urgency=low
Modified: trunk/libcoat-perl/debian/control
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/debian/control?rev=27471&op=diff
==============================================================================
--- trunk/libcoat-perl/debian/control (original)
+++ trunk/libcoat-perl/debian/control Sun Nov 30 13:39:54 2008
@@ -1,8 +1,8 @@
Source: libcoat-perl
Section: perl
Priority: optional
-Build-Depends: debhelper (>= 7)
-Build-Depends-Indep: perl (>= 5.8.8-12)
+Build-Depends: debhelper (>= 7), quilt
+Build-Depends-Indep: perl (>= 5.8.8-12), libtest-exception-perl
Maintainer: Debian Perl Group <pkg-perl-maintainers at lists.alioth.debian.org>
Uploaders: Alexis Sukrieh <sukria at debian.org>,
gregor herrmann <gregoa at debian.org>,
Added: trunk/libcoat-perl/debian/patches/Coat.pm-pod-errors.diff
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/debian/patches/Coat.pm-pod-errors.diff?rev=27471&op=file
==============================================================================
--- trunk/libcoat-perl/debian/patches/Coat.pm-pod-errors.diff (added)
+++ trunk/libcoat-perl/debian/patches/Coat.pm-pod-errors.diff Sun Nov 30 13:39:54 2008
@@ -1,0 +1,19 @@
+Subject: Fix POD error in lib/Coat.pm
+Author: Ansgar Burchardt <ansgar at 43-1.org>
+
+This patch fixes a small mistake reported by pod2man:
+
+ Hey! The above document had some coding errors, which are explained below:
+ Around line 482:
+ You forgot a '=back' before '=head2'
+
+--- libcoat-perl.orig/lib/Coat.pm
++++ libcoat-perl/lib/Coat.pm
+@@ -478,6 +478,7 @@
+ and can typically be ignored). You B<cannot> have a trigger on a read-only
+ attribute.
+
++=back
+
+ =head2 METHOD MODIFIERS (HOOKS)
+
Added: trunk/libcoat-perl/debian/patches/series
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/debian/patches/series?rev=27471&op=file
==============================================================================
--- trunk/libcoat-perl/debian/patches/series (added)
+++ trunk/libcoat-perl/debian/patches/series Sun Nov 30 13:39:54 2008
@@ -1,0 +1,1 @@
+Coat.pm-pod-errors.diff
Modified: trunk/libcoat-perl/debian/rules
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/debian/rules?rev=27471&op=diff
==============================================================================
--- trunk/libcoat-perl/debian/rules (original)
+++ trunk/libcoat-perl/debian/rules Sun Nov 30 13:39:54 2008
@@ -1,11 +1,13 @@
#!/usr/bin/make -f
+include /usr/share/quilt/quilt.make
+
build: build-stamp
-build-stamp:
+build-stamp: $(QUILT_STAMPFN)
dh build
touch $@
-clean:
+clean: unpatch
dh clean --before dh_clean
dh_clean -X011_metaclass_attributes_inheritance.t.orig
Modified: trunk/libcoat-perl/lib/Coat.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat.pm?rev=27471&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat.pm (original)
+++ trunk/libcoat-perl/lib/Coat.pm Sun Nov 30 13:39:54 2008
@@ -14,7 +14,7 @@
use Coat::Object;
use Coat::Types;
-$VERSION = '0.332';
+$VERSION = '0.334';
$AUTHORITY = 'cpan:SUKRIA';
# our exported keywords for class description
@@ -51,8 +51,7 @@
}
my $attr_meta = Coat::Meta->attribute( $class, $attr_name, \%options);
-
- my $accessor_code = _accessor_for_attr($attr_name, $attr_meta);
+ my $accessor_code = _accessor_for_attr($attr_name);
# now bind the subref to the appropriate symbol in the caller class
_bind_coderef_to_symbol( $accessor_code, $accessor );
@@ -206,14 +205,15 @@
# 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
+# It's ugly to get and check the meta of the attribute whenver using the setter or the
# getter.
-sub _accessor_for_attr($$) {
- my ($name, $meta) = @_;
+sub _accessor_for_attr {
+ my ($name) = @_;
return sub {
my ( $self, $value ) = @_;
-
+ my $meta = Coat::Meta->has( ref($self), $name );
+
# setter
if ( @_ > 1 ) {
confess "Cannot set a read-only attribute ($name)"
@@ -327,7 +327,7 @@
# class is unknown, never been loaded, let's try to import it
unless ( Coat::Meta->exists($mother) ) {
eval "use $mother";
- confess "Failed to load class '$mother' : $@" if $@;
+ confess "Could not load class ($mother) because : $@" if $@;
$mother->import;
}
Coat::Meta->extends( $class, $mother );
Modified: trunk/libcoat-perl/lib/Coat/Meta.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Meta.pm?rev=27471&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Meta.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Meta.pm Sun Nov 30 13:39:54 2008
@@ -12,7 +12,7 @@
sub classes { $CLASSES }
# returns all attributes for the given class
-sub attributes { $CLASSES->{ $_[1] } }
+sub attributes { $CLASSES->{ $_[1] } || {} }
# returns the meta-data for the given class
sub class
@@ -164,7 +164,10 @@
return grep /^$parent$/, @{ Coat::Meta->parents( $class ) };
}
-sub family { $CLASSES->{'@!family'}{ $_[1] } }
+sub family {
+ my ($self, $class) = @_;
+ $CLASSES->{'@!family'}{ $class } ||= Coat::Meta->parents( $class );
+}
sub add_to_family {
my ($self, $class, $parent) = @_;
Modified: trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm?rev=27471&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm Sun Nov 30 13:39:54 2008
@@ -35,33 +35,36 @@
foreach my $source (keys %{ $self->coercion_map }) {
# if current value passes the current source check, coercing
my $tc = Coat::Types::find_type_constraint($source);
- my $ok;
- eval {
- $ok = $tc->validate($value)
- };
- if ($ok && !$@) {
- return $self->{coercion_map}{$source}->($value);
- }
+ return $self->{coercion_map}{$source}->($value)
+ if $tc->silent_validate($value);
}
return $value;
}
# check the value through the type constraints
-sub validate {
+sub silent_validate {
my ($self, $value) = @_;
local $_ = $value;
- my $msg = (defined $self->message)
- ? $self->message->()
- : "Value '" .(defined $value ? $value : 'undef')
- ."' does not validate type constraint '".$self->name."'";
+ # validates the parent's type-constraint if exists
+ if (defined $self->parent) {
+ Coat::Types::find_type_constraint( $self->parent )->silent_validate( $value )
+ or return 0;
+ }
+ return $self->validation->($value);
+}
- # validates the parent's type-constraint if exists
- (defined $self->parent) &&
- Coat::Types::find_type_constraint( $self->parent )->validate( $value );
-
- # pass the value through the check
- $self->validation->($value) or confess $msg;
+sub validate {
+ my ($self, $value) = @_;
+ unless ($self->silent_validate($value)) {
+ local $_ = $value;
+ my $msg = (defined $self->message)
+ ? $self->message->()
+ : "Value '" .(defined $value ? $value : 'undef')
+ ."' does not validate type constraint '".$self->name."'";
+ confess $msg;
+ }
+ return 1;
}
sub has_coercion {
Modified: trunk/libcoat-perl/lib/Coat/Object.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Object.pm?rev=27471&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Object.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Object.pm Sun Nov 30 13:39:54 2008
@@ -10,14 +10,59 @@
# The default constructor
sub new {
- my ( $class, %args ) = @_;
-
+ my ( $class, @args ) = @_;
+
+ # create the newborn
my $self = {};
bless $self, $class;
- $self->init(%args);
-
+ # parse and prepare the args
+ my $args = $self->build_args(@args);
+
+ # init the object
+ $self->init($args);
+
+ # done
return $self;
+}
+
+sub build_args {
+ my ($self, @args) = @_;
+ my $class = ref($self);
+
+ my $args;
+ $args = {@args} if @args % 2 == 0;
+
+ # if BUILDARGS exists, look or it and run it
+ if ($self->can('BUILDARGS')) {
+ foreach my $pkg (reverse Coat::Meta->linearized_isa($class)) {
+ my $buildargs_sub;
+ {
+ no strict 'refs';
+ $buildargs_sub = *{$pkg."::BUILDARGS"};
+ }
+ if (defined &$buildargs_sub) {
+ $args = $self->$buildargs_sub(@args);
+ last;
+ }
+ }
+ }
+
+ # now check everything is OK with the args
+ unless (defined $args) {
+ if (@args == 1) {
+ if (ref($args[0]) ne 'HASHREF') {
+ confess "Single argument must be an HASHREF";
+ }
+ else {
+ $args = $args[0];
+ }
+ }
+ else {
+ confess "Invalid arguments";
+ }
+ }
+ return $args;
}
# returns the meta-class description of that instance
@@ -29,7 +74,7 @@
# init an instance : put default values and set values
# given at instanciation time
sub init {
- my ( $self, %attrs ) = @_;
+ my ( $self, $attrs ) = @_;
my $class = ref $self;
my $class_attr = Coat::Meta->all_attributes( $class );
@@ -60,53 +105,46 @@
confess "Attribute ($attr) is required"
if ($meta->{'required'} &&
$meta->{'is'} eq 'ro' &&
- (! defined $meta->{'default'}) &&
- (! exists $attrs{$attr}));
+ (! exists $meta->{'default'}) &&
+ (! exists $attrs->{$attr}));
}
# setting values given at instanciation time
- foreach my $attr ( keys %attrs ) {
+ foreach my $attr ( keys %$attrs ) {
my $is = $class_attr->{$attr}{'is'};
$class_attr->{$attr}{'is'} = 'rw';
- $self->$attr( $attrs{$attr} );
+ $self->$attr( $attrs->{$attr} );
$class_attr->{$attr}{'is'} = $is;
}
- $self->BUILDALL(\%attrs);
+ $self->BUILDALL($attrs);
return $self;
}
-# 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;
- foreach my $pkg (reverse Coat::Meta->linearized_isa(ref($self))) {
+# This is done to let us implement easily the BUILDARGS/BUILD/DEMOLISH stuff
+# It must behave the same: with inheritance in mind.
+# Thanks again to the Moose team for the idea of *ALL() methods.
+
+sub _run_for_all {
+ my ($method_name, $self, $params) = @_;
+ my $class = ref($self);
+
+ return unless $self->can($method_name);
+
+ my $sub;
+ foreach my $pkg (reverse Coat::Meta->linearized_isa($class)) {
{
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 = *{$pkg."::${method_name}"};
+ }
+ $self->$sub( %$params ) if defined &$sub;
+ }
+}
+
+sub BUILDALL { _run_for_all('BUILD', @_) }
+
+sub DEMOLISHALL { _run_for_all('DEMOLISH', @_) }
sub DESTROY { goto &DEMOLISHALL }
More information about the Pkg-perl-cvs-commits
mailing list