[libtype-tiny-perl] 05/27: compat with Moose attribute traits
Jonas Smedegaard
js at alioth.debian.org
Fri Aug 9 21:13:09 UTC 2013
This is an automated email from the git hooks/post-receive script.
js pushed a commit to branch master
in repository libtype-tiny-perl.
commit 801a1e888922e982f60575c3ef31171c1a921034
Author: Toby Inkster <mail at tobyinkster.co.uk>
Date: Tue Jul 30 12:42:02 2013 +0100
compat with Moose attribute traits
---
lib/Type/Tiny.pm | 35 ++++++++++++++++++++++++-----------
lib/Types/TypeTiny.pm | 6 ++++++
t/moose.t | 31 +++++++++++++++++++++++++++++++
3 files changed, 61 insertions(+), 11 deletions(-)
diff --git a/lib/Type/Tiny.pm b/lib/Type/Tiny.pm
index 5eb4c23..1505791 100644
--- a/lib/Type/Tiny.pm
+++ b/lib/Type/Tiny.pm
@@ -171,6 +171,15 @@ sub _dd
}
}
+sub _loose_to_TypeTiny
+{
+ map +(
+ ref($_)
+ ? Types::TypeTiny::to_TypeTiny($_)
+ : do { require Type::Utils; Type::Utils::dwim_type($_) }
+ ), @_;
+}
+
sub name { $_[0]{name} }
sub display_name { $_[0]{display_name} ||= $_[0]->_build_display_name }
sub parent { $_[0]{parent} }
@@ -302,7 +311,7 @@ sub _build_compiled_check
sub equals
{
- my ($self, $other) = map Types::TypeTiny::to_TypeTiny($_), @_;
+ my ($self, $other) = _loose_to_TypeTiny(@_);
return unless blessed($self) && $self->isa("Type::Tiny");
return unless blessed($other) && $other->isa("Type::Tiny");
@@ -324,7 +333,7 @@ sub equals
sub is_subtype_of
{
- my ($self, $other) = map Types::TypeTiny::to_TypeTiny($_), @_;
+ my ($self, $other) = _loose_to_TypeTiny(@_);
return unless blessed($self) && $self->isa("Type::Tiny");
return unless blessed($other) && $other->isa("Type::Tiny");
@@ -339,7 +348,7 @@ sub is_subtype_of
sub is_supertype_of
{
- my ($self, $other) = map Types::TypeTiny::to_TypeTiny($_), @_;
+ my ($self, $other) = _loose_to_TypeTiny(@_);
return unless blessed($self) && $self->isa("Type::Tiny");
return unless blessed($other) && $other->isa("Type::Tiny");
@@ -348,7 +357,7 @@ sub is_supertype_of
sub is_a_type_of
{
- my ($self, $other) = map Types::TypeTiny::to_TypeTiny($_), @_;
+ my ($self, $other) = _loose_to_TypeTiny(@_);
return unless blessed($self) && $self->isa("Type::Tiny");
return unless blessed($other) && $other->isa("Type::Tiny");
@@ -357,7 +366,7 @@ sub is_a_type_of
sub strictly_equals
{
- my ($self, $other) = map Types::TypeTiny::to_TypeTiny($_), @_;
+ my ($self, $other) = _loose_to_TypeTiny(@_);
return unless blessed($self) && $self->isa("Type::Tiny");
return unless blessed($other) && $other->isa("Type::Tiny");
$self->{uniq} == $other->{uniq};
@@ -365,7 +374,7 @@ sub strictly_equals
sub is_strictly_subtype_of
{
- my ($self, $other) = map Types::TypeTiny::to_TypeTiny($_), @_;
+ my ($self, $other) = _loose_to_TypeTiny(@_);
return unless blessed($self) && $self->isa("Type::Tiny");
return unless blessed($other) && $other->isa("Type::Tiny");
@@ -380,7 +389,7 @@ sub is_strictly_subtype_of
sub is_strictly_supertype_of
{
- my ($self, $other) = map Types::TypeTiny::to_TypeTiny($_), @_;
+ my ($self, $other) = _loose_to_TypeTiny(@_);
return unless blessed($self) && $self->isa("Type::Tiny");
return unless blessed($other) && $other->isa("Type::Tiny");
@@ -389,7 +398,7 @@ sub is_strictly_supertype_of
sub is_strictly_a_type_of
{
- my ($self, $other) = map Types::TypeTiny::to_TypeTiny($_), @_;
+ my ($self, $other) = _loose_to_TypeTiny(@_);
return unless blessed($self) && $self->isa("Type::Tiny");
return unless blessed($other) && $other->isa("Type::Tiny");
@@ -804,9 +813,11 @@ sub isa
{
my $self = shift;
- if ($INC{"Moose.pm"} and ref($self) and $_[0] eq 'Moose::Meta::TypeConstraint')
+ if ($INC{"Moose.pm"} and ref($self))
{
- return !!1;
+ return !!1 if $_[0] eq 'Moose::Meta::TypeConstraint';
+ return $self->is_parameterized if $_[0] eq 'Moose::Meta::TypeConstraint::Parameterized';
+ return $self->is_parameterizable if $_[0] eq 'Moose::Meta::TypeConstraint::Parameterizable';
}
if ($INC{"Moose.pm"} and ref($self) and $_[0] =~ /^Moose/ and my $r = $self->moose_type->isa(@_))
@@ -826,6 +837,8 @@ sub can
{
my $self = shift;
+ return !!0 if $_[0] eq 'type_parameter' && blessed($_[0]) && $_[0]->has_parameters;
+
my $can = $self->SUPER::can(@_);
return $can if $can;
@@ -870,6 +883,7 @@ sub compile_type_constraint { shift->compiled_check }
sub _actually_compile_type_constraint { shift->_build_compiled_check }
sub hand_optimized_type_constraint { shift->{hand_optimized_type_constraint} }
sub has_hand_optimized_type_constraint { exists(shift->{hand_optimized_type_constraint}) }
+sub type_parameter { my @p = @{ shift->parameters || [] }; @p==1 ? $p[0] : @p }
# some stuff for Mouse-compatible API
sub __is_parameterized { shift->is_parameterized(@_) }
@@ -878,7 +892,6 @@ sub _as_string { shift->qualified_name(@_) }
sub _compiled_type_coercion { shift->coercion->compiled_coercion(@_) };
sub _identity { refaddr(shift) };
sub _unite { require Type::Tiny::Union; "Type::Tiny::Union"->new(type_constraints => \@_) };
-sub type_parameter { my @p = @{ shift->parameters || [] }; @p==1 ? $p[0] : @p }
# Hooks for Type::Tie
sub TIESCALAR { require Type::Tie; unshift @_, 'Type::Tie::SCALAR'; goto \&Type::Tie::SCALAR::TIESCALAR };
diff --git a/lib/Types/TypeTiny.pm b/lib/Types/TypeTiny.pm
index eba5f68..481f612 100644
--- a/lib/Types/TypeTiny.pm
+++ b/lib/Types/TypeTiny.pm
@@ -123,6 +123,12 @@ sub _TypeTinyFromMoose
return $t->{"Types::TypeTiny::to_TypeTiny"};
}
+ if ($t->name ne '__ANON__') {
+ require Types::Standard;
+ my $ts = 'Types::Standard'->get_type($t->name);
+ return $ts if $ts->{_is_core};
+ }
+
my %opts;
$opts{display_name} = $t->name;
$opts{constraint} = $t->constraint;
diff --git a/t/moose.t b/t/moose.t
index dc49932..931f589 100644
--- a/t/moose.t
+++ b/t/moose.t
@@ -34,6 +34,8 @@ use Test::More;
use Test::Requires { Moose => 2.0000 };
use Test::Fatal;
+note "The basics";
+
{
package Local::Class;
@@ -74,6 +76,8 @@ like(
"violation of great-grandparent type constraint",
);
+note "Introspection, comparisons, conversions...";
+
require Types::Standard;
ok(
Types::Standard::Num->moose_type->equals(
@@ -190,4 +194,31 @@ is(
'round-tripping between ->moose_type and ->Types::TypeTiny::to_TypeTiny preserves reference address'
);
+note "Native attribute traits";
+
+{
+ package MyCollection;
+ use Moose;
+ use Types::Standard qw( ArrayRef Object );
+ has things => (
+ is => 'ro',
+ isa => ArrayRef[ Object ],
+ traits => [ 'Array' ],
+ handles => { add => 'push' },
+ );
+}
+
+my $coll = MyCollection->new(things => []);
+
+ok(
+ !exception { $coll->add(bless {}, "Monkey") },
+ 'pushing ok value',
+);
+
+like(
+ exception { $coll->add({})},
+ qr{^A new member value for things does not pass its type constraint because:},
+ 'pushing not ok value',
+);
+
done_testing;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libtype-tiny-perl.git
More information about the Pkg-perl-cvs-commits
mailing list