[libmoox-late-perl] 07/11: strip out loads of code for parsing type constraints and replace with Type::Parser+Type::Registry
Intrigeri
intrigeri at moszumanska.debian.org
Thu Aug 14 11:13:47 UTC 2014
This is an automated email from the git hooks/post-receive script.
intrigeri pushed a commit to tag 0.012
in repository libmoox-late-perl.
commit 21791f6882049e9f1d7e7d4590a9242da33ce23a
Author: Toby Inkster <mail at tobyinkster.co.uk>
Date: Fri Jun 28 01:30:18 2013 +0100
strip out loads of code for parsing type constraints and replace with Type::Parser+Type::Registry
---
lib/MooX/late.pm | 150 ++++++------------------------------------
lib/MooX/late/TypeRegistry.pm | 44 +++++++++++++
t/03invalid_tc.t | 29 +++-----
3 files changed, 74 insertions(+), 149 deletions(-)
diff --git a/lib/MooX/late.pm b/lib/MooX/late.pm
index bcd81fc..58c8688 100644
--- a/lib/MooX/late.pm
+++ b/lib/MooX/late.pm
@@ -87,11 +87,11 @@ sub import
for my $name (ref $proto ? @$proto : $proto)
{
my $spec = +{ %spec }; # shallow clone
- $me->_process_isa($name, $spec, $context)
+ $me->_process_isa($name, $spec, $context, $caller)
if exists $spec->{isa} && !ref $spec->{isa};
- $me->_process_default($name, $spec, $context)
+ $me->_process_default($name, $spec, $context, $caller)
if exists $spec->{default} && !ref $spec->{default};
- $me->_process_lazy_build($name, $spec, $context)
+ $me->_process_lazy_build($name, $spec, $context, $caller)
if exists $spec->{lazy_build} && $spec->{lazy_build};
$orig->($name, %$spec);
@@ -104,10 +104,17 @@ sub import
$install_tracked->($caller, confess => \&Carp::confess);
}
+my %registry;
sub _process_isa
{
- my ($me, $name, $spec, $context) = @_;
- $spec->{isa} = _type_constraint($spec->{isa}, $context);
+ my ($me, $name, $spec, $context, $class) = @_;
+ my $reg = (
+ $registry{$class} ||= do {
+ require MooX::late::TypeRegistry;
+ "MooX::late::TypeRegistry"->new(chained => $class);
+ }
+ );
+ $spec->{isa} = $reg->lookup($spec->{isa});
return;
}
@@ -142,130 +149,6 @@ sub _process_lazy_build
return;
}
-# A bunch of stuff stolen from Moose::Util::TypeConstraints...
-{
- my $valid_chars = qr{[\w:\.]};
- my $type_atom = qr{ (?>$valid_chars+) }x;
- my $ws = qr{ (?>\s*) }x;
- my $op_union = qr{ $ws \| $ws }x;
- my ($type, $type_capture_parts, $type_with_parameter, $union, $any);
- if ($] >= 5.010)
- {
- my $type_pattern = q{ (?&type_atom) (?: \[ (?&ws) (?&any) (?&ws) \] )? };
- my $type_capture_parts_pattern = q{ ((?&type_atom)) (?: \[ (?&ws) ((?&any)) (?&ws) \] )? };
- my $type_with_parameter_pattern = q{ (?&type_atom) \[ (?&ws) (?&any) (?&ws) \] };
- my $union_pattern = q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) };
- my $any_pattern = q{ (?&type) | (?&union) };
-
- my $defines = qr{(?(DEFINE)
- (?<valid_chars> $valid_chars)
- (?<type_atom> $type_atom)
- (?<ws> $ws)
- (?<op_union> $op_union)
- (?<type> $type_pattern)
- (?<type_capture_parts> $type_capture_parts_pattern)
- (?<type_with_parameter> $type_with_parameter_pattern)
- (?<union> $union_pattern)
- (?<any> $any_pattern)
- )}x;
-
- $type = qr{ $type_pattern $defines }x;
- $type_capture_parts = qr{ $type_capture_parts_pattern $defines }x;
- $type_with_parameter = qr{ $type_with_parameter_pattern $defines }x;
- $union = qr{ $union_pattern $defines }x;
- $any = qr{ $any_pattern $defines }x;
- }
- else
- {
- use re 'eval';
-
- $type = qr{ $type_atom (?: \[ $ws (??{$any}) $ws \] )? }x;
- $type_capture_parts = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x;
- $type_with_parameter = qr{ $type_atom \[ $ws (??{$any}) $ws \] }x;
- $union = qr{ $type (?> (?: $op_union $type )+ ) }x;
- $any = qr{ $type | $union }x;
- }
-
- sub _parse_parameterized_type_constraint {
- { no warnings 'void'; $any; } # force capture of interpolated lexical
- $_[0] =~ m{ $type_capture_parts }x;
- return ( $1, $2 );
- }
-
- sub _detect_parameterized_type_constraint {
- { no warnings 'void'; $any; } # force capture of interpolated lexical
- $_[0] =~ m{ ^ $type_with_parameter $ }x;
- }
-
- sub _parse_type_constraint_union {
- { no warnings 'void'; $any; } # force capture of interpolated lexical
- my $given = shift;
- my @rv;
- while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
- push @rv => $1;
- }
- ( pos($given) eq length($given) )
- || __PACKAGE__->_throw_error( "'$given' didn't parse (parse-pos="
- . pos($given)
- . " and str-length="
- . length($given)
- . ")" );
- @rv;
- }
-
- sub _detect_type_constraint_union {
- { no warnings 'void'; $any; } # force capture of interpolated lexical
- $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
- }
-
- sub _type_constraint
- {
- my ($tc, $ctx) = @_;
- $tc =~ s/(^\s+|\s+$)//g;
-
- if ($tc =~ /^(
- Any|Item|Bool|Undef|Defined|Value|Str|Num|Int|
- Ref|CodeRef|RegexpRef|GlobRef|FileHandle|Object|
- ScalarRef|ArrayRef|HashRef|ClassName|RoleName|Maybe
- )$/x)
- {
- require Types::Standard;
- return $_ for grep defined, Types::Standard->meta->get_type($tc);
- }
-
- elsif (_detect_type_constraint_union($tc))
- {
- require Type::Utils;
- my @tc = grep defined, map _type_constraint($_), _parse_type_constraint_union($tc);
- return Type::Utils::union(\@tc);
- }
-
- elsif (_detect_parameterized_type_constraint($tc))
- {
- my ($outer, $inner) = map _type_constraint($_), _parse_parameterized_type_constraint($tc);
- return $outer->parameterize($inner);
- }
-
- elsif (is_module_name($tc))
- {
- require Type::Utils;
- return Type::Utils::class_type({ class => $tc });
- }
-
- require Type::Utils;
- require Types::Standard;
- my $warned = 0;
- return 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,
- );
- }
-}
-
1;
__END__
@@ -346,6 +229,15 @@ Package::Variant.
importing => ['MooX::Role' => ['late']],
subs => [ qw(has with) ];
+=head2 Type constraints
+
+Type constraint strings are interpreted using L<Type::Parser>, using the
+type constraints defined in L<Types::Standard>. This provides a very slight
+superset of Moose's type constraint syntax and built-in type constraints.
+
+Any unrecognised string that looks like it might be a class name is
+interpreted as a class type constraint.
+
=head1 BUGS
Please report any bugs to
diff --git a/lib/MooX/late/TypeRegistry.pm b/lib/MooX/late/TypeRegistry.pm
new file mode 100644
index 0000000..b344e88
--- /dev/null
+++ b/lib/MooX/late/TypeRegistry.pm
@@ -0,0 +1,44 @@
+package MooX::late::TypeRegistry;
+
+use base "Type::Registry";
+
+# Preload with standard types
+sub new
+{
+ my ($class, %args) = @_;
+ my $self = $class->SUPER::new(%args);
+ $self->add_types(-Standard);
+ # this hash key should never be used by the parent class
+ $self->{"~~chained"} = $args{chained};
+ return $self;
+}
+
+sub simple_lookup
+{
+ my $self = shift;
+
+ my $r = $self->SUPER::simple_lookup(@_);
+ return $r if defined $r;
+
+ # Chaining! This is a fallback which looks up the
+ # type constraint in the class' Type::Registry if
+ # we couldn't find it ourselves.
+ #
+ my $chained = "Type::Registry"->for_class($self->{"~~chained"});
+ $r = eval { $chained->simple_lookup(@_) } unless $self == $chained;
+ return $r if defined $r;
+
+ # Lastly, if it looks like a class name, assume it's
+ # supposed to be a class type.
+ #
+ if ($_[0] =~ /^\s*(\w+(::\w+)*)\s*$/sm)
+ {
+ require Type::Tiny::Class;
+ return "Type::Tiny::Class"->new(class => $1);
+ }
+
+ # Give up already!
+ return;
+}
+
+1;
diff --git a/t/03invalid_tc.t b/t/03invalid_tc.t
index ba7c4d0..e006981 100644
--- a/t/03invalid_tc.t
+++ b/t/03invalid_tc.t
@@ -1,7 +1,6 @@
=head1 PURPOSE
-Check that we get warnings about unrecognisable type constraints, but only
-when a value is actually tested against the constraint.
+Check that we get error messages about unrecognisable type constraints.
=head1 AUTHOR
@@ -19,32 +18,22 @@ the same terms as the Perl 5 programming language system itself.
use strict;
use warnings;
-use if !eval { require Test::Warn },
- 'Test::More', skip_all => 'requires Test::Warn';
-use Test::Warn;
use Test::More;
-eval q {
+$@ = undef;
+ok !eval q {
# line 1 "embedded"
package Foo;
use Moo;
use MooX::late;
has foo => (is => 'ro', isa => 'X Y Z', required => 0);
+ 1;
};
-# type constraint should not be checked, so no warning expected
-warnings_are {
- my $foo = Foo->new();
-} [];
-
-# But this should warn
-warnings_like {
- my $foo = Foo->new(foo => 1);
-} qr{Type constraint 'X Y Z' not fully enforced \(defined at embedded:4, package Foo\)};
-
-# But we shouldn't get the same warning again. Too much noise!
-warnings_are {
- my $foo = Foo->new(foo => 1);
-} [];
+like(
+ $@,
+ qr{^Unexpected tail on type expression: Y Z},
+ 'error message looks ok',
+);
done_testing;
--
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