summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJesse Luehrs <doy@tozt.net>2012-10-09 20:52:44 -0500
committerJesse Luehrs <doy@tozt.net>2012-10-09 21:11:49 -0500
commitbb2bf61723962222952d2f68da497f8391dc6a5e (patch)
tree8b7f1eaba5805b31eb5b13523521896d9063acef
parent187562dd74bec5692831c08e8d8edf54f91ce031 (diff)
downloadmoosex-validation-doctypes-bb2bf61723962222952d2f68da497f8391dc6a5e.tar.gz
moosex-validation-doctypes-bb2bf61723962222952d2f68da497f8391dc6a5e.zip
initial implementation
-rw-r--r--lib/MooseX/Meta/TypeConstraint/Doctype.pm133
-rw-r--r--lib/MooseX/Validation/Doctypes.pm35
-rw-r--r--lib/MooseX/Validation/Doctypes/Errors.pm17
-rw-r--r--t/basic.t98
-rw-r--r--t/complex.t191
5 files changed, 474 insertions, 0 deletions
diff --git a/lib/MooseX/Meta/TypeConstraint/Doctype.pm b/lib/MooseX/Meta/TypeConstraint/Doctype.pm
new file mode 100644
index 0000000..0d333cc
--- /dev/null
+++ b/lib/MooseX/Meta/TypeConstraint/Doctype.pm
@@ -0,0 +1,133 @@
+package MooseX::Meta::TypeConstraint::Doctype;
+use Moose;
+
+use Devel::PartialDump 'dump';
+use Moose::Util::TypeConstraints qw(class_type find_type_constraint
+ match_on_type);
+use Scalar::Util 'weaken';
+
+use MooseX::Validation::Doctypes::Errors;
+
+extends 'Moose::Meta::TypeConstraint';
+
+class_type('Moose::Meta::TypeConstraint');
+
+has doctype => (
+ is => 'ro',
+ isa => 'Ref',
+ required => 1,
+);
+
+has '+parent' => (
+ default => sub { find_type_constraint('Ref') },
+);
+
+has '+constraint' => (
+ lazy => 1,
+ default => sub {
+ weaken(my $self = shift);
+ return sub { !$self->validate_doctype($_) };
+ },
+);
+
+has '+message' => (
+ default => sub {
+ weaken(my $self = shift);
+ return sub { $self->validate_doctype($_) };
+ },
+);
+
+sub validate_doctype {
+ my $self = shift;
+ my ($data, $doctype, $prefix) = @_;
+
+ $doctype = $self->doctype
+ unless defined $doctype;
+ $prefix = ''
+ unless defined $prefix;
+
+ my ($errors, $extra_data);
+
+ match_on_type $doctype => (
+ 'HashRef' => sub {
+ if (!find_type_constraint('HashRef')->check($data)) {
+ $errors = $data;
+ }
+ else {
+ for my $key (keys %$doctype) {
+ my $sub_errors = $self->validate_doctype(
+ $data->{$key},
+ $doctype->{$key},
+ join('.', (length($prefix) ? $prefix : ()), $key)
+ );
+ if ($sub_errors) {
+ if ($sub_errors->has_errors) {
+ $errors ||= {};
+ $errors->{$key} = $sub_errors->errors;
+ }
+ if ($sub_errors->has_extra_data) {
+ $extra_data ||= {};
+ $extra_data->{$key} = $sub_errors->extra_data;
+ }
+ }
+ }
+ for my $key (keys %$data) {
+ if (!exists $doctype->{$key}) {
+ $extra_data ||= {};
+ $extra_data->{$key} = $data->{$key};
+ }
+ }
+ }
+ },
+ 'ArrayRef' => sub {
+ if (!find_type_constraint('ArrayRef')->check($data)) {
+ $errors = $data;
+ }
+ else {
+ for my $i (0..$#$doctype) {
+ my $sub_errors = $self->validate_doctype(
+ $data->[$i],
+ $doctype->[$i],
+ join('.', (length($prefix) ? $prefix : ()), "[$i]")
+ );
+ if ($sub_errors) {
+ if ($sub_errors->has_errors) {
+ $errors ||= [];
+ $errors->[$i] = $sub_errors->errors;
+ }
+ if ($sub_errors->has_extra_data) {
+ $extra_data ||= [];
+ $extra_data->[$i] = $sub_errors->extra_data;
+ }
+ }
+ }
+ for my $i (0..$#$data) {
+ next if $i < @$doctype;
+ $extra_data ||= [];
+ $extra_data->[$i] = $data->[$i];
+ }
+ }
+ },
+ 'Str|Moose::Meta::TypeConstraint' => sub {
+ my $tc = Moose::Util::TypeConstraints::find_or_parse_type_constraint($doctype);
+ die "Unknown type $doctype" unless $tc;
+ if (!$tc->check($data)) {
+ $errors = "invalid value " . dump($data) . " for '$prefix'";
+ }
+ },
+ => sub {
+ die "Unknown doctype at position '$prefix': " . dump($doctype);
+ },
+ );
+
+ return unless $errors || $extra_data;
+
+ return MooseX::Validation::Doctypes::Errors->new(
+ ($errors ? (errors => $errors) : ()),
+ ($extra_data ? (extra_data => $extra_data) : ()),
+ );
+}
+
+no Moose;
+
+1;
diff --git a/lib/MooseX/Validation/Doctypes.pm b/lib/MooseX/Validation/Doctypes.pm
index e69de29..668c4f0 100644
--- a/lib/MooseX/Validation/Doctypes.pm
+++ b/lib/MooseX/Validation/Doctypes.pm
@@ -0,0 +1,35 @@
+package MooseX::Validation::Doctypes;
+use strict;
+use warnings;
+
+use MooseX::Meta::TypeConstraint::Doctype;
+
+use Sub::Exporter -setup => {
+ exports => ['doctype'],
+ groups => {
+ default => ['doctype'],
+ },
+};
+
+sub doctype {
+ my $name;
+ $name = shift if @_ > 1;
+
+ my ($doctype) = @_;
+
+ # XXX validate name
+
+ my $args = {
+ ($name ? (name => $name) : ()),
+ doctype => $doctype,
+ package_defined_in => scalar(caller),
+ };
+
+ my $tc = MooseX::Meta::TypeConstraint::Doctype->new($args);
+ Moose::Util::TypeConstraints::register_type_constraint($tc)
+ if $name;
+
+ return $tc;
+}
+
+1;
diff --git a/lib/MooseX/Validation/Doctypes/Errors.pm b/lib/MooseX/Validation/Doctypes/Errors.pm
new file mode 100644
index 0000000..d510670
--- /dev/null
+++ b/lib/MooseX/Validation/Doctypes/Errors.pm
@@ -0,0 +1,17 @@
+package MooseX::Validation::Doctypes::Errors;
+use Moose;
+
+has errors => (
+ is => 'ro',
+ predicate => 'has_errors',
+);
+
+has extra_data => (
+ is => 'ro',
+ predicate => 'has_extra_data',
+);
+
+__PACKAGE__->meta->make_immutable;
+no Moose;
+
+1;
diff --git a/t/basic.t b/t/basic.t
new file mode 100644
index 0000000..02c77c1
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,98 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Moose::Util::TypeConstraints 'find_type_constraint';
+
+use MooseX::Validation::Doctypes;
+
+doctype 'Person' => {
+ id => 'Str',
+ name => 'Str',
+ title => 'Str',
+};
+
+doctype 'Location' => {
+ id => 'Str',
+ city => 'Str',
+ state => 'Str',
+ country => 'Str',
+ zipcode => 'Int',
+};
+
+{
+ my $person = find_type_constraint('Person');
+ isa_ok($person, 'Moose::Meta::TypeConstraint');
+ isa_ok($person, 'MooseX::Meta::TypeConstraint::Doctype');
+
+ is_deeply(
+ $person->doctype,
+ { id => 'Str', name => 'Str', title => 'Str' },
+ "got the right doctype"
+ );
+
+ {
+ my $errors = $person->validate({
+ id => '17382-QA',
+ name => 'Bob',
+ title => 'CIO'
+ });
+ is($errors, undef, "no errors");
+ }
+
+ {
+ my $errors = $person->validate({
+ id => '17382-QA',
+ name => 'Bob',
+ title => 'CIO',
+ favorite_food => 'ice cream',
+ });
+ isa_ok($errors, 'MooseX::Validation::Doctypes::Errors');
+ is_deeply(
+ $errors->extra_data,
+ { favorite_food => 'ice cream' },
+ "got the right extra data"
+ );
+ is($errors->errors, undef, "no errors");
+ }
+
+ {
+ my $errors = $person->validate({
+ id => '17382-QA',
+ name => 'Bob',
+ });
+ isa_ok($errors, 'MooseX::Validation::Doctypes::Errors');
+ is($errors->extra_data, undef, "no extra data");
+ is_deeply(
+ $errors->errors,
+ { title => "invalid value undef for 'title'" },
+ "got the right errors"
+ );
+ }
+}
+
+{
+ my $location = find_type_constraint('Location');
+ isa_ok($location, 'Moose::Meta::TypeConstraint');
+ isa_ok($location, 'MooseX::Meta::TypeConstraint::Doctype');
+
+ {
+ my $errors = $location->validate({
+ id => 'My House',
+ city => 'Anytown',
+ state => 'IL',
+ country => 'USA',
+ zipcode => 'ABCDEF'
+ });
+ isa_ok($errors, 'MooseX::Validation::Doctypes::Errors');
+ is($errors->extra_data, undef, "no extra data");
+ is_deeply(
+ $errors->errors,
+ { zipcode => "invalid value \"ABCDEF\" for 'zipcode'" },
+ "got the right errors"
+ );
+ }
+}
+
+done_testing;
diff --git a/t/complex.t b/t/complex.t
new file mode 100644
index 0000000..b617cab
--- /dev/null
+++ b/t/complex.t
@@ -0,0 +1,191 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Test::Requires 'MooseX::Types::URI', 'MooseX::Types::Email',
+ 'Locale::Language', 'Locale::Currency',
+ 'Number::Phone::US';
+
+use Moose::Util::TypeConstraints;
+use MooseX::Types::URI 'Uri';
+use MooseX::Types::Email 'EmailAddress';
+
+use MooseX::Validation::Doctypes;
+
+subtype 'CurrencyCode',
+ as 'Str',
+ where { Locale::Currency::code2currency( $_ ) };
+subtype 'LocaleCode',
+ as 'Str',
+ where { Locale::Language::code2language( $_ ) };
+subtype 'PhoneNumber',
+ as 'Str',
+ where { Number::Phone::US::is_valid_number( $_ ) };
+
+doctype 'Location' => {
+ id => 'Str',
+ name => 'Str',
+ location => {
+ address => {
+ address1 => 'Str',
+ city => 'Str',
+ country => 'Str',
+ postal_code => 'Str',
+ address2 => 'Maybe[Str]',
+ address3 => 'Maybe[Str]',
+ address4 => 'Maybe[Str]',
+ address5 => 'Maybe[Str]',
+ state => 'Maybe[Str]',
+ },
+ coordinates => {
+ lon => 'Num',
+ lat => 'Num',
+ }
+ },
+ contact => {
+ phone => 'PhoneNumber',
+ fax => 'Maybe[PhoneNumber]',
+ support => 'Maybe[PhoneNumber | MooseX::Types::URI::Uri | MooseX::Types::Email::EmailAddress]',
+ web => 'Maybe[MooseX::Types::URI::Uri]',
+ email => 'Maybe[MooseX::Types::Email::EmailAddress]',
+ },
+ i18n => {
+ default_currency => 'CurrencyCode',
+ default_locale => 'LocaleCode',
+ available_currencies => 'ArrayRef[CurrencyCode]',
+ available_locales => 'ArrayRef[LocaleCode]',
+ }
+};
+
+{
+ my $location = find_type_constraint('Location');
+ is_deeply(
+ $location->doctype,
+ {
+ id => 'Str',
+ name => 'Str',
+ location => {
+ address => {
+ address1 => 'Str',
+ city => 'Str',
+ country => 'Str',
+ postal_code => 'Str',
+ address2 => 'Maybe[Str]',
+ address3 => 'Maybe[Str]',
+ address4 => 'Maybe[Str]',
+ address5 => 'Maybe[Str]',
+ state => 'Maybe[Str]',
+ },
+ coordinates => {
+ lon => 'Num',
+ lat => 'Num',
+ }
+ },
+ contact => {
+ phone => 'PhoneNumber',
+ fax => 'Maybe[PhoneNumber]',
+ support => 'Maybe[PhoneNumber | MooseX::Types::URI::Uri | MooseX::Types::Email::EmailAddress]',
+ web => 'Maybe[MooseX::Types::URI::Uri]',
+ email => 'Maybe[MooseX::Types::Email::EmailAddress]',
+ },
+ i18n => {
+ default_currency => 'CurrencyCode',
+ default_locale => 'LocaleCode',
+ available_currencies => 'ArrayRef[CurrencyCode]',
+ available_locales => 'ArrayRef[LocaleCode]',
+ }
+ },
+ "got the right doctype"
+ );
+
+ {
+ my $errors = $location->validate({
+ id => '14931-FL-53',
+ name => 'My House',
+ location => {
+ address => {
+ address1 => '123 Any St',
+ city => 'Anytown',
+ country => 'USA',
+ postal_code => '00100',
+ address2 => 'Apt Q',
+ address5 => 'knock on the back door',
+ state => 'IL',
+ },
+ coordinates => {
+ lon => '38',
+ lat => '57',
+ }
+ },
+ contact => {
+ phone => '867-5309',
+ support => 'anelson@cpan.org',
+ web => URI->new('https://metacpan.org/author/ANELSON'),
+ email => 'anelson@cpan.org',
+ },
+ i18n => {
+ default_currency => 'USD',
+ default_locale => 'en',
+ available_currencies => [ 'USD', 'CAD', 'EUR' ],
+ available_locales => [ 'en' ]
+ }
+ });
+ is($errors, undef, "no errors");
+ }
+
+ {
+ my $errors = $location->validate({
+ id => '14931-FL-53',
+ name => 'My House',
+ location => {
+ address => {
+ address1 => '123 Any St',
+ city => 'Anytown',
+ country => 'USA',
+ postal_code => '00100',
+ address2 => 'Apt Q',
+ address5 => 'knock on the back door',
+ state => 'IL',
+ },
+ coordinates => {
+ lon => '38q',
+ lat => '57',
+ }
+ },
+ contact => {
+ phone => '867-5309',
+ support => 'anelson@cpan.org',
+ web => URI->new('https://metacpan.org/author/ANELSON'),
+ email => 'anelson at cpan.org',
+ },
+ i18n => {
+ default_locale => 'en',
+ available_currencies => [ 'dolla dolla bill', 'CAD', 'EUR' ],
+ available_locales => [ 'en' ]
+ }
+ });
+ is_deeply(
+ $errors,
+ {
+ errors => {
+ contact => {
+ email => "invalid value \"anelson at cpan.org\" for 'contact.email'"
+ },
+ i18n => {
+ available_currencies => "invalid value [ \"dolla dolla bill\", \"CAD\", \"EUR\" ] for 'i18n.available_currencies'",
+ default_currency => "invalid value undef for 'i18n.default_currency'"
+ },
+ location => {
+ coordinates => {
+ lon => "invalid value \"38q\" for 'location.coordinates.lon'"
+ }
+ }
+ }
+ },
+ "got the right errors"
+ );
+ }
+}
+
+done_testing;