--- /dev/null
+Revision history for MooseX-Meta-TypeContraint-Structured
+
+0.01 01 August 2008
+ First version, released on an unsuspecting world.
--- /dev/null
+
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+,v$
+\B\.svn\b
+
+# Avoid Makemaker generated and utility files.
+\bMakefile$
+\bblib
+\bMakeMaker-\d
+\bpm_to_blib$
+\bblibdirs$
+^MANIFEST\.SKIP$
+
+# for developers only :)
+^TODO$
+^VERSIONING\.SKETCH$
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\b_build
+
+# Avoid temp and backup files.
+~$
+\.tmp$
+\.old$
+\.bak$
+\#$
+\b\.#
+
+# avoid OS X finder files
+\.DS_Store$
+
+#skip komodo project files
+\.kpf$
+
+
+# Don't ship the last dist we built :)
+\.tar\.gz$
+
+# Skip maint stuff
+^maint/
\ No newline at end of file
--- /dev/null
+use inc::Module::Install;
+
+## All the required meta information
+all_from 'lib/MooseX/Meta/TypeConstraint/Structured.pm';
+
+## Module dependencies
+requires 'Moose' => '0.54';
+
+## Testing dependencies
+build_requires 'Test::More' => '0.70';
+build_requires 'Test::Exception' => '0.27';
+build_requires 'Test::Pod' => '1.14';
+build_requires 'Test::Pod::Coverage' => '1.08';
+
+## Instructions to Module::Install
+auto_install;
+tests_recursive;
+WriteAll;
+
+1;
--- /dev/null
+MooseX-Meta-TypeConstraint-Structured
+
+Structured Type Constraints for Moose. This is an extension which provides
+additional type contraint abilities for L<Moose>.
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the
+perldoc command.
+
+ perldocMooseX::Meta::TypeConstraint::Structured
+
+AUTHOR
+
+See L<MooseX::Meta::TypeConstraint::Structured> for more information regarding authors.
+
+LICENSE
+
+See L<MooseX::Meta::TypeConstraint::Structured> for the license.
+
+=cut
+
--- /dev/null
+package MooseX::Meta::TypeConstraint::Structured;
+
+use 5.8.8; ## Minimum tested Perl Version
+use Moose;
+use Moose::Util::TypeConstraints;
+
+extends 'Moose::Meta::TypeConstraint';
+
+our $AUTHORITY = 'cpan:JJNAPIORK';
+
+=head1 NAME
+
+MooseX::Meta::TypeConstraint::Structured - Structured Type Constraints
+
+=head1 VERSION
+
+0.01
+
+=cut
+
+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.
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head2 parent
+
+additional details on the inherited parent attribute
+
+=head2 signature
+
+This is a signature of internal contraints for the contents of the outer
+contraint container.
+
+=cut
+
+has 'signature' => (
+ is=>'ro',
+ isa=>'Ref',
+ required=>1,
+);
+
+=head1 METHODS
+
+This class defines the following methods.
+
+=head2 _normalize_args
+
+Get arguments into a known state or die trying
+
+=cut
+
+sub _normalize_args {
+ my ($self, $args) = @_;
+ if(defined $args && ref $args eq 'ARRAY') {
+ return @{$args};
+ } else {
+ confess 'Arguments not ArrayRef as expected.';
+ }
+}
+
+=head2 constraint
+
+The constraint is basically validating the L</signature> against the incoming
+
+=cut
+
+sub constraint {
+ my $self = shift;
+ return sub {
+ my @args = $self->_normalize_args(shift);
+ foreach my $idx (0..$#args) {
+ if(my $error = $self->signature->[$idx]->validate($args[$idx])) {
+ confess $error;
+ }
+ } 1;
+ };
+}
+
+=head1 AUTHOR
+
+John James Napiorkowski <jjnapiork@cpan.org>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+no Moose; 1;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod::Coverage
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
+ if $@;
+
+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
+# but older versions don't recognize some common documentation styles
+my $min_pc = 0.18;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
+ if $@;
+
+all_pod_coverage_ok();
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests=>1;
+
+## List all the modules we want to make sure can at least compile
+
+use_ok 'MooseX::Meta::TypeConstraint::Structured';
+
--- /dev/null
+BEGIN {
+ use strict;
+ use warnings;
+ use Test::More tests=>17;
+ use Test::Exception;
+}
+
+{
+ package Test::MooseX::Meta::TypeConstraint::Structured::Concept;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ sub _normalize_args {
+ if(defined $_[0] && ref $_[0] eq 'ARRAY') {
+ return @{$_[0]};
+ } else {
+ confess 'Arguments not normal';
+ }
+ }
+
+ sub Pair {
+ my ($canonical_key, $value) = _normalize_args(shift);
+ return subtype
+ as "HashRef[$value]",
+ where {
+ my ($key, $extra) = keys %$_;
+ ($key eq $canonical_key) && !$extra;
+ };
+ }
+
+ sub Tuple {
+ my @args = _normalize_args(shift);
+ return subtype
+ as 'ArrayRef',
+ where {
+ my @incoming = @$_;
+ foreach my $idx (0..$#args) {
+ find_type_constraint($args[$idx])->check($incoming[$idx]) ||
+ confess 'Trouble validating Tuple';
+ } 1;
+ };
+ }
+
+ sub Dict {
+ my %keys_typeconstraints = _normalize_args(shift);
+ return subtype
+ as 'HashRef',
+ where {
+ my %incoming = %$_;
+ foreach my $key (keys %keys_typeconstraints) {
+ my $type_constraint = $keys_typeconstraints{$key};
+ my $incoming = $incoming{$key} || confess "Missing $key";
+ find_type_constraint($type_constraint)->check($incoming)
+ || confess "Trouble validating Dictionary";
+ } 1;
+ };
+ }
+
+ has 'pair' => (is=>'rw', isa=>Pair[key=>'Str']);
+ has 'tuple' => (is=>'rw', isa=>Tuple['Int', 'Str']);
+ has 'dict' => (is=>'rw', isa=>Dict[name=>'Str', age=>'Int']);
+}
+
+## Instantiate a new test object
+
+ok my $record = Test::MooseX::Meta::TypeConstraint::Structured::Concept->new
+ => 'Instantiated new Record test class.';
+
+isa_ok $record => 'Test::MooseX::Meta::TypeConstraint::Structured::Concept'
+ => 'Created correct object type.';
+
+## Test the Pair type constraint
+
+lives_ok sub {
+ $record->pair({key=>'value'});
+} => 'Set pair attribute without error';
+
+is $record->pair->{key}, 'value'
+ => 'correctly set the pair attribute';
+
+throws_ok sub {
+ $record->pair({not_the_key=>'value'}) ;
+}, qr/Validation failed/
+ => 'Got Expected Error for bad key';
+
+throws_ok sub {
+ $record->pair({key=>[1,2,3]}) ;
+}, qr/Validation failed/
+ => 'Got Expected Error for bad value';
+
+## Test the Tuple type constraint
+
+lives_ok sub {
+ $record->tuple([1,'hello']);
+} => 'Set tuple attribute without error';
+
+is $record->tuple->[0], 1
+ => 'correct set the tuple attribute index 0';
+
+is $record->tuple->[1], 'hello'
+ => 'correct set the tuple attribute index 1';
+
+throws_ok sub {
+ $record->tuple('hello') ;
+}, qr/Validation failed/
+ => 'Got Expected Error when setting as a scalar';
+
+throws_ok sub {
+ $record->tuple({key=>[1,2,3]}) ;
+}, qr/Validation failed/
+ => 'Got Expected Error for trying a hashref ';
+
+throws_ok sub {
+ $record->tuple(['asdasd',2]) ;
+}, qr/Trouble validating Tuple/
+ => 'Got Expected Error for violating constraints';
+
+## Test the Dictionary type constraint
+
+lives_ok sub {
+ $record->dict({name=>'frith', age=>23});
+} => 'Set dict attribute without error';
+
+is $record->dict->{name}, 'frith'
+ => 'correct set the dict attribute name';
+
+is $record->dict->{age}, 23
+ => 'correct set the dict attribute age';
+
+throws_ok sub {
+ $record->dict('hello') ;
+}, qr/Validation failed/
+ => 'Got Expected Error for bad key in dict';
+
+throws_ok sub {
+ $record->dict({name=>[1,2,3], age=>'sdfsdfsd'});
+}, qr/Trouble validating Dictionary/
+ => 'Got Expected Error for bad value in dict';
+
--- /dev/null
+BEGIN {
+ use strict;
+ use warnings;
+ use Test::More tests=>6;
+ use Test::Exception;
+}
+
+{
+ package Test::MooseX::Meta::TypeConstraint::Structured::Positional;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+ use MooseX::Meta::TypeConstraint::Structured;
+
+ sub Tuple {
+ my $args = shift @_;
+ return MooseX::Meta::TypeConstraint::Structured->new(
+ name => 'Tuple',
+ parent => find_type_constraint('ArrayRef'),
+ package_defined_in => __PACKAGE__,
+ signature => [map {find_type_constraint($_)} @$args],
+ );
+ }
+
+ has 'tuple' => (is=>'rw', isa=>Tuple['Int', 'Str']);
+}
+
+## Instantiate a new test object
+
+ok my $record = Test::MooseX::Meta::TypeConstraint::Structured::Positional->new
+ => 'Instantiated new Record test class.';
+
+isa_ok $record => 'Test::MooseX::Meta::TypeConstraint::Structured::Positional'
+ => 'Created correct object type.';
+
+lives_ok sub {
+ $record->tuple([1,'hello']);
+} => 'Set tuple attribute without error';
+
+is $record->tuple->[0], 1
+ => 'correct set the tuple attribute index 0';
+
+is $record->tuple->[1], 'hello'
+ => 'correct set the tuple attribute index 1';
+
+throws_ok sub {
+ $record->tuple(['asdasd',2]);
+}, qr/Validation failed for 'Int'/
+ => 'Got Expected Error for violating constraints';
+
projects / gitmo/MooseX-Types-Structured.git / commitdiff