From bb2bf61723962222952d2f68da497f8391dc6a5e Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Tue, 9 Oct 2012 20:52:44 -0500 Subject: initial implementation --- lib/MooseX/Meta/TypeConstraint/Doctype.pm | 133 +++++++++++++++++++++ lib/MooseX/Validation/Doctypes.pm | 35 ++++++ lib/MooseX/Validation/Doctypes/Errors.pm | 17 +++ t/basic.t | 98 +++++++++++++++ t/complex.t | 191 ++++++++++++++++++++++++++++++ 5 files changed, 474 insertions(+) create mode 100644 lib/MooseX/Meta/TypeConstraint/Doctype.pm create mode 100644 lib/MooseX/Validation/Doctypes/Errors.pm create mode 100644 t/basic.t create mode 100644 t/complex.t 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; -- cgit v1.2.3