r31742 - in /branches/upstream/libmouse-perl/current: ./ lib/ lib/Mouse/ lib/Mouse/Meta/ lib/Mouse/Util/ t/
ryan52-guest at users.alioth.debian.org
ryan52-guest at users.alioth.debian.org
Sun Mar 8 22:51:26 UTC 2009
Author: ryan52-guest
Date: Sun Mar 8 22:51:23 2009
New Revision: 31742
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=31742
Log:
[svn-upgrade] Integrating new upstream version, libmouse-perl (0.19)
Added:
branches/upstream/libmouse-perl/current/t/047-attribute-metaclass-role.t
Modified:
branches/upstream/libmouse-perl/current/Changes
branches/upstream/libmouse-perl/current/MANIFEST
branches/upstream/libmouse-perl/current/META.yml
branches/upstream/libmouse-perl/current/SIGNATURE
branches/upstream/libmouse-perl/current/lib/Mouse.pm
branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Attribute.pm
branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Role.pm
branches/upstream/libmouse-perl/current/lib/Mouse/Tiny.pm
branches/upstream/libmouse-perl/current/lib/Mouse/Util/TypeConstraints.pm
branches/upstream/libmouse-perl/current/t/043-parameterized-type.t
branches/upstream/libmouse-perl/current/t/044-attribute-metaclass.t
Modified: branches/upstream/libmouse-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/Changes?rev=31742&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/Changes (original)
+++ branches/upstream/libmouse-perl/current/Changes Sun Mar 8 22:51:23 2009
@@ -1,4 +1,12 @@
Revision history for Mouse
+
+0.19 Sun Mar 8 04:38:01 2009
+ * Parameterized type constraints for ArrayRef and HashRef (lestrrat)
+
+ * Allow extensible attribute metaclass in traits too(tokuhirom)
+
+ * Don't use method modifiers in a test since they may not be
+ available (Sartak)
0.18 Fri Mar 6 19:09:33 2009
* Fix the issue preventing Mouse usage on Perl 5.6 - a bug in older
Modified: branches/upstream/libmouse-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/MANIFEST?rev=31742&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/MANIFEST (original)
+++ branches/upstream/libmouse-perl/current/MANIFEST Sun Mar 8 22:51:23 2009
@@ -82,6 +82,7 @@
t/044-attribute-metaclass.t
t/045-import-into_level.t
t/046-meta-add_attribute.t
+t/047-attribute-metaclass-role.t
t/100-meta-class.t
t/101-meta-attribute.t
t/201-squirrel.t
Modified: branches/upstream/libmouse-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/META.yml?rev=31742&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/META.yml (original)
+++ branches/upstream/libmouse-perl/current/META.yml Sun Mar 8 22:51:23 2009
@@ -1,22 +1,24 @@
----
-abstract: Moose minus the antlers
-author:
- - Shawn M Moore, C<< <sartak at gmail.com> >>
-build_requires:
+---
+abstract: 'Moose minus the antlers'
+author:
+ - 'Shawn M Moore, C<< <sartak at gmail.com> >>'
+build_requires:
Test::Exception: 0
Test::More: 0
distribution_type: module
-generated_by: Module::Install version 0.70
+generated_by: 'Module::Install version 0.79'
license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.3.html
- version: 1.3
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
name: Mouse
-no_index:
- directory:
+no_index:
+ directory:
- inc
- t
-requires:
+requires:
+ Scalar::Util: 1.14
perl: 5.6.0
-tests: t/*.t t/*/*.t
-version: 0.17
+resources:
+ license: http://dev.perl.org/licenses/
+version: 0.19
Modified: branches/upstream/libmouse-perl/current/SIGNATURE
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/SIGNATURE?rev=31742&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/SIGNATURE (original)
+++ branches/upstream/libmouse-perl/current/SIGNATURE Sun Mar 8 22:51:23 2009
@@ -15,9 +15,9 @@
Hash: SHA1
SHA1 42f8112ac442d396c2fe2fddaf52ca2ed73cfbea .gitignore
-SHA1 eef5c453564916359be23ef9eb6e36898db02d0d Changes
-SHA1 a09b608ca77135388faff53c4b3698ee511736ad MANIFEST
-SHA1 8abbaa4f6d2c3fc176c504426fc45cca6fbb0d7b META.yml
+SHA1 6dba55f7ac5ea3b7614bd27a5a066e768bc3afcc Changes
+SHA1 85f0a3dc399a77ab35980bc28bfb29b96e8e7851 MANIFEST
+SHA1 84c40118f5e2f8bff659ad83c6ee6ff13e3c9d9a META.yml
SHA1 dc1bf99d9424a6d4dbcee44306d1ec195646bea7 Makefile.PL
SHA1 cc85b7cafbadec0483a5865da306b656682740eb author/benchmarks/basic.pl
SHA1 a408c24efc701c368bbde43c020b29e1ebd80f64 author/generate-mouse-tiny.pl
@@ -33,18 +33,18 @@
SHA1 ade2ac0b0246d4d8e28fa46942e53f6925abda46 inc/Module/Install/WriteAll.pm
SHA1 29ccdbe057fec4775456b275262881a6f79531d6 inc/Test/Exception.pm
SHA1 ab0c02dbe66a1a82be1cc3909a06b41d3e5894c2 inc/Test/More.pm
-SHA1 e7a2ba21c382a9b57d87f0a905ab83fcc2532f68 lib/Mouse.pm
-SHA1 3b16448d96194f2b1cc8ffcf83aa23ea89d5fd4f lib/Mouse/Meta/Attribute.pm
+SHA1 c0796ca4cf1381bb784846ddd4efaf7729305bd0 lib/Mouse.pm
+SHA1 93a356da65069098c3776fdf02b9f7ac9f860973 lib/Mouse/Meta/Attribute.pm
SHA1 26f8ed51cdc16ec8553a0e5f23ca9d9d15191ec4 lib/Mouse/Meta/Class.pm
SHA1 c92a58160d997408252443102f4ed3f59c81aabd lib/Mouse/Meta/Method/Constructor.pm
SHA1 8feddf4deaee14d9c1f69eff8d0c986222e90dde lib/Mouse/Meta/Method/Destructor.pm
-SHA1 d7d068b3351d7c599ea0caf7f08e3d1a6903e123 lib/Mouse/Meta/Role.pm
+SHA1 0b7c20f3c33e62bd560b701c616a543374a80739 lib/Mouse/Meta/Role.pm
SHA1 7725bc3b01ddf9a9b5a60f20e807c0b93ce62c90 lib/Mouse/Object.pm
SHA1 956720a381c30fdc017c589957a8069d648f4155 lib/Mouse/Role.pm
-SHA1 85b01aba08b57c3c9b6e5f1098fadbc49f0e2d01 lib/Mouse/Tiny.pm
+SHA1 9bebbd089a2104cabdda675b6624e1aed6d45a05 lib/Mouse/Tiny.pm
SHA1 affa82bf47e1888f22731b76c5c0f678bc5e43c0 lib/Mouse/TypeRegistry.pm
SHA1 2cca3d6d3b1da6a0a220e6eee231c01d728f5fb3 lib/Mouse/Util.pm
-SHA1 d4ba85be3d0e072c4e4b9ec24e3873c0ec85b6ba lib/Mouse/Util/TypeConstraints.pm
+SHA1 b5326ac34c0e3843846e6b1112bd96d2ab0cf934 lib/Mouse/Util/TypeConstraints.pm
SHA1 50017b83f252cac26cc828e427231ce8a9cd3c4d lib/Squirrel.pm
SHA1 1d459388c2b9e9173b9fcb0f13413b85758a1e7a lib/Squirrel/Role.pm
SHA1 7953af29701a1f92486e4af890baac30155774e0 lib/ouse.pm
@@ -93,10 +93,11 @@
SHA1 e845d0feb414ec954d04efac50dacdaa2cab30a1 t/040-existing-subclass.t
SHA1 abcd24e01ed3653acd0cb5443df1a49aef4b5ffa t/041-enum.t
SHA1 89bbc4b861d0366721cdb919d3950c0926f41f9f t/042-override.t
-SHA1 0da34f5af557781f39470f0cb58c00fb5e8e5de5 t/043-parameterized-type.t
-SHA1 512adbdecbc87de241abf24b0bc24bc5ae33d63b t/044-attribute-metaclass.t
+SHA1 bf76f94d7da2a9f99eb21e01a9665ed0ec321c26 t/043-parameterized-type.t
+SHA1 d2b10641b43382b0f3dfa8e506cdae44e5fad4d5 t/044-attribute-metaclass.t
SHA1 2627487b336f8a2cc0c4e57ccb3b6dff8582ba06 t/045-import-into_level.t
SHA1 05146766b178a3410df6d0505b00dc14c055b6bf t/046-meta-add_attribute.t
+SHA1 7f500e5bf9e6be77894b5543aae99ac33cba15bb t/047-attribute-metaclass-role.t
SHA1 1593a1a3d5fbf80860458f57e6e0e4c87765aab1 t/100-meta-class.t
SHA1 ed10e0911cfe567b1f8546c1ab9339b74a3fe575 t/101-meta-attribute.t
SHA1 b686298591ef3d2164aace5bee1c2e0c45f54aef t/201-squirrel.t
@@ -137,7 +138,7 @@
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.7 (Darwin)
-iD8DBQFJsbwasxfQtHhyRPoRAmJ7AJ0U6Tk4y4Ji7PBT74V71GOaJSjs5ACcCDsR
-zL/4uBs+3CKwN4v9SdByCN0=
-=chDL
+iD8DBQFJs4QOsxfQtHhyRPoRAlTEAJ4yjsZAliEygZ8tydBiJpd9PBTGlgCgg+sZ
+WDeLglSM9rzUkZfZJezmbYw=
+=cXwg
-----END PGP SIGNATURE-----
Modified: branches/upstream/libmouse-perl/current/lib/Mouse.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/lib/Mouse.pm?rev=31742&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/lib/Mouse.pm (original)
+++ branches/upstream/libmouse-perl/current/lib/Mouse.pm Sun Mar 8 22:51:23 2009
@@ -4,7 +4,7 @@
use 5.006;
use base 'Exporter';
-our $VERSION = '0.18';
+our $VERSION = '0.19';
use Carp 'confess';
use Scalar::Util 'blessed';
Modified: branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Attribute.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Attribute.pm?rev=31742&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Attribute.pm (original)
+++ branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Attribute.pm Sun Mar 8 22:51:23 2009
@@ -191,6 +191,59 @@
return \%method_map;
}
+my $optimized_constraints;
+sub _build_type_constraint {
+ my $spec = shift;
+ $optimized_constraints ||= Mouse::Util::TypeConstraints->optimized_constraints;
+ my $code;
+ if ($spec =~ /^([^\[]+)\[(.+)\]$/) {
+ # parameterized
+ my $constraint = $1;
+ my $param = $2;
+ my $parent = _build_type_constraint($constraint);
+ my $child = _build_type_constraint($param);
+ if ($constraint eq 'ArrayRef') {
+ my $code_str =
+ "sub {\n" .
+ " if (\$parent->(\$_)) {\n" .
+ " foreach my \$e (@\$_) {\n" .
+ " local \$_ = \$e;\n" .
+ " return () unless \$child->(\$_);\n" .
+ " }\n" .
+ " return 1;\n" .
+ " }\n" .
+ " return ();\n" .
+ "};\n"
+ ;
+ $code = eval $code_str or Carp::confess($@);
+ } elsif ($constraint eq 'HashRef') {
+ my $code_str =
+ "sub {\n" .
+ " if (\$parent->(\$_)) {\n" .
+ " foreach my \$e (values %\$_) {\n" .
+ " local \$_ = \$e;\n" .
+ " return () unless \$child->(\$_);\n" .
+ " }\n" .
+ " return 1;\n" .
+ " }\n" .
+ " return ();\n" .
+ "};\n"
+ ;
+ $code = eval $code_str or Carp::confess($@);
+ } else {
+ Carp::confess("Support for parameterized types other than ArrayRef or HashRef is not implemented yet");
+ }
+ $optimized_constraints->{$spec} = $code;
+ } else {
+ $code = $optimized_constraints->{ $spec };
+ if (! $code) {
+ $code = sub { Scalar::Util::blessed($_) && $_->isa($spec) };
+ $optimized_constraints->{$spec} = $code;
+ }
+ }
+ return $code;
+}
+
sub create {
my ($self, $class, $name, %args) = @_;
@@ -204,24 +257,22 @@
if exists $args{coerce};
if (exists $args{isa}) {
- confess "Mouse does not yet support parameterized types (rt.cpan.org #39795)"
- if $args{isa} =~ /\[.*\]/;
+ confess "Got isa => $args{isa}, but Mouse does not yet support parameterized types for containers other than ArrayRef and HashRef (rt.cpan.org #39795)"
+ if $args{isa} =~ /^([^\[]+)\[.+\]$/ &&
+ $1 ne 'ArrayRef' &&
+ $1 ne 'HashRef';
my $type_constraint = delete $args{isa};
$type_constraint =~ s/\s//g;
my @type_constraints = split /\|/, $type_constraint;
my $code;
- my $optimized_constraints = Mouse::Util::TypeConstraints->optimized_constraints;
if (@type_constraints == 1) {
- $code = $optimized_constraints->{$type_constraints[0]} ||
- sub { Scalar::Util::blessed($_) && $_->isa($type_constraints[0]) };
+ $code = _build_type_constraint($type_constraints[0]);
$args{type_constraint} = $type_constraints[0];
} else {
my @code_list = map {
- my $type = $_;
- $optimized_constraints->{$type} ||
- sub { Scalar::Util::blessed($_) && $_->isa($type) }
+ _build_type_constraint($_)
} @type_constraints;
$code = sub {
for my $code (@code_list) {
Modified: branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Role.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Role.pm?rev=31742&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Role.pm (original)
+++ branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Role.pm Sun Mar 8 22:51:23 2009
@@ -2,6 +2,7 @@
use strict;
use warnings;
use Carp 'confess';
+use Mouse::Util;
do {
my %METACLASS_CACHE;
@@ -107,7 +108,19 @@
for my $name ($self->get_attribute_list) {
next if $class->has_attribute($name);
my $spec = $self->get_attribute($name);
- Mouse::Meta::Attribute->create($class, $name, %$spec);
+
+ my $metaclass = 'Mouse::Meta::Attribute';
+ if ( my $metaclass_name = $spec->{metaclass} ) {
+ my $new_class = Mouse::Util::resolve_metaclass_alias(
+ 'Attribute',
+ $metaclass_name
+ );
+ if ( $metaclass ne $new_class ) {
+ $metaclass = $new_class;
+ }
+ }
+
+ $metaclass->create($class, $name, %$spec);
}
} else {
# apply role to role
@@ -188,7 +201,19 @@
for my $name ($self->get_attribute_list) {
next if $class->has_attribute($name);
my $spec = $self->get_attribute($name);
- Mouse::Meta::Attribute->create($class, $name, %$spec);
+
+ my $metaclass = 'Mouse::Meta::Attribute';
+ if ( my $metaclass_name = $spec->{metaclass} ) {
+ my $new_class = Mouse::Util::resolve_metaclass_alias(
+ 'Attribute',
+ $metaclass_name
+ );
+ if ( $metaclass ne $new_class ) {
+ $metaclass = $new_class;
+ }
+ }
+
+ $metaclass->create($class, $name, %$spec);
}
}
} else {
Modified: branches/upstream/libmouse-perl/current/lib/Mouse/Tiny.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/lib/Mouse/Tiny.pm?rev=31742&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/lib/Mouse/Tiny.pm (original)
+++ branches/upstream/libmouse-perl/current/lib/Mouse/Tiny.pm Sun Mar 8 22:51:23 2009
@@ -208,7 +208,7 @@
use 5.006;
use base 'Exporter';
-our $VERSION = '0.18';
+our $VERSION = '0.19';
use Carp 'confess';
use Scalar::Util 'blessed';
@@ -578,6 +578,59 @@
return \%method_map;
}
+my $optimized_constraints;
+sub _build_type_constraint {
+ my $spec = shift;
+ $optimized_constraints ||= Mouse::Util::TypeConstraints->optimized_constraints;
+ my $code;
+ if ($spec =~ /^([^\[]+)\[(.+)\]$/) {
+ # parameterized
+ my $constraint = $1;
+ my $param = $2;
+ my $parent = _build_type_constraint($constraint);
+ my $child = _build_type_constraint($param);
+ if ($constraint eq 'ArrayRef') {
+ my $code_str =
+ "sub {\n" .
+ " if (\$parent->(\$_)) {\n" .
+ " foreach my \$e (@\$_) {\n" .
+ " local \$_ = \$e;\n" .
+ " return () unless \$child->(\$_);\n" .
+ " }\n" .
+ " return 1;\n" .
+ " }\n" .
+ " return ();\n" .
+ "};\n"
+ ;
+ $code = eval $code_str or Carp::confess($@);
+ } elsif ($constraint eq 'HashRef') {
+ my $code_str =
+ "sub {\n" .
+ " if (\$parent->(\$_)) {\n" .
+ " foreach my \$e (values %\$_) {\n" .
+ " local \$_ = \$e;\n" .
+ " return () unless \$child->(\$_);\n" .
+ " }\n" .
+ " return 1;\n" .
+ " }\n" .
+ " return ();\n" .
+ "};\n"
+ ;
+ $code = eval $code_str or Carp::confess($@);
+ } else {
+ Carp::confess("Support for parameterized types other than ArrayRef or HashRef is not implemented yet");
+ }
+ $optimized_constraints->{$spec} = $code;
+ } else {
+ $code = $optimized_constraints->{ $spec };
+ if (! $code) {
+ $code = sub { Scalar::Util::blessed($_) && $_->isa($spec) };
+ $optimized_constraints->{$spec} = $code;
+ }
+ }
+ return $code;
+}
+
sub create {
my ($self, $class, $name, %args) = @_;
@@ -591,24 +644,22 @@
if exists $args{coerce};
if (exists $args{isa}) {
- confess "Mouse does not yet support parameterized types (rt.cpan.org #39795)"
- if $args{isa} =~ /\[.*\]/;
+ confess "Got isa => $args{isa}, but Mouse does not yet support parameterized types for containers other than ArrayRef and HashRef (rt.cpan.org #39795)"
+ if $args{isa} =~ /^([^\[]+)\[.+\]$/ &&
+ $1 ne 'ArrayRef' &&
+ $1 ne 'HashRef';
my $type_constraint = delete $args{isa};
$type_constraint =~ s/\s//g;
my @type_constraints = split /\|/, $type_constraint;
my $code;
- my $optimized_constraints = Mouse::Util::TypeConstraints->optimized_constraints;
if (@type_constraints == 1) {
- $code = $optimized_constraints->{$type_constraints[0]} ||
- sub { Scalar::Util::blessed($_) && $_->isa($type_constraints[0]) };
+ $code = _build_type_constraint($type_constraints[0]);
$args{type_constraint} = $type_constraints[0];
} else {
my @code_list = map {
- my $type = $_;
- $optimized_constraints->{$type} ||
- sub { Scalar::Util::blessed($_) && $_->isa($type) }
+ _build_type_constraint($_)
} @type_constraints;
$code = sub {
for my $code (@code_list) {
@@ -1340,7 +1391,6 @@
use strict;
use warnings;
use Carp 'confess';
-
do {
my %METACLASS_CACHE;
@@ -1445,7 +1495,19 @@
for my $name ($self->get_attribute_list) {
next if $class->has_attribute($name);
my $spec = $self->get_attribute($name);
- Mouse::Meta::Attribute->create($class, $name, %$spec);
+
+ my $metaclass = 'Mouse::Meta::Attribute';
+ if ( my $metaclass_name = $spec->{metaclass} ) {
+ my $new_class = Mouse::Util::resolve_metaclass_alias(
+ 'Attribute',
+ $metaclass_name
+ );
+ if ( $metaclass ne $new_class ) {
+ $metaclass = $new_class;
+ }
+ }
+
+ $metaclass->create($class, $name, %$spec);
}
} else {
# apply role to role
@@ -1526,7 +1588,19 @@
for my $name ($self->get_attribute_list) {
next if $class->has_attribute($name);
my $spec = $self->get_attribute($name);
- Mouse::Meta::Attribute->create($class, $name, %$spec);
+
+ my $metaclass = 'Mouse::Meta::Attribute';
+ if ( my $metaclass_name = $spec->{metaclass} ) {
+ my $new_class = Mouse::Util::resolve_metaclass_alias(
+ 'Attribute',
+ $metaclass_name
+ );
+ if ( $metaclass ne $new_class ) {
+ $metaclass = $new_class;
+ }
+ }
+
+ $metaclass->create($class, $name, %$spec);
}
}
} else {
@@ -1915,7 +1989,13 @@
if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
};
- my $constraint = $conf{where} || do { $TYPE{delete $conf{as} || 'Any' } };
+ my $constraint = $conf{where} || do {
+ my $as = delete $conf{as} || 'Any';
+ if (! exists $TYPE{$as}) { # Perhaps it's a parameterized source?
+ Mouse::Meta::Attribute::_build_type_constraint($as);
+ }
+ $TYPE{$as};
+ };
my $as = $conf{as} || '';
$TYPE_SOURCE{$name} = $pkg;
@@ -1941,8 +2021,14 @@
Carp::croak "A coercion action already exists for '$type'"
if $COERCE{$name}->{$type};
- Carp::croak "Could not find the type constraint ($type) to coerce from"
- unless $TYPE{$type};
+ if (! $TYPE{$type}) {
+ # looks parameterized
+ if ($type =~ /^[^\[]+\[.+\]$/) {
+ Mouse::Meta::Attribute::_build_type_constraint($type);
+ } else {
+ Carp::croak "Could not find the type constraint ($type) to coerce from"
+ }
+ }
push @{ $COERCE_KEYS{$name} }, $type;
$COERCE{$name}->{$type} = $code;
Modified: branches/upstream/libmouse-perl/current/lib/Mouse/Util/TypeConstraints.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/lib/Mouse/Util/TypeConstraints.pm?rev=31742&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/lib/Mouse/Util/TypeConstraints.pm (original)
+++ branches/upstream/libmouse-perl/current/lib/Mouse/Util/TypeConstraints.pm Sun Mar 8 22:51:23 2009
@@ -90,7 +90,13 @@
if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
};
- my $constraint = $conf{where} || do { $TYPE{delete $conf{as} || 'Any' } };
+ my $constraint = $conf{where} || do {
+ my $as = delete $conf{as} || 'Any';
+ if (! exists $TYPE{$as}) { # Perhaps it's a parameterized source?
+ Mouse::Meta::Attribute::_build_type_constraint($as);
+ }
+ $TYPE{$as};
+ };
my $as = $conf{as} || '';
$TYPE_SOURCE{$name} = $pkg;
@@ -116,8 +122,14 @@
Carp::croak "A coercion action already exists for '$type'"
if $COERCE{$name}->{$type};
- Carp::croak "Could not find the type constraint ($type) to coerce from"
- unless $TYPE{$type};
+ if (! $TYPE{$type}) {
+ # looks parameterized
+ if ($type =~ /^[^\[]+\[.+\]$/) {
+ Mouse::Meta::Attribute::_build_type_constraint($type);
+ } else {
+ Carp::croak "Could not find the type constraint ($type) to coerce from"
+ }
+ }
push @{ $COERCE_KEYS{$name} }, $type;
$COERCE{$name}->{$type} = $code;
Modified: branches/upstream/libmouse-perl/current/t/043-parameterized-type.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/t/043-parameterized-type.t?rev=31742&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/t/043-parameterized-type.t (original)
+++ branches/upstream/libmouse-perl/current/t/043-parameterized-type.t Sun Mar 8 22:51:23 2009
@@ -1,13 +1,11 @@
#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 1;
+use Test::More tests => 9;
use Test::Exception;
-TODO: {
- local $TODO = "Mouse does not support parameterized types yet";
-
- eval {
+{
+ {
package Foo;
use Mouse;
@@ -15,8 +13,78 @@
is => 'ro',
isa => 'HashRef[Int]',
);
+
+ has bar => (
+ is => 'ro',
+ isa => 'ArrayRef[Int]',
+ );
+
+ has 'complex' => (
+ is => 'rw',
+ isa => 'ArrayRef[HashRef[Int]]'
+ );
};
ok(Foo->meta->has_attribute('foo'));
-};
+ lives_and {
+ my $hash = { a => 1, b => 2, c => 3 };
+ my $array = [ 1, 2, 3 ];
+ my $complex = [ { a => 1, b => 1 }, { c => 2, d => 2} ];
+ my $foo = Foo->new(foo => $hash, bar => $array, complex => $complex);
+
+ is_deeply($foo->foo(), $hash, "foo is a proper hash");
+ is_deeply($foo->bar(), $array, "bar is a proper array");
+ is_deeply($foo->complex(), $complex, "complex is a proper ... structure");
+ } "Parameterized constraints work";
+
+ # check bad args
+ throws_ok {
+ Foo->new( foo => { a => 'b' });
+ } qr/Attribute \(foo\) does not pass the type constraint because: Validation failed for 'HashRef\[Int\]' failed with value/, "Bad args for hash throws an exception";
+
+ throws_ok {
+ Foo->new( bar => [ a => 'b' ]);
+ } qr/Attribute \(bar\) does not pass the type constraint because: Validation failed for 'ArrayRef\[Int\]' failed with value/, "Bad args for array throws an exception";
+
+ throws_ok {
+ Foo->new( complex => [ { a => 1, b => 1 }, { c => "d", e => "f" } ] )
+ } qr/Attribute \(complex\) does not pass the type constraint because: Validation failed for 'ArrayRef\[HashRef\[Int\]\]' failed with value/, "Bad args for complex types throws an exception";
+}
+
+{
+ {
+ package Bar;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ subtype 'Bar::List'
+ => as 'ArrayRef[HashRef]'
+ ;
+ coerce 'Bar::List'
+ => from 'ArrayRef[Str]'
+ => via {
+ [ map { +{ $_ => 1 } } @$_ ]
+ }
+ ;
+ has 'list' => (
+ is => 'ro',
+ isa => 'Bar::List',
+ coerce => 1,
+ );
+ }
+
+ lives_and {
+ my @list = ( {a => 1}, {b => 1}, {c => 1} );
+ my $bar = Bar->new(list => [ qw(a b c) ]);
+
+ is_deeply( $bar->list, \@list, "list is as expected");
+ } "coercion works";
+
+ throws_ok {
+ Bar->new(list => [ { 1 => 2 }, 2, 3 ]);
+ } qr/Attribute \(list\) does not pass the type constraint because: Validation failed for 'Bar::List' failed with value/, "Bad coercion parameter throws an error";
+}
+
+
+
Modified: branches/upstream/libmouse-perl/current/t/044-attribute-metaclass.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/t/044-attribute-metaclass.t?rev=31742&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/t/044-attribute-metaclass.t (original)
+++ branches/upstream/libmouse-perl/current/t/044-attribute-metaclass.t Sun Mar 8 22:51:23 2009
@@ -9,9 +9,9 @@
use Mouse;
extends 'Mouse::Meta::Attribute';
- around 'create' => sub {
- my ($next, @args) = @_;
- my $attr = $next->(@args);
+ sub create {
+ my ($self, @args) = @_;
+ my $attr = $self->SUPER::create(@args);
my %provides = %{$attr->{provides}};
my $method_constructors = {
add => sub {
Added: branches/upstream/libmouse-perl/current/t/047-attribute-metaclass-role.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/t/047-attribute-metaclass-role.t?rev=31742&op=file
==============================================================================
--- branches/upstream/libmouse-perl/current/t/047-attribute-metaclass-role.t (added)
+++ branches/upstream/libmouse-perl/current/t/047-attribute-metaclass-role.t Sun Mar 8 22:51:23 2009
@@ -1,0 +1,92 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 7;
+use lib 't/lib';
+
+do {
+ package MouseX::AttributeHelpers::Number;
+ use Mouse;
+ extends 'Mouse::Meta::Attribute';
+
+ sub create {
+ my ($self, @args) = @_;
+ my $attr = $self->SUPER::create(@args);
+ my %provides = %{$attr->{provides}};
+ my $method_constructors = {
+ add => sub {
+ my ($attr, $name) = @_;
+ return sub {
+ $_[0]->$name( $_[0]->$name() + $_[1])
+ };
+ },
+ };
+ while (my ($name, $aliased) = each %provides) {
+ $attr->associated_class->add_method(
+ $aliased => $method_constructors->{$name}->($attr, $attr->name)
+ );
+ }
+ return $attr;
+ };
+
+ package # hide me from search.cpan.org
+ Mouse::Meta::Attribute::Custom::Number;
+ sub register_implementation { 'MouseX::AttributeHelpers::Number' }
+
+ 1;
+
+ package Foo;
+ use Mouse::Role;
+
+ has 'i' => (
+ metaclass => 'Number',
+ is => 'rw',
+ isa => 'Int',
+ provides => {
+ 'add' => 'add_number'
+ },
+ );
+ sub f_m {}
+
+ package Bar;
+ use Mouse::Role;
+
+ has 'j' => (
+ metaclass => 'Number',
+ is => 'rw',
+ isa => 'Int',
+ provides => {
+ 'add' => 'add_number_j'
+ },
+ );
+ sub b_m {}
+
+ package Klass1;
+ use Mouse;
+ with 'Foo';
+
+ package Klass2;
+ use Mouse;
+ with 'Foo', 'Bar';
+
+};
+
+{
+ # normal
+ can_ok 'Klass1', 'add_number';
+ my $k = Klass1->new(i=>3);
+ $k->add_number(4);
+ is $k->i, 7;
+}
+
+{
+ # combine
+ can_ok 'Klass2', 'f_m';
+ can_ok 'Klass2', 'b_m';
+ can_ok 'Klass2', 'add_number';
+ can_ok 'Klass2', 'add_number_j';
+ my $k = Klass2->new(i=>3);
+ $k->add_number(4);
+ is $k->i, 7;
+}
+
More information about the Pkg-perl-cvs-commits
mailing list