pax_global_header00006660000000000000000000000064115315554040014515gustar00rootroot0000000000000052 comment=117cc2bea62c96168cbeb2eae8008987b1b05a7a p5-Kwalify-1.22/000077500000000000000000000000001153155540400133715ustar00rootroot00000000000000p5-Kwalify-1.22/.gitignore000066400000000000000000000001161153155540400153570ustar00rootroot00000000000000/.prove /Kwalify-*.tar.gz /Makefile /Makefile.old /blib /cover_db /pm_to_blib p5-Kwalify-1.22/Changes000066400000000000000000000033301153155540400146630ustar00rootroot00000000000000Revision history for Perl extension Kwalify. 1.22 - cease possible "unitinialized value" warnings 1.21 - fixed RT #48800 (unique in mappings did not work correctly) 1.20 - test failure fix - fixed RT #48714 (return early if not a hash was given) 1.19 - allow the new "class" (previously "classname") - more documentation about unclear schema definition - -h/-help is not anymore "accidentaly" showing the usage 1.18 - additional checks were not run with type 'any' - ceasing a warning if undef was used in enum - added warnings::compat prereq for 5.005 and older 1.17 - documentation change: the URL of the schema user guide changed (thanks to Christoph Lamprecht for the pointer) 1.16 - get rid of backquote in error and warning messages (after reading http://www.cl.cam.ac.uk/~mgk25/ucs/quotes.html) - protect from blib warnings (perl 5.6.x) in pkwalify.t test 1.15 (not released) - include experimental META.yml spec (version 1.3) to test directory - new -v version in pkwalify - new tests 1.14 - stricter checks if schema itself is correct (croak on unhandled keys) 1.13 - fixed bug in range/max test - fixed bug in Schema::Kwalify::validate - better test coverage 1.12 - added another test for older perls 1.11 - fixed another test problem (occurred if IPC::Run was not installed) 1.10 - just some test fixes 1.09 - fixed endless recursion when using recursive schemas or data structures - implemented -s option in pkwalify (like in ruby's kwalify) - pkwalify output now looks closer to the original - pkwalify outputs most things to STDOUT instead of STDERR 1.08 - fixed warnings in pkwalify - inc version in Kwalify.pm to force reinstalling 1.07 first and maybe last version :-) p5-Kwalify-1.22/MANIFEST000066400000000000000000000003741153155540400145260ustar00rootroot00000000000000Changes Makefile.PL MANIFEST README pkwalify t/compat.t t/Kwalify.t t/pkwalify.t t/testdata/document05a.yaml t/testdata/document05b.yaml t/testdata/kwalify.yaml t/testdata/schema05.yaml t/testdata/META-spec-1.3.yml lib/Kwalify.pm lib/Schema/Kwalify.pm p5-Kwalify-1.22/Makefile.PL000066400000000000000000000021751153155540400153500ustar00rootroot00000000000000use 5.000; use ExtUtils::MakeMaker; $is_devel_host = defined $ENV{USER} && $ENV{USER} eq 'eserte' && $^O =~ /bsd/i && -f "../../perl.release.mk"; $eumm_recent_enough = $ExtUtils::MakeMaker::VERSION >= 6.54; if (!$eumm_recent_enough) { *MY::dist_core = sub { <<'EOF'; dist : $(NOECHO) $(ECHO) "Sorry, use a newer EUMM!" EOF }; } WriteMakefile( NAME => 'Kwalify', VERSION_FROM => 'lib/Kwalify.pm', PREREQ_PM => { ($] < 5.006 ? ('warnings::compat' => 0) : ()), }, EXE_FILES => ['pkwalify'], LICENSE => 'perl', #NO_META => 1, ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'lib/Kwalify.pm', # retrieve abstract from module AUTHOR => 'Slaven Rezic ') : ()), ($eumm_recent_enough ? (META_ADD => { resources => { repository => 'git://github.com/eserte/p5-Kwalify.git' } }) : ()), ); sub MY::postamble { my $postamble = ''; if ($is_devel_host) { $postamble .= <<'EOF'; .include "../../perl.release.mk" .include "../../perl.git.mk" EOF } $postamble; } p5-Kwalify-1.22/README000066400000000000000000000015601153155540400142530ustar00rootroot00000000000000Kwalify ======= Kwalify is a Perl implementation for validating data structures against the Kwalify schema. For a schema definition, see http://www.kuwata-lab.com/kwalify/ruby/users-guide.01.html Note that there is no support for validator hooks (section 1-7 of the user guide document). INSTALLATION To install this module type the following: perl Makefile.PL make make test make install Or with modern CPAN.pm ($CPAN::VERSION >= 1.88_55) just: cpan . USAGE of the installed program: pkwalify -f schemafile datafile schemafile and datafile may be YAML or JSON files. COPYRIGHT AND LICENCE Copyright (C) 2006,2007,2008,2009 by Slaven Rezic This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. p5-Kwalify-1.22/lib/000077500000000000000000000000001153155540400141375ustar00rootroot00000000000000p5-Kwalify-1.22/lib/Kwalify.pm000066400000000000000000000367461153155540400161230ustar00rootroot00000000000000# -*- mode: cperl -*- # # Author: Slaven Rezic # # Copyright (C) 2006,2007,2008,2009,2010 Slaven Rezic. All rights reserved. # This package is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: srezic@cpan.org # WWW: http://www.rezic.de/eserte/ # package Kwalify; use strict; use base qw(Exporter); use vars qw(@EXPORT_OK $VERSION); @EXPORT_OK = qw(validate); $VERSION = '1.22'; BEGIN { if ($] < 5.006) { $INC{"warnings.pm"} = 1; *warnings::import = sub { }; *warnings::unimport = sub { }; } } sub validate ($$) { my($schema, $data) = @_; my $self = Kwalify::Validator->new; $self->validate($schema, $data, "/"); if (@{$self->{errors}}) { die join("\n", map { " - $_" } @{$self->{errors}}) . "\n"; } else { 1; } } package Kwalify::Validator; use overload (); sub new { my($class) = @_; bless { errors => [] }, $class; } sub validate { my($self, $schema, $data, $path, $args) = @_; $self->{done} = {}; $self->_validate($schema, $data, $path, $args); } sub _validate { my($self, $schema, $data, $path, $args) = @_; $self->{path} = $path; if (!UNIVERSAL::isa($schema, "HASH")) { $self->_die("Schema structure must be a hash reference"); } my $type = $schema->{type}; if (!defined $type) { $type = 'str'; # default type; } my $type_check_method = "validate_" . $type; if (!$self->can($type_check_method)) { $self->_die("Invalid or unimplemented type '$type'"); } $self->$type_check_method($schema, $data, $path, $args); } sub _additional_rules { my($self, $schema, $data, $path) = @_; no warnings 'uninitialized'; # legal undef values may happen everywhere for my $schema_key (keys %$schema) { if (defined $schema->{$schema_key}) { if ($schema_key eq 'pattern') { (my $pattern = $schema->{pattern}) =~ s{^/(.*)/$}{$1}; if ($data !~ qr{$pattern}) { $self->_error("Non-valid data '$data' does not match /$pattern/"); } } elsif ($schema_key eq 'length') { if (!UNIVERSAL::isa($schema->{'length'}, "HASH")) { $self->_die("'length' must be a hash with keys max and/or min"); } my $length = length($data); for my $sub_schema_key (keys %{ $schema->{'length'} }) { if ($sub_schema_key eq 'min') { my $min = $schema->{'length'}->{min}; if ($length < $min) { $self->_error("'$data' is too short (length $length < min $min)"); } } elsif ($sub_schema_key eq 'min-ex') { my $min = $schema->{'length'}->{'min-ex'}; if ($length <= $min) { $self->_error("'$data' is too short (length $length <= min $min)"); } } elsif ($sub_schema_key eq 'max') { my $max = $schema->{'length'}->{max}; if ($length > $max) { $self->_error("'$data' is too long (length $length > max $max)"); } } elsif ($sub_schema_key eq 'max-ex') { my $max = $schema->{'length'}->{'max-ex'}; if ($length >= $max) { $self->_error("'$data' is too long (length $length >= max $max)"); } } else { $self->_die("Unexpected key '$sub_schema_key' in length specification, expected min, max, min-ex and/or max-ex"); } } } elsif ($schema_key eq 'enum') { if (!UNIVERSAL::isa($schema->{enum}, 'ARRAY')) { $self->_die("'enum' must be an array"); } my %valid = map { ($_,1) } @{ $schema->{enum} }; if (!exists $valid{$data}) { $self->_error("'$data': invalid " . _base_path($path) . " value"); } } elsif ($schema_key eq 'range') { if (!UNIVERSAL::isa($schema->{range}, "HASH")) { $self->_die("'range' must be a hash with keys max and/or min"); } my($lt, $le, $gt, $ge); ## yes? no? # if (eval { require Scalar::Util; defined &Scalar::Util::looks_like_number }) { # if (Scalar::Util::looks_like_number($data)) { # $lt = sub { $_[0] < $_[1] }; # $gt = sub { $_[0] > $_[1] }; # } else { # $lt = sub { $_[0] lt $_[1] }; # $gt = sub { $_[0] gt $_[1] }; # } # } else { # warn "Cannot determine whether $data is a number, assume so..."; # XXX show only once no warnings 'numeric'; $lt = sub { $_[0] < $_[1] }; $gt = sub { $_[0] > $_[1] }; $le = sub { $_[0] <= $_[1] }; $ge = sub { $_[0] >= $_[1] }; # } for my $sub_schema_key (keys %{ $schema->{range} }) { if ($sub_schema_key eq 'min') { my $min = $schema->{range}->{min}; if ($lt->($data, $min)) { $self->_error("'$data' is too small (< min $min)"); } } elsif ($sub_schema_key eq 'min-ex') { my $min = $schema->{range}->{'min-ex'}; if ($le->($data, $min)) { $self->_error("'$data' is too small (<= min $min)"); } } elsif ($sub_schema_key eq 'max') { my $max = $schema->{range}->{max}; if ($gt->($data, $max)) { $self->_error("'$data' is too large (> max $max)"); } } elsif ($sub_schema_key eq 'max-ex') { my $max = $schema->{range}->{'max-ex'}; if ($ge->($data, $max)) { $self->_error("'$data' is too large (>= max $max)"); } } else { $self->_die("Unexpected key '$sub_schema_key' in range specification, expected min, max, min-ex and/or max-ex"); } } } elsif ($schema_key eq 'assert') { $self->_die("'assert' is not yet implemented"); } elsif ($schema_key !~ m{^(type|required|unique|name|classname|class|desc)$}) { $self->_die("Unexpected key '$schema_key' in type specification"); } } } } sub validate_text { my($self, $schema, $data, $path) = @_; if (!defined $data || ref $data) { return $self->_error("Non-valid data '" . (defined $data ? $data : 'undef') . "', expected text"); } $self->_additional_rules($schema, $data, $path); } sub validate_str { my($self, $schema, $data, $path) = @_; if (!defined $data || ref $data || $data =~ m{^\d+(\.\d+)?$}) { return $self->_error("Non-valid data '" . (defined $data ? $data : 'undef') . "', expected a str"); } $self->_additional_rules($schema, $data, $path); } sub validate_int { my($self, $schema, $data, $path) = @_; if ($data !~ m{^[+-]?\d+$}) { # XXX what about scientific notation? $self->_error("Non-valid data '" . $data . "', expected an int"); } $self->_additional_rules($schema, $data, $path); } sub validate_float { my($self, $schema, $data, $path) = @_; if ($data !~ m{^[+-]?\d+\.\d+$}) { # XXX other values? $self->_error("Non-valid data '" . $data . "', expected a float"); } $self->_additional_rules($schema, $data, $path); } sub validate_number { my($self, $schema, $data, $path) = @_; if ($data !~ m{^[+-]?\d+(\.\d+)?$}) { # XXX combine int+float regexp! $self->_error("Non-valid data '" . $data . "', expected a number"); } $self->_additional_rules($schema, $data, $path); } sub validate_bool { my($self, $schema, $data, $path) = @_; if ($data !~ m{^(yes|true|1|no|false|0)$}) { # XXX correct? $self->_error("Non-valid data '" . $data . "', expected a boolean"); } $self->_additional_rules($schema, $data, $path); } # XXX is this correct? sub validate_scalar { shift->validate_text(@_); } sub validate_date { my($self, $schema, $data, $path) = @_; if ($data !~ m{^\d{4}-\d{2}-\d{2}$}) { $self->_error("Non-valid data '" . $data . "', expected a date (YYYY-MM-DD)"); } $self->_additional_rules($schema, $data, $path); } sub validate_time { my($self, $schema, $data, $path) = @_; if ($data !~ m{^\d{2}:\d{2}:\d{2}$}) { $self->_error("Non-valid data '" . $data . "', expected a time (HH:MM:SS)"); } $self->_additional_rules($schema, $data, $path); } sub validate_timestamp { my($self) = @_; $self->_error("timestamp validation NYI"); # XXX } sub validate_any { my($self, $schema, $data, $path) = @_; $self->_additional_rules($schema, $data, $path); } sub validate_seq { my($self, $schema, $data, $path) = @_; if (!exists $schema->{sequence}) { $self->_die("'sequence' missing with 'seq' type"); } my $sequence = $schema->{sequence}; if (!UNIVERSAL::isa($sequence, 'ARRAY')) { $self->_die("Expected array in 'sequence'"); } if (@$sequence != 1) { $self->_die("Expect exactly one element in sequence"); } if (!UNIVERSAL::isa($data, 'ARRAY')) { $self->_error("Non-valid data " . $data . ", expected sequence"); return; } return if ($self->{done}{overload::StrVal($data)}{overload::StrVal($schema)}); $self->{done}{overload::StrVal($data)}{overload::StrVal($schema)} = 1; my $subschema = $sequence->[0]; my $unique = _get_boolean($subschema->{unique}); my %unique_val; my %unique_mapping_val; my $index = 0; for my $elem (@$data) { my $subpath = _append_path($path, $index); $self->_validate($subschema, $elem, $subpath, { unique_mapping_val => \%unique_mapping_val}); if ($unique) { if (exists $unique_val{$elem}) { $self->_error("'$elem' is already used at '$unique_val{$elem}'"); } else { $unique_val{$elem} = $subpath; } } $index++; } } sub validate_map { my($self, $schema, $data, $path, $args) = @_; my $unique_mapping_val; if ($args && $args->{unique_mapping_val}) { $unique_mapping_val = $args->{unique_mapping_val}; } if (!exists $schema->{mapping}) { $self->_die("'mapping' missing with 'map' type"); } my $mapping = $schema->{mapping}; if (!UNIVERSAL::isa($mapping, 'HASH')) { $self->_die("Expected hash in 'mapping'"); } if (!defined $data) { $self->_error("Undefined data, expected mapping"); return; } if (!UNIVERSAL::isa($data, 'HASH')) { $self->_error("Non-valid data " . $data . ", expected mapping"); return; } return if ($self->{done}{overload::StrVal($data)}{overload::StrVal($schema)}); $self->{done}{overload::StrVal($data)}{overload::StrVal($schema)} = 1; my %seen_key; my $default_key_schema; ## Originally this was an each-loop, but this could lead into ## endless recursions, because mapping may be reused in Kwalify, ## thus the each iterator was shared between recursion levels. # while(my($key,$subschema) = each %$mapping) { for my $key (keys %$mapping) { my $subschema = $mapping->{$key}; if ($key eq '=') { # the "default" key $default_key_schema = $subschema; next; } my $subpath = _append_path($path, $key); $self->{path} = $subpath; if (!UNIVERSAL::isa($subschema, 'HASH')) { $self->_die("Expected subschema (a hash)"); } my $required = _get_boolean($subschema->{required}); if (!exists $data->{$key}) { if ($required) { $self->{path} = $path; $self->_error("Expected required key '$key'"); next; } else { next; } } my $unique = _get_boolean($subschema->{unique}); if ($unique) { if (defined $unique_mapping_val->{$data->{$key}}->{val} && $unique_mapping_val->{$data->{$key}}->{val} eq $data->{$key}) { $self->_error("'$data->{$key}' is already used at '$unique_mapping_val->{$data->{$key}}->{path}'"); } else { $unique_mapping_val->{$data->{$key}} = { val => $data->{$key}, path => $subpath, }; } } $self->_validate($subschema, $data->{$key}, $subpath); $seen_key{$key}++; } # while(my($key,$val) = each %$data) { for my $key (keys %$data) { my $val = $data->{$key}; my $subpath = _append_path($path, $key); $self->{path} = $subpath; if (!$seen_key{$key}) { if ($default_key_schema) { $self->_validate($default_key_schema, $val, $subpath); } else { $self->_error("Unexpected key '$key'"); } } } } sub _die { my($self, $msg) = @_; $msg = "[$self->{path}] $msg"; die $msg."\n"; } sub _error { my($self, $msg) = @_; $msg = "[$self->{path}] $msg"; push @{$self->{errors}}, $msg; 0; } # Functions: sub _append_path { my($root, $leaf) = @_; $root . ($root !~ m{/$} ? "/" : "") . $leaf; } sub _base_path { my($path) = @_; my($base) = $path =~ m{([^/]+)$}; $base; } sub _get_boolean { my($val) = @_; defined $val && $val =~ m{^(yes|true|1)$}; # XXX check for all boolean trues } 1; __END__ =head1 NAME Kwalify - Kwalify schema for data structures =head1 SYNOPSIS use Kwalify qw(validate); validate($schema, $data); Typically used together with YAML or JSON: use YAML; validate(YAML::LoadFile($schema_file), YAML::LoadFile($data_file)); use JSON; validate(jsonToObj($schema_data), jsonToObj($data)); =head1 DESCRIPTION Kwalify is a Perl implementation for validating data structures against the Kwalify schema. For a schema definition, see L, but see also below L. =head2 validate($schema_data, $data) Validate I<$data> according to Kwalify schema specified in I<$schema_data>. Dies if the validation fails. B may be exported. =head1 SCHEMA DEFINITION The original schema definition document is not very specific about types and behaviour. Here's how B implements things: =over =item pattern Perl regular expressions are used for patterns. This may or may not be compatible with other Kwalify validators, so restrict to "simple" regular expression constructs to be compatible with other validators. =item type =over =item str Any defined value which is B a number. Most probably you will want to use B instead of B. =item int A possibly signed integer. Note that scientific notation is not supported, and it is also not clear whether it should be supported. =item float A possibly signed floating value with a mandatory decimal point. Note that scientific notation is also not supported here. =item bool The values B, B, and B<1> for true values and the values B, B, and B<0> for false values are allowed. The ruby implementation possibly allows more values, but this is not documented. Note that this definition is problematic, because for example the string B is a true boolean value in Perl. So one should stick to B<0> and B<1> as data values, and probably define an additional B or B to ensure this: type: bool enum: [0, 1] =item scalar Currently the same as B, but it's not clear if this is correct. =item date A string matching C<< /^\d{4}-\d{2}-\d{2}$/ >> (i.e. YYYY-MM-DD). Note that no date range checks are done (yet). =item time A string matching C<< /^\d{2}:\d{2}:\d{2}$/ >> (i.e. HH:MM:SS). Note that no time range checks are done (yet). =item timestamp Not supported --- it is not clear what this is supposed to be. =back =item assert Currently not supported by the Perl implementation. =item classname Previously defined what is now B, see L. =item class Currently not used, as there's no genclass action. =item default Currently not used, as there's no genclass action. =back =head1 TECHNICAL NOTES As B is a pure validator and de-coupled from a parser (in fact, it does not need to deal with YAML at all, but just with pure perl data structures), there's no connection to the original validated document. This means that no line numbers are available to the validator. In case of validation errors the validator is only able to show a path-like expression to the data causing the error. =head1 AUTHOR Slaven ReziE, Esrezic@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright (C) 2006,2007,2008,2009,2010 by Slaven ReziE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. =head1 SEE ALSO L, L. Other non-XML schema languages: L =cut p5-Kwalify-1.22/lib/Schema/000077500000000000000000000000001153155540400153375ustar00rootroot00000000000000p5-Kwalify-1.22/lib/Schema/Kwalify.pm000066400000000000000000000020331153155540400173010ustar00rootroot00000000000000# -*- mode: cperl; coding: latin-2 -*- # # $Id: Kwalify.pm,v 1.4 2007/03/04 10:50:06 eserte Exp $ # Author: Slaven Rezic # # Copyright (C) 2006,2007 Slaven Rezic. All rights reserved. # This package is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: slaven@rezic.de # WWW: http://www.rezic.de/eserte/ # package Schema::Kwalify; use strict; use vars qw($VERSION); $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); use Kwalify qw(); sub new { bless {}, shift; } sub validate { my($self, $schema, $data) = @_; Kwalify::validate($schema, $data); } 1; __END__ =encoding iso-8859-2 =head1 NAME Schema::Kwalify - =head1 SYNOPSIS Not yet =head1 DESCRIPTION I expect that there will be other schema languages for data structures defined. It would be nice if the implementations would use the B namespace, and that these modules share a common interface. =head1 AUTHOR Slaven Reziæ, Esrezic@cpan.orgE =head1 SEE ALSO L. =cut p5-Kwalify-1.22/pkwalify000077500000000000000000000064461153155540400151570ustar00rootroot00000000000000#!/usr/bin/perl -w # -*- mode: cperl; coding: latin-2 -*- # # Author: Slaven Rezic # # Copyright (C) 2006,2007,2008,2009 Slaven Rezic. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: slaven@rezic.de # WWW: http://www.rezic.de/eserte/ # use strict; use vars qw($VERSION); $VERSION = '1.12'; use Kwalify; use Getopt::Long; my $schema_file; my $silent; my $show_version; GetOptions("f=s" => \$schema_file, "s|silent" => \$silent, "v|version" => \$show_version, "h|help" => sub { print usage(); exit 0 }, ) or die usage(); if ($show_version) { version(); exit; } if (!defined $schema_file) { die usage("-f option is mandatory"); } my $data_file = shift @ARGV; if (!defined $data_file) { die usage("datafile is mandatory"); } my(@schema) = read_file($schema_file); if (@schema != 1) { print "<$schema_file> does not contain exactly one schema, cannot handle this."; exit 1; } my $schema = $schema[0]; my(@data) = read_file($data_file); my $errors = 0; my $document_index = 0; for my $data (@data) { my $document_label = $data_file . '#' . $document_index; eval { Kwalify::validate($schema, $data) }; if ($@) { print "$document_label: INVALID\n$@\n"; $errors++; } else { if (!$silent) { print "$document_label: valid.\n"; } } $document_index++; } exit $errors; sub read_file { my $file = shift; my @data; my @errors; if (eval { require YAML::Syck; 1 }) { @data = eval { YAML::Syck::LoadFile($file) }; return @data if !$@; push @errors, $@; } if (eval { require YAML; 1 }) { @data = eval { YAML::LoadFile($file) }; return @data if !$@; push @errors, $@; } if (eval { require JSON; 1 }) { my $data = eval { open JSON, "< $file" or die "Can't open <$file>: $!"; local $/ = undef; my $json = ; close JSON; if (defined &JSON::from_json) { JSON::from_json($json, {utf8 => 1}); } else { JSON::jsonToObj($json); } }; return ($data) if $data && !$@; push @errors, $@; } die "Cannot parse <$file>. Cumulated errors:\n" . join("\n", @errors) . "\n"; } sub usage { my($msg) = @_; if (defined $msg) { $msg .= "\n"; } else { $msg = ""; } < validates the data from I (which may be a L or L file) against a schema defined with I (which also may be a YAML or JSON file). The program returns the number of errors found in the datafile. An exit status 0 means no errors. =head2 OPTIONS =over =item -f I Specify a schema file, either as YAML or JSON. Required. =item -s Be silent if the document is valid. =item -v Show script and module versions and exit. =item -h --help Show summary of options. =item =back =head1 AUTHOR Slaven Reziæ, Esrezic@cpan.orgE =head1 SEE ALSO L, L, L, L. =cut p5-Kwalify-1.22/t/000077500000000000000000000000001153155540400136345ustar00rootroot00000000000000p5-Kwalify-1.22/t/Kwalify.t000077500000000000000000000410661153155540400154410ustar00rootroot00000000000000#!/usr/bin/perl -w # -*- perl -*- # # Author: Slaven Rezic # use strict; BEGIN { if (!eval q{ use Test::More; 1; }) { print "1..0 # skip: no Test::More module\n"; exit; } if ($] < 5.005) { print "1..0 # skip: test works only with perl 5.005 or better\n"; exit; } } my $yaml_syck_tests; BEGIN { $yaml_syck_tests = 38; plan tests => 2 + $yaml_syck_tests + 40; } BEGIN { use_ok('Kwalify', 'validate'); } my @w; $SIG{__WARN__} = sub { push @w, @_ }; use_ok('Schema::Kwalify'); sub is_valid_yaml { my($schema, $document, $testname) = @_; local $Test::Builder::Level = $Test::Builder::Level+1; ok(validate(YAML::Syck::Load($schema), YAML::Syck::Load($document)), $testname); } sub is_invalid_yaml { my($schema, $document, $errors, $testname) = @_; local $Test::Builder::Level = $Test::Builder::Level+1; ok(!eval { validate(YAML::Syck::Load($schema), YAML::Syck::Load($document)) }, $testname); for my $error (@$errors) { if (UNIVERSAL::isa($error, 'HASH')) { my($pattern, $testname) = @{$error}{qw(pattern testname)}; like($@, $pattern, $testname); } else { like($@, $error); } } } SKIP: { skip("Need YAML::Syck for tests", $yaml_syck_tests) if !eval { require YAML::Syck; 1 }; my $schema01 = <<'EOF'; type: seq sequence: - type: str EOF my $document01a = <<'EOF'; - foo - bar - baz EOF is_valid_yaml($schema01, $document01a, "sequence of str"); my $schema01b = <<'EOF'; type: seq sequence: [{}] EOF is_valid_yaml($schema01b, $document01a, "sequence with default type (str)"); my $document01b = <<'EOF'; - foo - 123 - baz EOF is_invalid_yaml($schema01,$document01b, [qr{\Q[/1] Non-valid data '123', expected a str}], "Non valid data, int in sequence of str"); my $schema02 = <<'EOF'; type: map mapping: name: type: str required: yes email: type: str pattern: /@/ age: type: int birth: type: date EOF my $document02a = <<'EOF'; name: foo email: foo@mail.com age: 20 birth: 1985-01-01 EOF is_valid_yaml($schema02, $document02a, "mapping"); my $document02b = <<'EOF'; name: foo email: foo(at)mail.com age: twenty birth: Jun 01, 1985 EOF is_invalid_yaml($schema02, $document02b, [qr{\Q[/birth] Non-valid data 'Jun 01, 1985', expected a date (YYYY-MM-DD)}, qr{\Q[/age] Non-valid data 'twenty', expected an int}, qr{\Q[/email] Non-valid data 'foo(at)mail.com' does not match /@/}, ], "invalid mapping"); my $schema03 = <<'EOF'; type: seq sequence: - type: map mapping: name: type: str required: true email: type: str EOF my $document03a = <<'EOF'; - name: foo email: foo@mail.com - name: bar email: bar@mail.net - name: baz email: baz@mail.org EOF is_valid_yaml($schema03, $document03a, "sequence of mapping"); my $document03b = <<'EOF'; - name: foo email: foo@mail.com - naem: bar email: bar@mail.net - name: baz mail: baz@mail.org EOF is_invalid_yaml($schema03, $document03b, [qr{\Q[/1] Expected required key 'name'}, qr{\Q[/1/naem] Unexpected key 'naem'}, qr{\Q[/2/mail] Unexpected key 'mail'}, ]); my $schema04 = <<'EOF'; type: map mapping: company: type: str required: yes email: type: str employees: type: seq sequence: - type: map mapping: code: type: int required: yes name: type: str required: yes email: type: str EOF my $document04a = <<'EOF'; company: Kuwata lab. email: webmaster@kuwata-lab.com employees: - code: 101 name: foo email: foo@kuwata-lab.com - code: 102 name: bar email: bar@kuwata-lab.com EOF is_valid_yaml($schema04, $document04a, "mapping of sequence"); my $document04b = <<'EOF'; company: Kuwata Lab. email: webmaster@kuwata-lab.com employees: - code: A101 name: foo email: foo@kuwata-lab.com - code: 102 name: bar mail: bar@kuwata-lab.com EOF is_invalid_yaml($schema04, $document04b, [qr{\Q[/employees/0/code] Non-valid data 'A101', expected an int}, qr{\Q[/employees/1/mail] Unexpected key 'mail'}, ]); my $schema05 = <<'EOF'; type: seq # new rule sequence: - type: map # new rule mapping: name: type: str # new rule required: yes email: type: str # new rule required: yes pattern: /@/ password: type: text # new rule length: { max: 16, min: 8 } age: type: int # new rule range: { max: 30, min: 18 } # or assert: 18 <= val && val <= 30 blood: type: str # new rule enum: - A - B - O - AB birth: type: date # new rule memo: type: any # new rule EOF my $document05a = <<'EOF'; - name: foo email: foo@mail.com password: xxx123456 age: 20 blood: A birth: 1985-01-01 - name: bar email: bar@mail.net age: 25 blood: AB birth: 1980-01-01 EOF is_valid_yaml($schema05, $document05a, "Many rules"); my $document05b = <<'EOF'; - name: foo email: foo(at)mail.com password: xxx123 age: twenty blood: a birth: 1985-01-01 - given-name: bar family-name: Bar email: bar@mail.net age: 15 blood: AB birth: 1980/01/01 EOF is_invalid_yaml($schema05, $document05b, [ qr{\Q[/0/blood] 'a': invalid blood value}, qr{\Q[/0/email] Non-valid data 'foo(at)mail.com' does not match /@/}, qr{\Q[/0/password] 'xxx123' is too short (length 6 < min 8)}, qr{\Q[/0/age] Non-valid data 'twenty', expected an int}, qr{\Q[/0/age] 'twenty' is too small (< min 18)}, qr{\Q[/1/birth] Non-valid data '1980/01/01', expected a date (YYYY-MM-DD)}, qr{\Q[/1] Expected required key 'name'}, qr{\Q[/1/age] '15' is too small (< min 18)}, qr{\Q[/1/given-name] Unexpected key 'given-name'}, qr{\Q[/1/family-name] Unexpected key 'family-name'}, ]); my $schema06 = <<'EOF'; type: seq sequence: - type: map required: yes mapping: name: type: str required: yes unique: yes email: type: str groups: type: seq sequence: - type: str unique: yes EOF my $document06a = <<'EOF'; - name: foo email: admin@mail.com groups: - users - foo - admin - name: bar email: admin@mail.com groups: - users - admin - name: baz email: baz@mail.com groups: - users EOF is_valid_yaml($schema06, $document06a, "unique"); my $document06b = <<'EOF'; - name: foo email: admin@mail.com groups: - foo - users - admin - foo - name: bar email: admin@mail.com groups: - admin - users - name: bar email: baz@mail.com groups: - users EOF is_invalid_yaml($schema06, $document06b, [qr{\Q[/0/groups/3] 'foo' is already used at '/0/groups/0'}, qr{\Q[/2/name] 'bar' is already used at '/1/name'}, ]); # testcase for RT #48800 my $document_unique = <<'EOF'; - name: foo - name: bar - name: barf - name: bar EOF is_invalid_yaml($schema06, $document_unique, [qr{\Q[/3/name] 'bar' is already used at '/1/name'}, ]); # Recursive mappings: my $recursive_schema = <<'EOF'; name: MAIN type: map required: yes mapping: &main-rule "type": type: str enum: - map - str "mapping": name: MAPPING type: map mapping: =: type: map mapping: *main-rule name: MAIN #required: yes EOF my $non_recursive_document = <<'EOF'; type: map mapping: recursive_hash: type: map mapping: bla: type: str foo: type: str another_key: type: str EOF my $recursive_maps = <<'EOF'; type: map mapping: recursive_hash: &recursive type: map mapping: bla: type: str foo: type: str bar: *recursive another_key: type: str EOF is_valid_yaml($recursive_schema, $non_recursive_document, "valid data against schema with recursive rules (no endless loop)"); is_valid_yaml($recursive_schema, $recursive_maps, "valid recursive data against schema with recursive rules (no endless loop)"); } { my $schema06_pl = { 'sequence' => [ { 'mapping' => { 'email' => { 'type' => 'str' }, 'groups' => { 'sequence' => [ { 'unique' => 'yes', 'type' => 'str' } ], 'type' => 'seq' }, 'name' => { 'unique' => 'yes', 'required' => 'yes', 'type' => 'str' } }, 'required' => 'yes', 'type' => 'map' } ], 'type' => 'seq' }; my $document06a_pl = [ { 'email' => 'admin@mail.com', 'groups' => [ 'users', 'foo', 'admin' ], 'name' => 'foo' }, { 'email' => 'admin@mail.com', 'groups' => [ 'users', 'admin' ], 'name' => 'bar' }, { 'email' => 'baz@mail.com', 'groups' => [ 'users' ], 'name' => 'baz' } ]; my $document06b_pl = [ { 'email' => 'admin@mail.com', 'groups' => [ 'foo', 'users', 'admin', 'foo' ], 'name' => 'foo' }, { 'email' => 'admin@mail.com', 'groups' => [ 'admin', 'users' ], 'name' => 'bar' }, { 'email' => 'baz@mail.com', 'groups' => [ 'users' ], 'name' => 'bar' } ]; ok(validate($schema06_pl, $document06a_pl), "valid data against perl schema"); eval { validate($schema06_pl, $document06b_pl) }; ok($@, "invalid data against perl schema"); } { # test length/range min/max-ex # (no tests in original document) my $schema_ex = { type => "map", mapping => { password => { type => "text", length => { 'max-ex' => 16, 'min-ex' => 8 }, }, age => { type => "int", range => { 'max-ex' => 30, 'min-ex' => 18 }, }, } }; my $document_length_min_ex_pass = { password => "123456789" }; ok(validate($schema_ex, $document_length_min_ex_pass), "min-ex length pass"); my $document_length_min_ex_fail = { password => "12345678" }; eval { validate($schema_ex, $document_length_min_ex_fail) }; like($@, qr{\Qis too short (length 8 <= min 8)}, "min-ex length fail"); my $document_length_max_ex_pass = { password => "123456789012345" }; ok(validate($schema_ex, $document_length_max_ex_pass), "max-ex length pass"); my $document_length_max_ex_fail = { password => "1234567890123456" }; eval { validate($schema_ex, $document_length_max_ex_fail) }; like($@, qr{\Qis too long (length 16 >= max 16)}, "max-ex length fail"); ###################################################################### my $document_range_min_ex_pass = { age => 19 }; ok(validate($schema_ex, $document_range_min_ex_pass), "min-ex range pass"); my $document_range_min_ex_fail = { age => 18 }; eval { validate($schema_ex, $document_range_min_ex_fail) }; like($@, qr{\Qis too small (<= min 18)}, "min-ex range fail"); my $document_range_max_ex_pass = { age => 29 }; ok(validate($schema_ex, $document_range_max_ex_pass), "max-ex range pass"); my $document_range_max_ex_fail = { age => 30 }; eval { validate($schema_ex, $document_range_max_ex_fail) }; like($@, qr{\Qis too large (>= max 30)}, "max-ex range fail"); } { # missing length/range max tests my $schema = { type => "map", mapping => { password => { type => "text", length => { 'max' => 16, 'min-ex' => 8 }, }, age => { type => "int", range => { 'max' => 16, 'min-ex' => 8 }, }, } }; my $document_length_max_pass = { password => "1234567890123456" }; ok(validate($schema, $document_length_max_pass), "max length pass"); my $document_length_max_fail = { password => "12345678901234567" }; eval { validate($schema, $document_length_max_fail) }; like($@, qr{\Qis too long (length 17 > max 16)}, "max length fail"); my $document_range_max_pass = { age => 16 }; ok(validate($schema, $document_range_max_pass), "max range pass"); my $document_range_max_fail = { age => 17 }; eval { validate($schema, $document_range_max_fail) }; like($@, qr{\Qis too large (> max 16)}, "max range fail"); } { ok(validate({type=>"text", name=>"A schema name", classname=>"TestClass", # the old now undocumented "classname" desc=>"Just testing the description.\nReally!", }, "foo"), "Passing name/classname/desc"); } { ok(validate({type=>"text", name=>"A schema name", class=>"TestClass", # the new "class" (instead of "classname") desc=>"Just testing the description.\nReally!", }, "foo"), "Passing name/class/desc"); } { # Some validation tests eval { validate({type => "text"}, [qw(a ref is not a text)]) }; like($@, qr{Non-valid data}, "a ref is not a text"); eval { validate({type => "text"}, undef) }; like($@, qr{Non-valid data.*undef}, "undef is not a text"); eval { validate({type => "str"}, [qw(a ref is not a str)]) }; like($@, qr{Non-valid data}, "a str is not a text"); eval { validate({type => "str"}, undef) }; like($@, qr{Non-valid data.*undef}, "undef is not a str"); eval { validate({type => "str"}, 1.2) }; like($@, qr{Non-valid data}, "a number is not a str"); } # Missing spec for float # Missing spec for number # Missing spec for bool { # Various schema error conditions eval { validate([qw(schema not a hash)], {}) }; like($@, qr{Schema structure must be a hash reference}, "schema must be hash"); eval { validate({type=>"unknown"},{}) }; like($@, qr{Invalid or unimplemented type .*unknown}, "unknown type"); eval { validate({type=>"text", length => "foo"}, "foo") }; like($@, qr{length.* must be a hash with keys max and/or min}, "invalid length spec"); eval { validate({type=>"text", enum=>"not an array"}, "foo") }; like($@, qr{must be an array}, "invalid enum spec"); eval { validate({type=>"text", range => "foo"}, "foo") }; like($@, qr{range.* must be a hash with keys max and/or min}, "invalid range spec"); eval { validate({type=>"text", unknown_key => "foo"}, "foo") }; like($@, qr{Unexpected key 'unknown_key' in type specification}, "unknown key in type"); eval { validate({type=>"int", range=>{foo => 1}}, "foo") }; like($@, qr{Unexpected key 'foo' in range specification}, "unknown key in range"); eval { validate({type=>"int", length=>{foo => 1}}, "foo") }; like($@, qr{Unexpected key 'foo' in length specification}, "unknown key in length"); eval { validate({type=>"map", mapping=> {foo=>{type=>"text"}} }, []) }; like($@, qr{Non-valid data .*, expected mapping}, "expected hash in data"); } { # Schema::Kwalify tests my $sk = Schema::Kwalify->new; isa_ok($sk, "Schema::Kwalify"); ok($sk->validate({type=>"text"},"foo"), "Simple Schema::Kwalify validation"); eval { $sk->validate({type=>"text"},[]) }; isnt($@, "", "Simple Schema::Kwalify failure"); } { # Test any with additional checks my $schema = { type => "any", pattern => "CODE", }; ok(validate($schema, "CODE"), "type any with additional check, successful"); eval { validate($schema, "CoDe"); }; like($@, qr{Non-valid data 'CoDe' does not match /CODE/}, "type any with additional check, failure"); } { my $schema = { type => "any", enum => [1,2,undef], }; ok(validate($schema, 1), "enum with defined value"); ok(validate($schema, undef), "enum with undefined value"); } { my $schema = { type => "any", pattern => '/^(|something)$/', }; ok(validate($schema, 'something'), "legally undefined pattern"); ok(validate($schema, undef), "legally undefined pattern"); } SKIP: { skip("Don't bother with warnings on old perls without warnings.pm", 1) if $] < 5.006; is("@w", "", "No warnings expected"); } __END__ p5-Kwalify-1.22/t/compat.t000077500000000000000000000033331153155540400153110ustar00rootroot00000000000000#!/usr/bin/perl -w # -*- perl -*- # # Author: Slaven Rezic # # This test is just for older perls (5.004, 5.005) # because the other test scripts in this suite have # too large prerequisites (Test::More, \Q in regexpes...) use strict; use Kwalify qw(validate); use Test; plan tests => 2; { my $schema06_pl = { 'sequence' => [ { 'mapping' => { 'email' => { 'type' => 'str' }, 'groups' => { 'sequence' => [ { 'unique' => 'yes', 'type' => 'str' } ], 'type' => 'seq' }, 'name' => { 'unique' => 'yes', 'required' => 'yes', 'type' => 'str' } }, 'required' => 'yes', 'type' => 'map' } ], 'type' => 'seq' }; my $document06a_pl = [ { 'email' => 'admin@mail.com', 'groups' => [ 'users', 'foo', 'admin' ], 'name' => 'foo' }, { 'email' => 'admin@mail.com', 'groups' => [ 'users', 'admin' ], 'name' => 'bar' }, { 'email' => 'baz@mail.com', 'groups' => [ 'users' ], 'name' => 'baz' } ]; my $document06b_pl = [ { 'email' => 'admin@mail.com', 'groups' => [ 'foo', 'users', 'admin', 'foo' ], 'name' => 'foo' }, { 'email' => 'admin@mail.com', 'groups' => [ 'admin', 'users' ], 'name' => 'bar' }, { 'email' => 'baz@mail.com', 'groups' => [ 'users' ], 'name' => 'bar' } ]; ok(validate($schema06_pl, $document06a_pl)); eval { validate($schema06_pl, $document06b_pl) }; ok($@); } __END__ p5-Kwalify-1.22/t/pkwalify.t000077500000000000000000000163501153155540400156570ustar00rootroot00000000000000#!/usr/bin/perl -w # -*- perl -*- # # Author: Slaven Rezic # use strict; use FindBin; use Getopt::Long; BEGIN { if (!eval q{ use Test::More; use File::Temp; use File::Spec 0.8; # rel2abs 1; }) { print "1..0 # skip: no Test::More, File::Spec and/or File::Temp modules\n"; exit; } } require blib; # just to get blib's VERSION my $skip_warnings_test = $blib::VERSION < 1.01; # Test cases with single documents my @yaml_syck_defs = (["schema05.yaml", "document05a.yaml", 1], ["schema05.yaml", "document05b.yaml", 0], ); # Test cases with multiple documents (by combining single documents) my %combined_document; { for my $def (["invalid_diff", "document05a.yaml", "document05b.yaml"], ["valid_same", "document05a.yaml", "document05a.yaml"], ["invalid_same", "document05b.yaml", "document05b.yaml"], ["invalid_schema", "schema05.yaml", "schema05.yaml"], ) { my($newname, @yaml) = @$def; my($fh,$outfile) = File::Temp::tempfile(SUFFIX => ".yaml", UNLINK => 1); if (!$fh) { die "Cannot create temporary file: $!"; } # fix possible problem if somebody sets TMPDIR=. $outfile = File::Spec->rel2abs($outfile) if !File::Spec->file_name_is_absolute($outfile); for my $document (@yaml) { print $fh "--- \n"; { open IN, "$FindBin::RealBin/testdata/$document" or die $!; local $/ = undef; print $fh ; close IN; } } $combined_document{$newname} = $outfile; close $fh; } } # Test cases for YAML::Syck (schema+document combinations) push @yaml_syck_defs, ( [$combined_document{"invalid_schema"}, "document05a.yaml", 0], ["schema05.yaml", $combined_document{"invalid_diff"}, 0], ["schema05.yaml", $combined_document{"valid_same"}, 1], ["schema05.yaml", $combined_document{"invalid_same"}, 0], ); # Test cases for JSON (generated from YAML documents) my @json_defs = (); if (eval { require YAML::Syck; require JSON; 1 }) { my %json_equivalent; for my $file ('schema05.yaml', 'document05a.yaml', 'document05b.yaml') { my($tmpfh,$tmpfile) = File::Temp::tempfile(SUFFIX => '.json', UNLINK => 1); my $data = YAML::Syck::LoadFile("$FindBin::RealBin/testdata/$file"); if (defined &JSON::to_json) { print $tmpfh JSON::to_json($data, {utf8 => 1}); } else { print $tmpfh JSON::objToJson($data); } close $tmpfh or die "Can't write JSON data to $tmpfile: $!"; $json_equivalent{$file} = $tmpfile; } push @json_defs, ([$json_equivalent{'schema05.yaml'}, $json_equivalent{'document05a.yaml'}, 1], [$json_equivalent{'schema05.yaml'}, $json_equivalent{'document05b.yaml'}, 0], ); } my $v; GetOptions("v!") or die "usage: $0 [-v]"; my $tests_per_case = 3; plan tests => 13 + $tests_per_case*(scalar(@yaml_syck_defs) + scalar(@json_defs)); my $script = "$FindBin::RealBin/../blib/script/pkwalify"; my @cmd = ($^X, "-Mblib=$FindBin::RealBin/..", $script, "-s"); SKIP: { skip("Need YAML::Syck for tests", $tests_per_case*scalar(@yaml_syck_defs)) if !eval { require YAML::Syck; 1 }; for my $def (@yaml_syck_defs) { any_test($def); } } SKIP: { skip("Need JSON for tests", $tests_per_case*scalar(@json_defs)) if !eval { require JSON; 1 }; for my $def (@json_defs) { any_test($def); } } { my $result = run_pkwalify(); is($result->{success}, 0, "No success without options"); SKIP: { skip("Skip STDERR test", 1) if !$result->{can_capture}; like($result->{stderr}, qr{-f option is mandatory}, "usage -f"); } } { my $result = run_pkwalify("-xxx"); is($result->{success}, 0, "Invalid option"); SKIP: { skip("Skip STDERR test", 1) if !$result->{can_capture}; like($result->{stderr}, qr{usage}, "got usage"); } } { my $result = run_pkwalify("-f", "foo"); is($result->{success}, 0, "Missing data file"); SKIP: { skip("Skip STDERR test", 1) if !$result->{can_capture}; like($result->{stderr}, qr{datafile is mandatory}, "usage datafile"); } } { my $result = run_pkwalify("-f", $0, $0); is($result->{success}, 0, "No YAML/JSON file"); SKIP: { skip("Skip STDERR test", 1) if !$result->{can_capture}; like($result->{stderr}, qr{cannot parse}i, "cannot parse file"); } } SKIP: { skip("Need YAML::Syck for tests", 4) if !eval { require YAML::Syck; 1 }; my $schema_file = "schema05.yaml"; my $data_file = "document05a.yaml"; for ($schema_file, $data_file) { if (!File::Spec->file_name_is_absolute($_)) { $_ = "$FindBin::RealBin/testdata/$_"; } } { my @args = ('-f', $schema_file, $data_file, '-s'); my $result = run_pkwalify_non_silent(@args); is($result->{success}, 1, "Success with -s"); SKIP: { skip("Skip STDOUT test", 1) if !$result->{can_capture}; is($result->{stdout}, "", "silent output"); } } { my @args = ('-f', $schema_file, $data_file); my $result = run_pkwalify_non_silent(@args); is($result->{success}, 1, "Success without -s"); SKIP: { skip("Skip STDOUT test", 1) if !$result->{can_capture}; like($result->{stdout}, qr{\Q: valid.}, "non-silent output for validity"); } } } sub any_test { my($def) = @_; local $Test::Builder::Level = $Test::Builder::Level+1; my($schema_file, $data_file, $expect_validity) = @$def; for ($schema_file, $data_file) { if (!File::Spec->file_name_is_absolute($_)) { $_ = "$FindBin::RealBin/testdata/$_"; } } my @args = ('-f' => $schema_file, $data_file); my $result = run_pkwalify(@args); my($valid, $stdin, $stdout, $stderr, $can_capture) = @{$result}{qw(success stdin stdout stderr can_capture)}; if ($can_capture) { if (!$valid) { diag "STDOUT=$stdout\nSTDERR=$stderr\n" if $v; } SKIP: { skip("Older blib versions write to STDERR", 2) if $skip_warnings_test; if ($valid) { is($stdout, "", "No warnings in @args"); } else { isnt($stdout, "", "There are warnings in @args"); } is($stderr, "", "Nothing in STDERR"); } } else { SKIP: { skip("No stdout/stderr tests without IPC::Run", 2) } } is($valid, $expect_validity, "@args") or diag("@args"); } sub _run_pkwalify { my(@cmd) = @_; my($success,$stdin,$stdout,$stderr,$can_capture); if (eval { require IPC::Run; 1 }) { $can_capture = 1; $success = IPC::Run::run(\@cmd, \$stdin, \$stdout, \$stderr) ? 1 : 0; } else { *OLDOUT = *OLDOUT; # cease -w *OLDERR = *OLDERR; # cease -w open(OLDOUT, ">&STDOUT") or die $!; open(OLDERR, ">&STDERR") or die $!; open(STDOUT, ">".File::Spec->devnull) or die $!; open(STDERR, ">".File::Spec->devnull) or die $!; system(@cmd); close STDERR; close STDOUT; open(STDERR, ">&OLDERR") or die $!; open(STDOUT, ">&OLDOUT") or die $!; $success = $? == 0 ? 1 : 0; } return { success => $success, stdin => $stdin, stdout => $stdout, stderr => $stderr, can_capture => $can_capture, }; } sub run_pkwalify { my(@args) = @_; my @cmd = (@cmd, @args); _run_pkwalify(@cmd); } sub run_pkwalify_non_silent { my(@args) = @_; my(@cmd) = grep { $_ ne '-s' } @cmd; push @cmd, @args; _run_pkwalify(@cmd); } # Should be last because of STDERR redirection { open(STDERR, ">" . File::Spec->devnull); system($^X, "-c", "-Mblib=$FindBin::RealBin/..", $script); ok($?==0, "$script compiles OK"); } __END__ p5-Kwalify-1.22/t/testdata/000077500000000000000000000000001153155540400154455ustar00rootroot00000000000000p5-Kwalify-1.22/t/testdata/META-spec-1.3.yml000066400000000000000000000053521153155540400201520ustar00rootroot00000000000000# META.yml specification 1.3 type: map mapping: meta-spec: type: map required: yes comment: exact specification missing mapping: version: &optional_version type: text pattern: /^[\d_]+(\.[\d_]+)*$/ required: no url: &required_url type: text pattern: /^((ftp|https?):\/\/|mailto:.*@)/ required: yes name: type: text required: yes version: &required_version type: text pattern: /^[\d_]+(\.[\d_]+)*$/ required: yes abstract: type: text required: yes author: type: seq comment: preferred form is "author-name " required: yes sequence: - type: text license: type: text required: yes enum: - perl - gpl - lgpl - artistic - bsd - open_source - unrestricted - restrictive distribution_type: type: text required: no enum: - module - script requires: &requires type: map required: no mapping: =: &required_version_range type: text pattern: "/^((>|>=|==|!=|<|<=)\s*)?[\d_]+(\.[\d_]+)*(,\s*((>|>=|==|!=|<|<=)\s*)?[\d_]+(\.[\d_]+)*)*$/" required: yes recommends: *requires optional_features: type: map mapping: =: type: map mapping: description: type: text requires: *requires build_requires: *requires conflicts: *requires requires_packages: comment: exact specification missing type: any requires_os: comment: exact specification missing type: any excludes_os: comment: exact specification missing type: any build_requires: *requires conflicts: *requires dynamic_config: type: bool required: no provides: type: map required: no mapping: =: type: map mapping: file: type: text version: *optional_version no_index: &no_index type: map required: no mapping: file: &no_index_element type: seq required: no sequence: - type: text directory: *no_index_element package: *no_index_element namespace: *no_index_element private: *no_index keywords: type: seq required: no sequence: - type: text resources: type: map required: no mapping: license: &optional_url type: text pattern: /^((ftp|https?|git):\/\/|mailto:.*@)/ required: no homepage: *optional_url bugtracker: *optional_url repository: *optional_url # missing in spec =: *optional_url generated_by: type: text required: yes p5-Kwalify-1.22/t/testdata/document05a.yaml000066400000000000000000000003211153155540400204510ustar00rootroot00000000000000- name: foo email: foo@mail.com password: xxx123456 age: 20 blood: A birth: 1985-01-01 - name: bar email: bar@mail.net age: 25 blood: AB birth: 1980-01-01 p5-Kwalify-1.22/t/testdata/document05b.yaml000066400000000000000000000003531153155540400204570ustar00rootroot00000000000000- name: foo email: foo(at)mail.com password: xxx123 age: twenty blood: a birth: 1985-01-01 - given-name: bar family-name: Bar email: bar@mail.net age: 15 blood: AB birth: 1980/01/01 p5-Kwalify-1.22/t/testdata/kwalify.yaml000066400000000000000000000030211153155540400177730ustar00rootroot00000000000000name: MAIN type: map required: yes mapping: &main-rule "name": type: str "desc": type: str "classname": type: str "type": type: str #required: yes enum: - seq #- sequence #- list - map #- mapping #- hash - str #- string - int #- integer - float - number #- numeric - bool #- boolean - text - date - time - timestamp #- object - any - scalar #- collection "required": type: bool "enum": type: seq sequence: - type: scalar unique: yes "pattern": type: str "assert": type: str pattern: /\bval\b/ "range": type: map mapping: "max": type: scalar "min": type: scalar "max-ex": type: scalar "min-ex": type: scalar "length": type: map mapping: "max": type: int "min": type: int "max-ex": type: int "min-ex": type: int "ident": type: bool "unique": type: bool "sequence": name: SEQUENCE type: seq sequence: - type: map mapping: *main-rule name: MAIN #required: yes "mapping": name: MAPPING type: map mapping: =: type: map mapping: *main-rule name: MAIN #required: yes p5-Kwalify-1.22/t/testdata/schema05.yaml000066400000000000000000000016021153155540400177350ustar00rootroot00000000000000type: seq # new rule sequence: - type: map # new rule mapping: name: type: str # new rule required: yes email: type: str # new rule required: yes pattern: /@/ password: type: text # new rule length: { max: 16, min: 8 } age: type: int # new rule range: { max: 30, min: 18 } # or assert: 18 <= val && val <= 30 blood: type: str # new rule enum: - A - B - O - AB birth: type: date # new rule memo: type: any # new rule