Permalink
Browse files

Validate resources.

  • Loading branch information...
1 parent a38590e commit 31de4d491f402ccf83ee245568af2c3c33722c4d @theory theory committed May 25, 2011
Showing with 168 additions and 4 deletions.
  1. +21 −4 lib/PGXN/Meta/Validator.pm
  2. +147 −0 t/validator.t
View
@@ -90,7 +90,7 @@ my %definitions = (
}
},
'name' => { mandatory => 1, value => \&term },
- 'release_status' => { mandatory => 1, value => \&release_status },
+ 'release_status' => { mandatory => 0, value => \&release_status },
'version' => { mandatory => 1, value => \&version },
'provides' => {
'mandatory' => 1,
@@ -120,15 +120,15 @@ my %definitions = (
bugtracker => {
'map' => {
web => { value => \&url },
- mailto => { value => \&string},
+ mailto => { value => \&email},
':key' => { name => \&custom, value => \&anything },
}
},
repository => {
'map' => {
web => { value => \&url },
url => { value => \&url },
- type => { value => \&string },
+ type => { value => \&lc_string },
':key' => { name => \&custom, value => \&anything },
}
},
@@ -455,6 +455,7 @@ sub _uri_split {
sub url {
my ($self,$key,$value) = @_;
if(defined $value) {
+ # XXX Consider using Data::Validate::URI.
my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
unless ( defined $scheme && length $scheme ) {
$self->_error( "'$value' for '$key' does not have a URL scheme" );
@@ -466,7 +467,7 @@ sub url {
}
return 1;
}
- $value ||= '';
+ $value = '<undef>' unless defined $value;
$self->_error( "'$value' for '$key' is not a valid URL." );
return 0;
}
@@ -484,6 +485,14 @@ sub urlspec {
return 0;
}
+sub email {
+ my ($self, $key, $value) = @_;
+ # XXX Consider using Email::Valid.
+ return 1 if defined $value && $value =~ /@/;
+ $self->_error( "'$value' for '$key' is not a valid email address" );
+ return 0;
+}
+
sub anything { return 1 }
sub string {
@@ -495,6 +504,14 @@ sub string {
return 0;
}
+sub lc_string {
+ my ($self, $key, $value) = @_;
+ $self->string($key, $value) or return 0;
+ return 1 if $value !~ /\p{XPosixUpper}/;
+ $self->_error( "'$value' is not a lowercase string" );
+ return 0;
+}
+
sub term {
shift->_string_class(@_, term => qr{[[:space:][:cntrl:]/\\]}, 2);
}
View
@@ -134,6 +134,78 @@ for my $spec (
'prereq version 0',
sub { shift->{prereqs}{runtime}{requires}{PostgreSQL} = 0 },
],
+ [
+ 'no release status',
+ sub { delete shift->{release_status} },
+ ],
+ (map {
+ my $rel = $_;
+ [
+ "release status $rel",
+ sub { shift->{release_status} = $rel },
+ ],
+ } qw(stable testing unstable)),
+ [
+ 'no resources',
+ sub { delete shift->{resources} },
+ ],
+ [
+ 'homepage resource',
+ sub { shift->{resources}{homepage} = 'http://foo.com' },
+ ],
+ [
+ 'bugtracker resource',
+ sub { shift->{resources}{bugtracker} = {
+ web => 'http://example.com/',
+ mailto => 'foo@bar.com',
+ } },
+ ],
+ [
+ 'bugtracker web',
+ sub { shift->{resources}{bugtracker} = {
+ web => 'http://example.com/',
+ } },
+ ],
+ [
+ 'bugtracker mailto',
+ sub { shift->{resources}{bugtracker} = {
+ mailto => 'foo@bar.com',
+ } },
+ ],
+ [
+ 'bugtracker custom',
+ sub { shift->{resources}{bugtracker} = {
+ x_foo => 'foo',
+ } },
+ ],
+ [
+ 'repository resource',
+ sub { shift->{resources}{repository} = {
+ web => 'http://example.com/',
+ url => 'git://example.com/',
+ type => 'git',
+ } },
+ ],
+ [
+ 'repository resource url',
+ sub { shift->{resources}{repository} = {
+ url => 'git://example.com/',
+ type => 'git',
+ } },
+ ],
+ [
+ 'repository resource web',
+ sub { shift->{resources}{repository} = {
+ web => 'http://example.com/',
+ type => 'git',
+ } },
+ ],
+ [
+ 'repository custom',
+ sub { shift->{resources}{repository} = {
+ x_foo => 'foo',
+ } },
+ ],
) {
my ($desc, $sub) = @{ $spec };
my $dm = clone $distmeta;
@@ -449,6 +521,81 @@ for my $spec (
sub { shift->{prereqs}{runtime}{requires}{'foo/bar'} = '1.0.0' },
"'foo/bar' is not a valid term (prereqs -> runtime -> requires -> foo/bar) [Validation: 1.0.0]",
],
+ [
+ 'invalid release status',
+ sub { shift->{release_status} = 'rockin' },
+ "'rockin' for 'release_status' is invalid (release_status) [Validation: 1.0.0]",
+ ],
+ [
+ 'undef release status',
+ sub { shift->{release_status} = undef },
+ "'release_status' is not defined (release_status) [Validation: 1.0.0]",
+ ],
+ [
+ 'homepage resource undef',
+ sub { shift->{resources}{homepage} = undef },
+ "'<undef>' for 'homepage' is not a valid URL. (resources -> homepage) [Validation: 1.0.0]",
+ ],
+ [
+ 'homepage resource non-url',
+ sub { shift->{resources}{homepage} = 'hi' },
+ "'hi' for 'homepage' does not have a URL scheme (resources -> homepage) [Validation: 1.0.0]",
+ ],
+ [
+ 'bugtracker resource undef',
+ sub { shift->{resources}{bugtracker} = undef },
+ "Expected a map structure. (resources -> bugtracker) [Validation: 1.0.0]",
+ ],
+ [
+ 'bugtracker resource array',
+ sub { shift->{resources}{bugtracker} = ['hi'] },
+ "Expected a map structure. (resources -> bugtracker) [Validation: 1.0.0]",
+ ],
+ [
+ 'bugtracker empty invalid key',
+ sub { shift->{resources}{bugtracker} = { foo => 1 } },
+ "Custom key 'foo' must begin with 'x_' or 'X_'. (resources -> bugtracker -> foo) [Validation: 1.0.0]",
+ ],
+ [
+ 'bugtracker invalid URL',
+ sub { shift->{resources}{bugtracker} = { web => 'hi' } },
+ "'hi' for 'web' does not have a URL scheme (resources -> bugtracker -> web) [Validation: 1.0.0]",
+ ],
+ [
+ 'bugtracker invalid email',
+ sub { shift->{resources}{bugtracker} = { mailto => 'hi' } },
+ "'hi' for 'mailto' is not a valid email address (resources -> bugtracker -> mailto) [Validation: 1.0.0]",
+ ],
+ [
+ 'repository resource undef',
+ sub { shift->{resources}{repository} = undef },
+ "Expected a map structure. (resources -> repository) [Validation: 1.0.0]",
+ ],
+ [
+ 'repository resource array',
+ sub { shift->{resources}{repository} = ['hi'] },
+ "Expected a map structure. (resources -> repository) [Validation: 1.0.0]",
+ ],
+ [
+ 'repository empty invalid key',
+ sub { shift->{resources}{repository} = { foo => 1 } },
+ "Custom key 'foo' must begin with 'x_' or 'X_'. (resources -> repository -> foo) [Validation: 1.0.0]",
+ ],
+ [
+ 'repository invalid URL',
+ sub { shift->{resources}{repository} = { url => 'hi' } },
+ "'hi' for 'url' does not have a URL scheme (resources -> repository -> url) [Validation: 1.0.0]",
+ ],
+ [
+ 'repository invalid web URL',
+ sub { shift->{resources}{repository} = { web => 'hi' } },
+ "'hi' for 'web' does not have a URL scheme (resources -> repository -> web) [Validation: 1.0.0]",
+ ],
+ [
+ 'repository invalid type',
+ sub { shift->{resources}{repository} = { type => 'Foo' } },
+ "'Foo' is not a lowercase string (resources -> repository -> type) [Validation: 1.0.0]",
+ ],
) {
my ($desc, $sub, $err) = @{ $spec };
my $dm = clone $distmeta;

0 comments on commit 31de4d4

Please sign in to comment.