[libmoox-late-perl] 02/03: swap out MooX::Types::BaseLike for Type::Tiny
Intrigeri
intrigeri at moszumanska.debian.org
Thu Aug 14 11:13:41 UTC 2014
This is an automated email from the git hooks/post-receive script.
intrigeri pushed a commit to tag 0.009
in repository libmoox-late-perl.
commit 3be926cc833ef6f67dafa97ac29c18bcd230dc8e
Author: Toby Inkster <mail at tobyinkster.co.uk>
Date: Fri Apr 12 18:57:28 2013 +0100
swap out MooX::Types::BaseLike for Type::Tiny
---
lib/MooX/late.pm | 181 +++++++++++------------------------------------------
meta/makefile.pret | 2 +-
t/01basic.t | 2 -
t/02inflation.t | 8 ---
4 files changed, 36 insertions(+), 157 deletions(-)
diff --git a/lib/MooX/late.pm b/lib/MooX/late.pm
index 8b54cfd..4c65962 100644
--- a/lib/MooX/late.pm
+++ b/lib/MooX/late.pm
@@ -107,7 +107,7 @@ sub import
sub _process_isa
{
my ($me, $name, $spec, $context) = @_;
- $spec->{isa} = _fatal_type_constraint($spec->{isa}, $context);
+ $spec->{isa} = _type_constraint($spec->{isa}, $context);
return;
}
@@ -218,158 +218,51 @@ sub _process_lazy_build
$_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
}
- our $returned_empty_handed;
- sub _empty_handed
- {
- $returned_empty_handed++;
-
- my $tc = shift;
- return sub { 1 };
- }
-
- my $warned = 0;
- sub _get_simple_type_constraint
- {
- no strict 'refs';
-
- eval { require MooX::Types::MooseLike::Base }
- or do {
- carp "Use of isa => STRING requires MooX::Types::MooseLike::Base"
- unless $warned++;
- return _empty_handed($_[0]);
- };
-
- my $tc = shift;
- return {
- ClassName => sub { is_module_name($_[0]) },
- RoleName => sub { is_module_name($_[0]) },
- map {
- $_ => \&{"MooX::Types::MooseLike::Base::is_$_"};
- }
- qw {
- Any Item Undef Defined Value Bool Str Num Int
- CodeRef RegexpRef GlobRef FileHandle Object
- ArrayRef HashRef ScalarRef
- }
- }->{$tc} or _empty_handed($tc);
- }
-
- sub _get_type_constraint_union
- {
- my @tc =
- grep defined,
- map { _type_constraint($_) }
- _parse_type_constraint_union($_[0]);
-
- return sub {
- my $value = shift;
- foreach my $x (@tc) {
- return 1 if $x->($value);
- }
- return;
- };
- }
-
- sub _get_parameterized_type_constraint
+ sub _type_constraint
{
- my ($outer, $inner) = _parse_parameterized_type_constraint($_[0]);
- $inner = _type_constraint($inner);
+ my ($tc, $ctx) = @_;
+ $tc =~ s/(^\s+|\s+$)//g;
- if ($outer eq 'Maybe')
+ if ($tc =~ /^(
+ Any|Item|Bool|Undef|Defined|Value|Str|Num|Int|
+ Ref|CodeRef|RegexpRef|GlobRef|FileHandle|Object|
+ ScalarRef|ArrayRef|HashRef|ClassName|RoleName
+ )$/x)
{
- return sub { !defined($_[0]) or $inner->($_[0]) };
+ require Types::Standard;
+ return $_ for grep defined, Types::Standard->meta->get_type($tc);
}
- if ($outer eq 'ScalarRef')
+ elsif (_detect_type_constraint_union($tc))
{
- return sub {
- return unless ref $_[0] eq 'SCALAR';
- $inner->(${$_[0]});
- };
+ require Type::Utils;
+ my @tc = grep defined, map _type_constraint($_), _parse_type_constraint_union($tc);
+ return Type::Utils::union(\@tc);
}
- if ($outer eq 'ArrayRef')
+ elsif (_detect_parameterized_type_constraint($tc))
{
- return sub {
- return unless ref $_[0] eq 'ARRAY';
- foreach my $e (@{$_[0]}) {
- $inner->($e) or return;
- }
- return 1;
- };
+ my ($outer, $inner) = map _type_constraint($_), _parse_parameterized_type_constraint($tc);
+ return $outer->parameterize($inner);
}
- if ($outer eq 'HashRef')
+ elsif (is_module_name($tc))
{
- return sub {
- return unless ref $_[0] eq 'HASH';
- foreach my $e (values %{$_[0]}) {
- return unless $inner->($e);
- }
- return 1;
- };
- }
-
- return _empty_handed($_[0]);
- }
-
- sub _type_constraint
- {
- my $tc = shift;
- $tc =~ s/(^\s+|\s+$)//g;
-
- $tc =~ /^(
- Any|Item|Bool|Undef|Defined|Value|Str|Num|Int|
- Ref|CodeRef|RegexpRef|GlobRef|FileHandle|Object|
- ScalarRef|ArrayRef|HashRef|ClassName|RoleName
- )$/x
- and return _get_simple_type_constraint($1);
-
- _detect_type_constraint_union($tc)
- and return _get_type_constraint_union($tc);
-
- _detect_parameterized_type_constraint($tc)
- and return _get_parameterized_type_constraint($tc);
-
- is_module_name($tc)
- and return sub { blessed($_[0]) and $_[0]->isa($tc) };
-
- return _empty_handed($tc);
- }
-
- my %Cache;
- sub _fatal_type_constraint
- {
- my ($tc_name, $context) = @_;
-
- $returned_empty_handed = 0;
- my $tc = _type_constraint($tc_name);
-
- if ($returned_empty_handed) {
- # Don't cache; don't inflate
- my $warned;
- return sub {
- unless ($warned) {
- carp "Type constraint '$tc_name' not fully enforced (defined at $context)";
- $warned++;
- }
- $tc->($_[0]) or croak "value '$_[0]' is not a $tc_name";
- }
+ require Type::Utils;
+ Type::Utils::class_type({ class => $tc });
}
- my $fatal = (
- $Cache{$tc_name} ||= sub {
- $tc->($_[0]) or
- croak "value '$_[0]' is not a $tc_name"
- }
+ require Type::Utils;
+ require Types::Standard;
+ my $warned = 0;
+ Type::Utils::declare(
+ Type::Utils::as( Types::Standard::Any() ),
+ Type::Utils::where(sub {
+ $warned ||=1+!! carp("Type constraint '$tc' not fully enforced (defined at $ctx)");
+ !!1;
+ }),
+ display_name => $tc,
);
-
- # For inflation
- $Moo::HandleMoose::TYPE_MAP{$fatal} = sub {
- Moose::Util::TypeConstraints::find_or_parse_type_constraint $tc_name
- };
-
- return $fatal;
}
}
@@ -415,9 +308,7 @@ Allows C<< isa => $string >> to work when defining attributes for all
Moose's built-in type constraints (and assumes other strings are package
names).
-This feature require L<MooX::Types::MooseLike::Base>. If you don't
-have it, you'll get a warning message and all your C<isa> checks will be
-no-ops.
+This feature requires L<Types::Standard>.
=item 2.
@@ -462,8 +353,7 @@ L<http://rt.cpan.org/Dist/Display.html?Queue=MooX-late>.
=head1 SEE ALSO
-C<MooX::late> uses L<MooX::Types::MooseLike::Base> to check many type
-constraints.
+C<MooX::late> uses L<Types::Standard> to check type constraints.
The following modules bring additional Moose functionality to Moo:
@@ -479,9 +369,8 @@ L<MooX::Augment> - support augment/inner
=back
-L<MooX::HandlesVia|https://github.com/mattp-/MooX-HandlesVia> is also in
-development, and once released MooX::late may be able to use it to add
-a native-traits-like feature.
+L<MooX::HandlesVia> provides a native-traits-like feature for Moo. There
+are plans afoot to add MooX::HandlesVia magic to MooX::late.
L<MooX> allows you to load Moo plus multiple MooX extension modules in a
single line.
diff --git a/meta/makefile.pret b/meta/makefile.pret
index 85908a3..b92a1c7 100644
--- a/meta/makefile.pret
+++ b/meta/makefile.pret
@@ -6,7 +6,7 @@
readme_from m`MooX::late`;
test_requires p`Test::More 0.61`;
requires p`Moo 1.000004`;
- requires p`MooX::Types::MooseLike::Base`;
+ requires p`Type::Tiny 0.000_08`;
recommends p`MooX`;
.
diff --git a/t/01basic.t b/t/01basic.t
index ba8881a..3f1c223 100644
--- a/t/01basic.t
+++ b/t/01basic.t
@@ -43,12 +43,10 @@ is($o2->foo, 'bar');
is($o2->bar, 'foo');
ok not eval {
- require MooX::Types::MooseLike::Base;
Local::Class->new(foo => []);
};
ok not eval {
- require MooX::Types::MooseLike::Base;
Local::Class->new(bar => []);
};
diff --git a/t/02inflation.t b/t/02inflation.t
index 02b4c04..ff78a8e 100644
--- a/t/02inflation.t
+++ b/t/02inflation.t
@@ -3,8 +3,6 @@
Check that our type constraints are correctly inflated to Moose type
constraints.
-This test is skipped if L<MooX::Types::MooseLike::Base> is unavailable.
-
=head1 AUTHOR
Toby Inkster E<lt>tobyink at cpan.orgE<gt>.
@@ -23,11 +21,6 @@ use warnings;
use Test::More;
BEGIN {
- eval { require MooX::Types::MooseLike::Base }
- or plan skip_all => 'requires MooX::Types::MooseLike::Base'
-};
-
-BEGIN {
package Local::Class;
use Moo;
use MooX::late;
@@ -35,7 +28,6 @@ BEGIN {
};
ok not eval {
- require MooX::Types::MooseLike::Base;
my $obj = Local::Class->new(foo => [])
};
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libmoox-late-perl.git
More information about the Pkg-perl-cvs-commits
mailing list