--- /dev/null
+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.
--- /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
+name 'MooseX-Types-Dependent';
+all_from 'lib/MooseX/Types/Dependent.pm';
+abstract 'Moose Type Constraint for creating Dependent Types Constraints';
+author 'John Napiorkowski <jjnapiork@cpan.org>';
+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;
--- /dev/null
+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<Moose>, L<Moose::Meta::TypeCoercion>
+
+=head1 AUTHOR
+
+John Napiorkowski, C<< <jjnapiork@cpan.org> >>
+
+=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
--- /dev/null
+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<MooseX::Types::Dependent> for examples and details of how to use dependent
+types. This class is a subclass of L<Moose::Meta::TypeConstraint> 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</constraining_type_constraint>
+
+=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</constraining_type_constraint> 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<Devel::PartialDump> 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<Moose>, L<Moose::Meta::TypeConstraint>
+
+=head1 AUTHOR
+
+John Napiorkowski, C<< <jjnapiork@cpan.org> >>
+
+=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
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<MooseX::Types> 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<MooseX::Types> 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<Moose>, L<MooseX::Types>, L<Moose::Meta::TypeConstraint>,
+L<MooseX::Meta::TypeConstraint::Dependent>
-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) <jjnapiork@cpan.org>
-
-=head1 LICENSE
+John Napiorkowski, C<< <jjnapiork@cpan.org> >>
+
+=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;
-
--- /dev/null
+
+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';
+}
+
-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->();
-
projects / gitmo/MooseX-Dependent.git / commitdiff