X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FMeta%2FTypeConstraint%2FRole%2FStructured.pm;fp=lib%2FMooseX%2FMeta%2FTypeConstraint%2FRole%2FStructured.pm;h=73b9b8bb0a966146b485acbc7e4ab238a7891209;hb=bc5c0758d92c58286c4ba66a613850492525d752;hp=55fbb024de8a532d8c1e85cb8046fc8709402f0f;hpb=87aa984af39bf081ed00b9258643bd3a091547b9;p=gitmo%2FMooseX-Types-Structured.git diff --git a/lib/MooseX/Meta/TypeConstraint/Role/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Role/Structured.pm index 55fbb02..73b9b8b 100644 --- a/lib/MooseX/Meta/TypeConstraint/Role/Structured.pm +++ b/lib/MooseX/Meta/TypeConstraint/Role/Structured.pm @@ -1,7 +1,6 @@ package MooseX::Meta::TypeConstraint::Role::Structured; use Moose::Role; -use Moose::Util::TypeConstraints; =head1 NAME @@ -17,44 +16,7 @@ our $VERSION = '0.01'; =head1 DESCRIPTION -Structured type constraints let you assign an internal pattern of type -constraints to a 'container' constraint. The goal is to make it easier to -declare constraints like "ArrayRef[Int, Int, Str]" where the constraint is an -ArrayRef of three elements and the internal constraint on the three is Int, Int -and Str. - -To accomplish this, we add an attribute to the base L -to hold a L, which is a reference to a pattern of type constraints. -We then override L to check our incoming value to the attribute -against this signature pattern. - -=head1 SUBTYPES - -The following subtypes and coercions are defined in this class. - -=head2 MooseX::Meta::TypeConstraint::Structured::Signature - -This is a type constraint to normalize the incoming L. We want -everything as a HashRef in the end. - -=cut - -subtype 'MooseX::Meta::TypeConstraint::Structured::Signature', - as 'HashRef[Object]', - where { - my %signature = %$_; - foreach my $key (keys %signature) { - $signature{$key}->isa('Moose::Meta::TypeConstraint'); - } 1; - }; - -coerce 'MooseX::Meta::TypeConstraint::Structured::Signature', - from 'ArrayRef[Object]', - via { - my @signature = @$_; - my %hashed_signature = map { $_ => $signature[$_] } 0..$#signature; - \%hashed_signature; - }; +STUB - TBD =head1 ATTRIBUTES @@ -69,8 +31,7 @@ contraint container. has 'signature' => ( is=>'ro', - isa=>'MooseX::Meta::TypeConstraint::Structured::Signature', - coerce=>1, + isa=>'Ref', required=>1, ); @@ -85,20 +46,6 @@ into a HashRef so we can match it up with the L HashRef. =cut -sub _normalize_args { - my ($self, $args) = @_; - if(defined $args) { - if(ref $args eq 'ARRAY') { - return map { $_ => $args->[$_] } (0..$#$args); - } elsif (ref $args eq 'HASH') { - return %$args; - } else { - confess 'Signature must be a reference'; - } - } else { - confess 'Signature cannot be empty'; - } -} =head2 constraint @@ -106,59 +53,18 @@ The constraint is basically validating the L against the incoming =cut -sub constraint { - my $self = shift; - return sub { - my %args = $self->_normalize_args(shift); - foreach my $idx (keys %{$self->signature}) { - my $type_constraint = $self->signature->{$idx}; - if(my $error = $type_constraint->validate($args{$idx})) { - confess $error; - } - } 1; - }; -} - =head2 equals modifier to make sure equals descends into the L =cut -around 'equals' => sub { - my ($equals, $self, $compared_type_constraint) = @_; - - ## Make sure we are comparing typeconstraints of the same base class - return unless $compared_type_constraint->isa(__PACKAGE__); - - ## Make sure the base equals is also good - return unless $self->$equals($compared_type_constraint); - - ## Make sure the signatures match - return unless $self->signature_equals($compared_type_constraint); - - ## If we get this far, the two are equal - return 1; -}; - =head2 signature_equals Check that the signature equals another signature. =cut -sub signature_equals { - my ($self, $compared_type_constraint) = @_; - - foreach my $idx (keys %{$self->signature}) { - my $this = $self->signature->{$idx}; - my $that = $compared_type_constraint->signature->{$idx}; - return unless $this->equals($that); - } - - return 1; -} - =head1 AUTHOR John James Napiorkowski @@ -169,4 +75,4 @@ You may distribute this code under the same terms as Perl itself. =cut -no Moose; 1; +1;