[libmoox-late-perl] 04/07: cache coderefs; big refactor of type constraitn stuff
Intrigeri
intrigeri at moszumanska.debian.org
Thu Aug 14 11:13:32 UTC 2014
This is an automated email from the git hooks/post-receive script.
intrigeri pushed a commit to tag 0.003
in repository libmoox-late-perl.
commit f65a0bba0b8b037189b3e91e30896b0ebba34753
Author: Toby Inkster <mail at tobyinkster.co.uk>
Date: Sun Dec 2 21:49:00 2012 +0000
cache coderefs; big refactor of type constraitn stuff
---
examples/simple.pl | 2 +-
lib/MooX/late.pm | 195 ++++++++++++++++++++++++++++-------------------------
2 files changed, 106 insertions(+), 91 deletions(-)
diff --git a/examples/simple.pl b/examples/simple.pl
index 632e105..7f887b2 100644
--- a/examples/simple.pl
+++ b/examples/simple.pl
@@ -3,4 +3,4 @@ use Moo;
use MooX::late;
has bar => (is => 'ro', isa => 'Str|ArrayRef[Int|Num]|Int');
-Foo->new(bar => [1, "xyz", 3])
+Foo->new(bar => [1, '2o', 3])
diff --git a/lib/MooX/late.pm b/lib/MooX/late.pm
index 1085894..7e46877 100644
--- a/lib/MooX/late.pm
+++ b/lib/MooX/late.pm
@@ -178,121 +178,136 @@ sub _process_lazy_build
$_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
}
- sub _type_constraint
+ sub _get_simple_type_constraint
{
my $tc = shift;
- $tc =~ s/(^\s+|\s+$)//g;
+ return {
+ Any => sub { 1 },
+ Item => sub { 1 },
+ Undef => sub { !defined $_[0] },
+ Defined => sub { defined $_[0] },
+ Value => sub { !ref $_[0] },
+ Bool => sub {
+ return 1 unless defined $_[0];
+ !ref($_[0]) and $_[0]=~ /^(0|1|)$/;
+ },
+ Str => sub { ref(\$_[0]) eq 'SCALAR' },
+ Num => sub { Scalar::Util::looks_like_number($_[0]) },
+ Int => sub { "$_[0]" =~ /^-?[0-9]+$/x },
+ ScalarRef => sub { ref($_[0]) eq 'SCALAR' },
+ ArrayRef => sub { ref($_[0]) eq 'ARRAY' },
+ HashRef => sub { ref($_[0]) eq 'HASH' },
+ CodeRef => sub { ref($_[0]) eq 'CODE' },
+ RegexpRef => sub { ref($_[0]) eq 'Regexp' },
+ GlobRef => sub { ref($_[0]) eq 'GLOB' },
+ FileHandle=> sub {
+ Scalar::Util::openhandle($_[0]) or
+ blessed($_[0]) && $_[0]->isa('IO::Handle');
+ },
+ Object => sub { blessed($_[0]) },
+ ClassName => sub { is_module_name($_[0]) },
+ RoleName => sub { is_module_name($_[0]) },
+ }->{$tc} or sub { 1 };
+ }
+
+ sub _get_type_constraint_union
+ {
+ my @tc =
+ grep defined,
+ map { _type_constraint($_) }
+ _parse_type_constraint_union($_[0]);
- if ($tc =~ /^(
- Any|Item|Bool|Undef|Defined|Value|Str|Num|Int|
- Ref|CodeRef|RegexpRef|GlobRef|FileHandle|Object|
- ArrayRef|HashRef|ClassName|RoleName
- )$/x)
+ return sub {
+ my $value = shift;
+ foreach my $x (@tc) {
+ return 1 if eval { $x->($value) };
+ }
+ return;
+ };
+ }
+
+ sub _get_parameterized_type_constraint
+ {
+ my ($outer, $inner) = _parse_parameterized_type_constraint($_[0]);
+ $inner = _type_constraint($inner);
+
+ if ($outer eq 'Maybe')
{
- return {
- Any => sub { 1 },
- Item => sub { 1 },
- Undef => sub { !defined $_[0] },
- Defined => sub { defined $_[0] },
- Value => sub { !ref $_[0] },
- Bool => sub {
- return 1 unless defined $_[0];
- !ref($_[0]) and $_[0]=~ /^(0|1|)$/;
- },
- Str => sub { ref(\$_[0]) eq 'SCALAR' },
- Num => sub { Scalar::Util::looks_like_number($_[0]) },
- Int => sub { "$_[0]" =~ /^-?[0-9]+$/x },
- ScalarRef => sub { ref($_[0]) eq 'SCALAR' },
- ArrayRef => sub { ref($_[0]) eq 'ARRAY' },
- HashRef => sub { ref($_[0]) eq 'HASH' },
- CodeRef => sub { ref($_[0]) eq 'CODE' },
- RegexpRef => sub { ref($_[0]) eq 'Regexp' },
- GlobRef => sub { ref($_[0]) eq 'GLOB' },
- FileHandle=> sub {
- Scalar::Util::openhandle($_[0]) or
- blessed($_[0]) && $_[0]->isa('IO::Handle');
- },
- Object => sub { blessed($_[0]) },
- ClassName => sub { is_module_name($_[0]) },
- RoleName => sub { is_module_name($_[0]) },
- }->{$1};
+ return sub { !defined($_[0]) or $inner->($_[0]) };
}
- if (_detect_type_constraint_union($tc))
+ if ($outer eq 'ScalarRef')
{
- my @isa =
- grep defined,
- map { _type_constraint($_) }
- _parse_type_constraint_union($tc);
-
return sub {
- my $value = shift;
- foreach my $isa (@isa) {
- return 1 if eval { $isa->($value) };
- }
- return;
+ return unless ref $_[0] eq 'SCALAR';
+ $inner->(${$_[0]});
};
}
- if (_detect_parameterized_type_constraint($tc))
+ if ($outer eq 'ArrayRef')
{
- my ($outer, $inner) =
- _parse_parameterized_type_constraint($tc);
- $inner = _type_constraint($inner);
-
- if ($outer eq 'Maybe')
- {
- return sub { !defined($_[0]) or $inner->($_[0]) };
- }
- if ($outer eq 'ScalarRef')
- {
- return sub {
- return unless ref $_[0] eq 'SCALAR';
- $inner->(${$_[0]});
- };
- }
- if ($outer eq 'ArrayRef')
- {
- return sub {
- return unless ref $_[0] eq 'ARRAY';
- foreach my $e (@{$_[0]}) {
- $inner->($e) or return;
- }
- return 1;
- };
- }
- if ($outer eq 'HashRef')
- {
- return sub {
- return unless ref $_[0] eq 'HASH';
- foreach my $e (values %{$_[0]}) {
- return unless $inner->($e);
- }
- return 1;
- };
- }
-
- return sub { 1 };
+ return sub {
+ return unless ref $_[0] eq 'ARRAY';
+ foreach my $e (@{$_[0]}) {
+ $inner->($e) or return;
+ }
+ return 1;
+ };
}
- if (is_module_name($tc))
+ if ($outer eq 'HashRef')
{
- return sub { blessed($_[0]) and $_[0]->isa($tc) };
+ return sub {
+ return unless ref $_[0] eq 'HASH';
+ foreach my $e (values %{$_[0]}) {
+ return unless $inner->($e);
+ }
+ return 1;
+ };
}
- return;
+ return sub { 1 };
+ }
+
+ 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 sub { 1 };
}
+ my %Cache;
sub _fatal_type_constraint
{
my $tc = _type_constraint(my $tc_name = shift);
- my $fatal = $tc
- ? sub { $tc->($_[0]) or die "value '$_[0]' is not a $tc_name" }
- : sub { 1 };
+
+ my $fatal = (
+ $Cache{$tc_name} ||= sub {
+ $tc->($_[0]) or
+ croak "value '$_[0]' is not a $tc_name"
+ }
+ );
# For inflation
$Moo::HandleMoose::TYPE_MAP{$fatal} = sub {
- Moose::Util::TypeConstraints::find_or_parse_type_constraint($tc_name)
+ Moose::Util::TypeConstraints::find_or_parse_type_constraint $tc_name
};
return $fatal;
--
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