[Moose-commits] r7862 - in MooseX-Types-Dependent/trunk: .
lib/MooseX lib/MooseX/Meta lib/MooseX/Meta/TypeCoercion
lib/MooseX/Meta/TypeConstraint lib/MooseX/Types t
jnapiorkowski at code2.0beta.co.uk
jnapiorkowski at code2.0beta.co.uk
Fri Mar 27 21:44:24 GMT 2009
Author: jnapiorkowski
Date: 2009-03-27 14:44:24 -0700 (Fri, 27 Mar 2009)
New Revision: 7862
Added:
MooseX-Types-Dependent/trunk/Changes
MooseX-Types-Dependent/trunk/MANIFEST.SKIP
MooseX-Types-Dependent/trunk/Makefile.PL
MooseX-Types-Dependent/trunk/lib/MooseX/Meta/
MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeCoercion/
MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeCoercion/Dependent.pm
MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeConstraint/
MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeConstraint/Dependent.pm
MooseX-Types-Dependent/trunk/t/00-load.t
Modified:
MooseX-Types-Dependent/trunk/lib/MooseX/Types/Dependent.pm
MooseX-Types-Dependent/trunk/t/01-basic.t
Log:
got the basic tests in place, got the types organized how I want this to work. Still a lot of unknowns.
Added: MooseX-Types-Dependent/trunk/Changes
===================================================================
--- MooseX-Types-Dependent/trunk/Changes (rev 0)
+++ MooseX-Types-Dependent/trunk/Changes 2009-03-27 21:44:24 UTC (rev 7862)
@@ -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.
Added: MooseX-Types-Dependent/trunk/MANIFEST.SKIP
===================================================================
--- MooseX-Types-Dependent/trunk/MANIFEST.SKIP (rev 0)
+++ MooseX-Types-Dependent/trunk/MANIFEST.SKIP 2009-03-27 21:44:24 UTC (rev 7862)
@@ -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
Added: MooseX-Types-Dependent/trunk/Makefile.PL
===================================================================
--- MooseX-Types-Dependent/trunk/Makefile.PL (rev 0)
+++ MooseX-Types-Dependent/trunk/Makefile.PL 2009-03-27 21:44:24 UTC (rev 7862)
@@ -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 <jjnapiork at 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;
Added: MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeCoercion/Dependent.pm
===================================================================
--- MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeCoercion/Dependent.pm (rev 0)
+++ MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeCoercion/Dependent.pm 2009-03-27 21:44:24 UTC (rev 7862)
@@ -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<Moose>, L<Moose::Meta::TypeCoercion>
+
+=head1 AUTHOR
+
+John Napiorkowski, C<< <jjnapiork at 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
Added: MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeConstraint/Dependent.pm
===================================================================
--- MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeConstraint/Dependent.pm (rev 0)
+++ MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeConstraint/Dependent.pm 2009-03-27 21:44:24 UTC (rev 7862)
@@ -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<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 at 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
Modified: MooseX-Types-Dependent/trunk/lib/MooseX/Types/Dependent.pm
===================================================================
--- MooseX-Types-Dependent/trunk/lib/MooseX/Types/Dependent.pm 2009-03-27 17:57:06 UTC (rev 7861)
+++ MooseX-Types-Dependent/trunk/lib/MooseX/Types/Dependent.pm 2009-03-27 21:44:24 UTC (rev 7862)
@@ -1,206 +1,169 @@
package MooseX::Types::Dependent;
-use strict;
-use warnings;
+use 5.008;
+use Moose::Util::TypeConstraints;
+use MooseX::Meta::TypeConstraint::Dependent;
+use MooseX::Types -declare => [qw(Depending)];
-#use Carp::Clan qw( ^MooseX::Types );
-use Moose::Util::TypeConstraints ();
-use Scalar::Util qw(blessed);
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:JJNAPIORK';
-use overload(
- '""' => sub {
- my $self = shift @_;
- if(blessed $self) {
- return $self->__internal_type_constraint->name;
- } else {
- return "$self";
- }
- },
- fallback => 1,
-);
-
=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
+ 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];
- 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
+Please see the test cases for more examples.
-=head1 DESCRIPTION
+=head1 DEFINITIONS
-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.
+The following is a list of terms used in this documentation.
-=head1 METHODS
+=head2 Dependent Type Constraint
-This class defines the following methods.
+=head2 Check Value
-=head2 new
+=head2 Constraining Type Constraint
-Old school instantiation
+=head2 Constraining Value
-=cut
+=head1 DESCRIPTION
-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.";
- }
-}
+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
-=head2 __internal_type_constraint ($type_constraint)
+=head2 Subtyping a Dependent type constraints
-Set/Get the type_constraint we are making dependent.
+ TDB: Need discussion and examples.
-=cut
+=head2 Coercions
-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: Need discussion and example of coercions working for both the
+ constrainted and dependent type constraint.
-=head2 isa
+=head2 Recursion
-handle $self->isa since AUTOLOAD can't.
+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:
-=cut
+ TBD
-sub isa {
- my ($self, $target) = @_;
- if(defined $target) {
- if(blessed $self) {
- return $self->__internal_type_constraint->isa($target);
- } else {
- return;
- }
- } else {
- return;
- }
-}
+=head1 TYPE CONSTRAINTS
-=head2 can
+This type library defines the following constraints.
-handle $self->can since AUTOLOAD can't.
+=head2 Depending[$dependent_tc, $codref, $constraining_tc]
-=cut
+Create a subtype of $dependent_tc that is constrainted by a value that is a
+valid $constraining_tc using $coderef. For example;
-sub can {
- my ($self, $target) = @_;
- if(defined $target) {
- if(blessed $self) {
- return $self->__internal_type_constraint->can($target);
- } else {
- return;
- }
- } else {
- return;
- }
-}
+ subtype GreaterThanInt,
+ as Depending[
+ Int,
+ sub {
+ my($constraining_value, $check_value) = @_;
+ return $constraining_value > $check_value ? 1:0;
+ },
+ Int,
+ ];
-=head2 meta
+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:
-have meta examine the underlying type constraints
+ 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.
-=cut
+=head1 EXAMPLES
-sub meta {
- my $self = shift @_;
- if(blessed $self) {
- return $self->__internal_type_constraint->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.
+ TBD
-=head2 DESTROY
+=cut
-We might need it later
+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
-=cut
+The following modules or resources may be of interest.
-sub DESTROY {
- return;
-}
+L<Moose>, L<MooseX::Types>, L<Moose::Meta::TypeConstraint>,
+L<MooseX::Meta::TypeConstraint::Dependent>
-=head2 AUTOLOAD
+=head1 TODO
-Delegate to the decorator targe
+Here's a list of stuff I would be happy to get volunteers helping with:
-=cut
+=over 4
-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;
- }
-}
+=item Examples
-=head1 AUTHOR AND COPYRIGHT
+Examples of useful code with both POD and ideally a test case to show it
+working.
-John Napiorkowski (jnapiorkowski) <jjnapiork at cpan.org>
+=back
-=head1 LICENSE
+=head1 AUTHOR
+John Napiorkowski, C<< <jjnapiork at 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;
-
Added: MooseX-Types-Dependent/trunk/t/00-load.t
===================================================================
--- MooseX-Types-Dependent/trunk/t/00-load.t (rev 0)
+++ MooseX-Types-Dependent/trunk/t/00-load.t 2009-03-27 21:44:24 UTC (rev 7862)
@@ -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';
+}
+
Modified: MooseX-Types-Dependent/trunk/t/01-basic.t
===================================================================
--- MooseX-Types-Dependent/trunk/t/01-basic.t 2009-03-27 17:57:06 UTC (rev 7861)
+++ MooseX-Types-Dependent/trunk/t/01-basic.t 2009-03-27 21:44:24 UTC (rev 7862)
@@ -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';
+use Test::More tests=>8; {
+
+ use strict;
+ use warnings;
+
+ use_ok 'MooseX::Meta::TypeConstraint::Dependent';
+ 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';
+ ## 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?
-my $a = [1,2,3,4];
+ isa_ok $dep_tc, 'MooseX::Meta::TypeConstraint::Dependent';
-
-package Dependent;
-
-use overload(
- '&{}' => sub {
- warn 'sdfsdfsdfsdfsdf';
- return sub {};
- },
-);
-
-sub new {
- my $class = shift @_;
- return bless {a=>1}, $class;
+ 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->();
-
More information about the Moose-commits
mailing list