From: John Napiorkowski Date: Fri, 27 Mar 2009 21:44:24 +0000 (+0000) Subject: got the basic tests in place, got the types organized how I want this to work. Still... X-Git-Tag: 0.01~50 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3cfd35fdfa2f99812c2d8806aec1b5f01b0100a8;hp=328fad4dedc851a4cab988ab33c3f0b1dead231e;p=gitmo%2FMooseX-Dependent.git got the basic tests in place, got the types organized how I want this to work. Still a lot of unknowns. --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..5ab183e --- /dev/null +++ b/Changes @@ -0,0 +1,6 @@ +Revision history for MooseX-Types-Structured + +0.01 27 March 2009 + - Completed basic requirements, documentation and tests. + - Today my dog, "Sunshine" is one year old. This release is dedicated + to her. diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..b055a14 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,43 @@ + +# 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 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..c891688 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,29 @@ +use inc::Module::Install; + +## All the required meta information +name 'MooseX-Types-Dependent'; +all_from 'lib/MooseX/Types/Dependent.pm'; +abstract 'Moose Type Constraint for creating Dependent Types Constraints'; +author 'John Napiorkowski '; +license 'perl'; + +## Module dependencies +requires 'Moose' => '0.73'; +requires 'Scalar::Util' => '1.19'; + +## 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'; + +## Build README +system 'pod2text lib/MooseX/Types/Dependent.pm > README' + if -e 'MANIFEST.SKIP'; + +## Instructions to Module::Install +auto_install; +tests_recursive; +WriteAll; + +1; diff --git a/lib/MooseX/Meta/TypeCoercion/Dependent.pm b/lib/MooseX/Meta/TypeCoercion/Dependent.pm new file mode 100644 index 0000000..991020e --- /dev/null +++ b/lib/MooseX/Meta/TypeCoercion/Dependent.pm @@ -0,0 +1,36 @@ +package ## Hide from PAUSE + MooseX::Meta::TypeCoercion::Dependent; + +use Moose; +extends 'Moose::Meta::TypeCoercion'; + +=head1 NAME + +MooseX::Meta::TypeCoercion::Dependent - Coerce structured type constraints. + +=head1 DESCRIPTION + +TBD + +=head1 METHODS + +This class defines the following methods. + +=head1 SEE ALSO + +The following modules or resources may be of interest. + +L, L + +=head1 AUTHOR + +John Napiorkowski, C<< >> + +=head1 COPYRIGHT & LICENSE + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +__PACKAGE__->meta->make_immutable; \ No newline at end of file diff --git a/lib/MooseX/Meta/TypeConstraint/Dependent.pm b/lib/MooseX/Meta/TypeConstraint/Dependent.pm new file mode 100644 index 0000000..01853fe --- /dev/null +++ b/lib/MooseX/Meta/TypeConstraint/Dependent.pm @@ -0,0 +1,296 @@ +package ## Hide from PAUSE + MooseX::Meta::TypeConstraint::Dependent; + +use Moose; +use Moose::Util::TypeConstraints (); +use MooseX::Meta::TypeCoercion::Dependent; +extends 'Moose::Meta::TypeConstraint'; + +=head1 NAME + +MooseX::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints. + +=head1 DESCRIPTION + +see L for examples and details of how to use dependent +types. This class is a subclass of L which +provides the gut functionality to enable dependent type constraints. + +=head1 ATTRIBUTES + +This class defines the following attributes. + +=head2 dependent_type_constraint + +The type constraint whose validity is being made dependent on a value that is a +L + +=cut + +has 'dependent_type_constraint' => ( + is=>'ro', + predicate=>'has_dependent_type_constraint', +); + +=head2 constraining_type_constraint + +This is a type constraint which defines what kind of value is allowed to be the +constraining value of the depending type. + +=cut + +has 'constraining_type_constraint' => ( + is=>'ro', + predicate=>'has_constraining_type_constraint', +); + +=head2 comparision_callback + +This is a callback which returns a boolean value. It get's passed the value +L validates as well as the check value. + +This callback is executed in addition to anything you put into a 'where' clause. +However, the 'where' clause only get's the check value. + +Exercise some sanity, this should be limited to actual comparision operations, +not as a sneaky way to mess with the constraining value. + +=cut + +has 'comparision_callback' => ( + is=>'ro', + isa=>'CodeRef', + predicate=>'has_comparision_callback', +); + +=head2 constraint_generator + +A subref or closure that contains the way we validate incoming values against +a set of type constraints. + +=cut + +has 'constraint_generator' => ( + is=>'ro', + isa=>'CodeRef', + predicate=>'has_constraint_generator', +); + +=head1 METHODS + +This class defines the following methods. + +=head2 new + +Initialization stuff. + +=cut + +around 'new' => sub { + my ($new, $class, @args) = @_; + my $self = $class->$new(@args); + $self->coercion(MooseX::Meta::TypeCoercion::Structured->new( + type_constraint => $self, + )); + return $self; +}; + +=head2 generate_constraint_for ($type_constraints) + +Given some type constraints, use them to generate validation rules for an ref +of values (to be passed at check time) + +=cut + +sub generate_constraint_for { + my ($self, $dependent, $callback, $constraining) = @_; + return sub { + my (@args) = @_; + my $constraint_generator = $self->constraint_generator; + return $constraint_generator->($dependent, $callback, $constraining, @args); + }; +} + +=head2 parameterize (@type_constraints) + +Given a ref of type constraints, create a structured type. + +=cut + +sub parameterize { + + my ($self, $dependent, $callback, $constraining) = @_; + my $class = ref $self; + my $name = $self->_generate_subtype_name($dependent, $constraining); + my $constraint_generator = $self->__infer_constraint_generator; + + return $class->new( + name => $name, + parent => $self, + dependent_type_constraint=>$dependent, + comparision_callback=>$callback, + constraint_generator => $constraint_generator, + ); +} + +=head2 _generate_subtype_name + +Returns a name for the dependent type that should be unique + +=cut + +sub _generate_subtype_name { + my ($self, $dependent, $constraining) = @_; + return sprintf( + "%s_depends_on_%s", + $dependent, $constraining + ); +} + +=head2 __infer_constraint_generator + +This returns a CODEREF which generates a suitable constraint generator. Not +user servicable, you'll never call this directly. + + TBD, this is definitely going to need some work. + +=cut + +sub __infer_constraint_generator { + my ($self) = @_; + if($self->has_constraint_generator) { + return $self->constraint_generator; + } else { + return sub { + ## I'm not sure about this stuff but everything seems to work + my $tc = shift @_; + my $merged_tc = [ + @$tc, + $self->dependent_type_constraint, + $self->comparision_callback, + $self->constraining_type_constraint, + ]; + + $self->constraint->($merged_tc, @_); + }; + } +} + +=head2 compile_type_constraint + +hook into compile_type_constraint so we can set the correct validation rules. + +=cut + +around 'compile_type_constraint' => sub { + my ($compile_type_constraint, $self, @args) = @_; + + if($self->has_type_constraints) { + my $type_constraints = $self->type_constraints; + my $constraint = $self->generate_constraint_for($type_constraints); + $self->_set_constraint($constraint); + } + + return $self->$compile_type_constraint(@args); +}; + +=head2 create_child_type + +modifier to make sure we get the constraint_generator + +=cut + +around 'create_child_type' => sub { + my ($create_child_type, $self, %opts) = @_; + return $self->$create_child_type( + %opts, + constraint_generator => $self->__infer_constraint_generator, + ); +}; + +=head2 is_a_type_of + +=head2 is_subtype_of + +=head2 equals + +Override the base class behavior. + + TBD + +sub equals { + my ( $self, $type_or_name ) = @_; + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless $other->isa(__PACKAGE__); + + return ( + $self->type_constraints_equals($other) + and + $self->parent->equals( $other->parent ) + ); +} + +=head2 type_constraints_equals + +Checks to see if the internal type contraints are equal. + + TBD + +sub type_constraints_equals { + my ($self, $other) = @_; + my @self_type_constraints = @{$self->type_constraints||[]}; + my @other_type_constraints = @{$other->type_constraints||[]}; + + ## Incoming ay be either arrayref or hashref, need top compare both + while(@self_type_constraints) { + my $self_type_constraint = shift @self_type_constraints; + my $other_type_constraint = shift @other_type_constraints + || return; ## $other needs the same number of children. + + if( ref $self_type_constraint) { + $self_type_constraint->equals($other_type_constraint) + || return; ## type constraints obviously need top be equal + } else { + $self_type_constraint eq $other_type_constraint + || return; ## strings should be equal + } + + } + + return 1; ##If we get this far, everything is good. +} + +=head2 get_message + +Give you a better peek into what's causing the error. For now we stringify the +incoming deep value with L and pass that on to either your +custom error message or the default one. In the future we'll try to provide a +more complete stack trace of the actual offending elements + + TBD + +around 'get_message' => sub { + my ($get_message, $self, $value) = @_; + my $new_value = Devel::PartialDump::dump($value); + return $self->$get_message($new_value); +}; + +=head1 SEE ALSO + +The following modules or resources may be of interest. + +L, L + +=head1 AUTHOR + +John Napiorkowski, C<< >> + +=head1 COPYRIGHT & LICENSE + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +__PACKAGE__->meta->make_immutable; \ No newline at end of file diff --git a/lib/MooseX/Types/Dependent.pm b/lib/MooseX/Types/Dependent.pm index ea27fba..b4f10ef 100644 --- a/lib/MooseX/Types/Dependent.pm +++ b/lib/MooseX/Types/Dependent.pm @@ -1,206 +1,169 @@ package MooseX::Types::Dependent; -use strict; -use warnings; - - -#use Carp::Clan qw( ^MooseX::Types ); -use Moose::Util::TypeConstraints (); -use Scalar::Util qw(blessed); - -use overload( - '""' => sub { - my $self = shift @_; - if(blessed $self) { - return $self->__internal_type_constraint->name; - } else { - return "$self"; - } - }, - fallback => 1, -); +use 5.008; + +use Moose::Util::TypeConstraints; +use MooseX::Meta::TypeConstraint::Dependent; +use MooseX::Types -declare => [qw(Depending)]; + +our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:JJNAPIORK'; =head1 NAME -MooseX::Types::Dependent - Type Constraints that are dependent on others +MooseX::Types::Dependent - L constraints that depend on values. =head1 SYNOPSIS - use MooseX::Types::Dependent; - - ## Assuming the type constraint 'Set' isa Set::Scalar - - subtype UniqueInt, - as Dependent[Int,Set], - where { - ## ok Set->check($set), 'Good $set'; - ## ok Int->check($val), 'Already an Int' - my ($set, $val) = @_; - ## If the $set already has $val, then it's not unique - return $set->has($val) ? 0:1 - }; - - my $set = Set::Scalar->new(1..10); - - ok UniqueInt->check([1, $set]); ## Fails, 1 is already in $set; - ok UniqueInt->check(['a', $set]); ## Fails, 'a' is not an Int; - ok UniqueInt->check([1, $obj]); ## Fails, $obj is not a Set; - ok UniqueInt->check([20, $set]); ## PASSES + TDB: Syntax to be determined. Canonical is: + + subtype UniqueInt, + as Depending[ + Int, + sub { + shift->not_exists(shift); + }, + Set, + ]; + + possible sugar options + + Depending + as Depending sub :Set {} Int; + depending(Set $set) { $set->exists($Int) } Int; + + May have some ready to go, such as + as isGreaterThan[ + Int, + Int, + ]; + + as isMemberOf[ + Int + Set, + ] + + ## using object for comparison + + as Dependent[Int, CompareCmd, Int]; + +Please see the test cases for more examples. + +=head1 DEFINITIONS + +The following is a list of terms used in this documentation. + +=head2 Dependent Type Constraint + +=head2 Check Value + +=head2 Constraining Type Constraint + +=head2 Constraining Value =head1 DESCRIPTION -This is a decorator object that contains an underlying type constraint. We use -this to control access to the type constraint and to add some features. - -=head1 METHODS +A dependent type is a type constraint whose validity is dependent on a second +value. You defined the dependent type constraint with a primary type constraint +(such as 'Int') a 'constraining' value type constraint (such as a Set object) +and a coderef which will compare the incoming value to be checked with a value +that conforms to the constraining type constraint. Typically there should be a +comparision operator between the check value and the constraining value -This class defines the following methods. +=head2 Subtyping a Dependent type constraints -=head2 new + TDB: Need discussion and examples. -Old school instantiation +=head2 Coercions -=cut + TBD: Need discussion and example of coercions working for both the + constrainted and dependent type constraint. -sub new { - my $class = shift @_; - my $attributes = {}; - if(my $ - if(my $arg = shift @_) { - if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) { - return bless {'__type_constraint'=>$arg}, $class; - } elsif( - blessed $arg && - $arg->isa('MooseX::Types::UndefinedType') - ) { - ## stub in case we'll need to handle these types differently - return bless {'__type_constraint'=>$arg}, $class; - } elsif(blessed $arg) { - croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg; - } else { - croak "Argument cannot be '$arg'"; - } - } else { - croak "This method [new] requires a single argument."; - } -} - -=head2 __internal_type_constraint ($type_constraint) - -Set/Get the type_constraint we are making dependent. +=head2 Recursion -=cut +Newer versions of L support recursive type constraints. That is +you can include a type constraint as a contained type constraint of itself. +Recursion is support in both the dependent and constraining type constraint. For +example: -sub __internal_type_constraint { - my $self = shift @_; - if(blessed $self) { - if(defined(my $tc = shift @_)) { - $self->{__type_constraint} = $tc; - } - return $self->{__type_constraint}; - } else { - croak 'cannot call __internal_type_constraint as a class method'; - } -} + TBD -=head2 isa +=head1 TYPE CONSTRAINTS -handle $self->isa since AUTOLOAD can't. +This type library defines the following constraints. -=cut +=head2 Depending[$dependent_tc, $codref, $constraining_tc] -sub isa { - my ($self, $target) = @_; - if(defined $target) { - if(blessed $self) { - return $self->__internal_type_constraint->isa($target); - } else { - return; - } - } else { - return; - } -} +Create a subtype of $dependent_tc that is constrainted by a value that is a +valid $constraining_tc using $coderef. For example; -=head2 can + subtype GreaterThanInt, + as Depending[ + Int, + sub { + my($constraining_value, $check_value) = @_; + return $constraining_value > $check_value ? 1:0; + }, + Int, + ]; -handle $self->can since AUTOLOAD can't. +This would create a type constraint that takes an integer and checks it against +a second integer, requiring that the check value is greater. For example: -=cut + GreaterThanInt->check(5,10); ## Fails, 5 is less than 10 + GreaterThanInt->check('a',10); ## Fails, 'a' is not an Int. + GreaterThanInt->check(5,'b'); ## Fails, 'b' is not an Int either. + GreaterThanInt->check(10,5); ## Success, 10 is greater than 5. -sub can { - my ($self, $target) = @_; - if(defined $target) { - if(blessed $self) { - return $self->__internal_type_constraint->can($target); - } else { - return; - } - } else { - return; - } -} +=head1 EXAMPLES -=head2 meta +Here are some additional example usage for structured types. All examples can +be found also in the 't/examples.t' test. Your contributions are also welcomed. -have meta examine the underlying type constraints + TBD =cut -sub meta { - my $self = shift @_; - if(blessed $self) { - return $self->__internal_type_constraint->meta; - } -} +Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( + MooseX::Meta::TypeConstraint::Dependent->new( + name => "MooseX::Types::Dependent::Depending" , + parent => find_type_constraint('ArrayRef'), + constraint_generator=> sub { + my ($callback, $constraining_value, $check_value) = @_; + return $callback->($constraining_value, $check_value) ? 1:0; + }, + ) +); + +=head1 SEE ALSO +The following modules or resources may be of interest. -=head2 DESTROY +L, L, L, +L -We might need it later +=head1 TODO -=cut +Here's a list of stuff I would be happy to get volunteers helping with: -sub DESTROY { - return; -} +=over 4 -=head2 AUTOLOAD +=item Examples -Delegate to the decorator targe +Examples of useful code with both POD and ideally a test case to show it +working. -=cut +=back + +=head1 AUTHOR -sub AUTOLOAD { - - my ($self, @args) = @_; - my ($method) = (our $AUTOLOAD =~ /([^:]+)$/); - - ## We delegate with this method in an attempt to support a value of - ## __type_constraint which is also AUTOLOADing, in particular the class - ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication. - - my $return; - - eval { - $return = $self->__internal_type_constraint->$method(@args); - }; if($@) { - croak $@; - } else { - return $return; - } -} - -=head1 AUTHOR AND COPYRIGHT - -John Napiorkowski (jnapiorkowski) - -=head1 LICENSE +John Napiorkowski, C<< >> + +=head1 COPYRIGHT & LICENSE This program is free software; you can redistribute it and/or modify -it under the same terms as perl itself. +it under the same terms as Perl itself. =cut - + 1; - diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..062b92b --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,12 @@ + +use Test::More tests=>3; { + + use strict; + use warnings; + + ## List all the modules we want to make sure can at least compile + use_ok 'MooseX::Types::Dependent'; + use_ok 'MooseX::Meta::TypeConstraint::Dependent'; + use_ok 'MooseX::Meta::TypeCoercion::Dependent'; +} + diff --git a/t/01-basic.t b/t/01-basic.t index 3327e2a..136928b 100644 --- a/t/01-basic.t +++ b/t/01-basic.t @@ -1,35 +1,38 @@ -use Test::More tests=>5; -use MooseX::Types::Structured qw(Tuple slurpy); -use MooseX::Types qw(Str Object); -use_ok 'MooseX::Meta::TypeConstraint::Structured'; -use_ok 'Moose::Util::TypeConstraints'; - -ok my $int = find_type_constraint('Int') => 'Got Int'; -ok my $str = find_type_constraint('Str') => 'Got Str'; -ok my $obj = find_type_constraint('Object') => 'Got Object'; -ok my $arrayref = find_type_constraint('ArrayRef') => 'Got ArrayRef'; - -my $a = [1,2,3,4]; - - -package Dependent; - -use overload( - '&{}' => sub { - warn 'sdfsdfsdfsdfsdf'; - return sub {}; - }, -); - -sub new { - my $class = shift @_; - return bless {a=>1}, $class; +use Test::More tests=>8; { + + use strict; + use warnings; + + use_ok 'MooseX::Meta::TypeConstraint::Dependent'; + use_ok 'Moose::Util::TypeConstraints'; + + ## A sample dependent type constraint the requires two ints and see which + ## is the greater. + + ok my $int = find_type_constraint('Int') => 'Got Int'; + + my $dep_tc = MooseX::Meta::TypeConstraint::Dependent->new( + name => "MooseX::Types::Dependent::Depending" , + parent => find_type_constraint('ArrayRef'), + dependent_type_constraint=>$int, + comparision_callback=>sub { + my ($constraining_value, $check_value) = @_; + return $constraining_value > $check_value ? 0:1; + }, + constraint_generator =>$int, + constraint_generator=> sub { + my ($callback, $constraining_value, $check_value) = @_; + return $callback->($constraining_value, $check_value) ? 1:0; + }, + ); + + ## Does this work at all? + + isa_ok $dep_tc, 'MooseX::Meta::TypeConstraint::Dependent'; + + ok !$dep_tc->check([5,10]), "Fails, 5 is less than 10"; + ok !$dep_tc->check(['a',10]), "Fails, 'a' is not an Int."; + ok !$dep_tc->check([5,'b']), "Fails, 'b' is not an Int either."; + ok $dep_tc->check([10,5]), "Success, 10 is greater than 5."; } - -1; - -my $dependent = Dependent->new($int); - -$dependent->(); -